* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Function>: Make sure
[official-gcc.git] / gcc / ada / gcc-interface / trans.c
blob418f923b2bfd8bf67f1de56b3ea9f64b1cc93454
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * T R A N S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2015, 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 "tm.h"
30 #include "vec.h"
31 #include "alias.h"
32 #include "symtab.h"
33 #include "inchash.h"
34 #include "tree.h"
35 #include "fold-const.h"
36 #include "stringpool.h"
37 #include "stor-layout.h"
38 #include "stmt.h"
39 #include "varasm.h"
40 #include "flags.h"
41 #include "output.h"
42 #include "libfuncs.h" /* For set_stack_check_libfunc. */
43 #include "tree-iterator.h"
44 #include "gimple-expr.h"
45 #include "gimplify.h"
46 #include "bitmap.h"
47 #include "hash-map.h"
48 #include "plugin-api.h"
49 #include "hard-reg-set.h"
50 #include "function.h"
51 #include "ipa-ref.h"
52 #include "cgraph.h"
53 #include "diagnostic.h"
54 #include "opts.h"
55 #include "target.h"
56 #include "common/common-target.h"
58 #include "ada.h"
59 #include "adadecode.h"
60 #include "types.h"
61 #include "atree.h"
62 #include "elists.h"
63 #include "namet.h"
64 #include "nlists.h"
65 #include "snames.h"
66 #include "stringt.h"
67 #include "uintp.h"
68 #include "urealp.h"
69 #include "fe.h"
70 #include "sinfo.h"
71 #include "einfo.h"
72 #include "gadaint.h"
73 #include "ada-tree.h"
74 #include "gigi.h"
76 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
77 for fear of running out of stack space. If we need more, we use xmalloc
78 instead. */
79 #define ALLOCA_THRESHOLD 1000
81 /* In configurations where blocks have no end_locus attached, just
82 sink assignments into a dummy global. */
83 #ifndef BLOCK_SOURCE_END_LOCATION
84 static location_t block_end_locus_sink;
85 #define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink
86 #endif
88 /* Pointers to front-end tables accessed through macros. */
89 struct Node *Nodes_Ptr;
90 struct Flags *Flags_Ptr;
91 Node_Id *Next_Node_Ptr;
92 Node_Id *Prev_Node_Ptr;
93 struct Elist_Header *Elists_Ptr;
94 struct Elmt_Item *Elmts_Ptr;
95 struct String_Entry *Strings_Ptr;
96 Char_Code *String_Chars_Ptr;
97 struct List_Header *List_Headers_Ptr;
99 /* Highest number in the front-end node table. */
100 int max_gnat_nodes;
102 /* Current node being treated, in case abort called. */
103 Node_Id error_gnat_node;
105 /* True when gigi is being called on an analyzed but unexpanded
106 tree, and the only purpose of the call is to properly annotate
107 types with representation information. */
108 bool type_annotate_only;
110 /* Current filename without path. */
111 const char *ref_filename;
114 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
115 static vec<Node_Id> gnat_validate_uc_list;
117 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
118 of unconstrained array IN parameters to avoid emitting a great deal of
119 redundant instructions to recompute them each time. */
120 struct GTY (()) parm_attr_d {
121 int id; /* GTY doesn't like Entity_Id. */
122 int dim;
123 tree first;
124 tree last;
125 tree length;
128 typedef struct parm_attr_d *parm_attr;
131 struct GTY(()) language_function {
132 vec<parm_attr, va_gc> *parm_attr_cache;
133 bitmap named_ret_val;
134 vec<tree, va_gc> *other_ret_val;
135 int gnat_ret;
138 #define f_parm_attr_cache \
139 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
141 #define f_named_ret_val \
142 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
144 #define f_other_ret_val \
145 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
147 #define f_gnat_ret \
148 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
150 /* A structure used to gather together information about a statement group.
151 We use this to gather related statements, for example the "then" part
152 of a IF. In the case where it represents a lexical scope, we may also
153 have a BLOCK node corresponding to it and/or cleanups. */
155 struct GTY((chain_next ("%h.previous"))) stmt_group {
156 struct stmt_group *previous; /* Previous code group. */
157 tree stmt_list; /* List of statements for this code group. */
158 tree block; /* BLOCK for this code group, if any. */
159 tree cleanups; /* Cleanups for this code group, if any. */
162 static GTY(()) struct stmt_group *current_stmt_group;
164 /* List of unused struct stmt_group nodes. */
165 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
167 /* A structure used to record information on elaboration procedures
168 we've made and need to process.
170 ??? gnat_node should be Node_Id, but gengtype gets confused. */
172 struct GTY((chain_next ("%h.next"))) elab_info {
173 struct elab_info *next; /* Pointer to next in chain. */
174 tree elab_proc; /* Elaboration procedure. */
175 int gnat_node; /* The N_Compilation_Unit. */
178 static GTY(()) struct elab_info *elab_info_list;
180 /* Stack of exception pointer variables. Each entry is the VAR_DECL
181 that stores the address of the raised exception. Nonzero means we
182 are in an exception handler. Not used in the zero-cost case. */
183 static GTY(()) vec<tree, va_gc> *gnu_except_ptr_stack;
185 /* In ZCX case, current exception pointer. Used to re-raise it. */
186 static GTY(()) tree gnu_incoming_exc_ptr;
188 /* Stack for storing the current elaboration procedure decl. */
189 static GTY(()) vec<tree, va_gc> *gnu_elab_proc_stack;
191 /* Stack of labels to be used as a goto target instead of a return in
192 some functions. See processing for N_Subprogram_Body. */
193 static GTY(()) vec<tree, va_gc> *gnu_return_label_stack;
195 /* Stack of variable for the return value of a function with copy-in/copy-out
196 parameters. See processing for N_Subprogram_Body. */
197 static GTY(()) vec<tree, va_gc> *gnu_return_var_stack;
199 /* Structure used to record information for a range check. */
200 struct GTY(()) range_check_info_d {
201 tree low_bound;
202 tree high_bound;
203 tree type;
204 tree invariant_cond;
207 typedef struct range_check_info_d *range_check_info;
210 /* Structure used to record information for a loop. */
211 struct GTY(()) loop_info_d {
212 tree stmt;
213 tree loop_var;
214 vec<range_check_info, va_gc> *checks;
217 typedef struct loop_info_d *loop_info;
220 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
221 static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
223 /* The stacks for N_{Push,Pop}_*_Label. */
224 static GTY(()) vec<tree, va_gc> *gnu_constraint_error_label_stack;
225 static GTY(()) vec<tree, va_gc> *gnu_storage_error_label_stack;
226 static GTY(()) vec<tree, va_gc> *gnu_program_error_label_stack;
228 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
229 static enum tree_code gnu_codes[Number_Node_Kinds];
231 static void init_code_table (void);
232 static void Compilation_Unit_to_gnu (Node_Id);
233 static void record_code_position (Node_Id);
234 static void insert_code_for (Node_Id);
235 static void add_cleanup (tree, Node_Id);
236 static void add_stmt_list (List_Id);
237 static void push_exception_label_stack (vec<tree, va_gc> **, Entity_Id);
238 static tree build_stmt_group (List_Id, bool);
239 static inline bool stmt_group_may_fallthru (void);
240 static enum gimplify_status gnat_gimplify_stmt (tree *);
241 static void elaborate_all_entities (Node_Id);
242 static void process_freeze_entity (Node_Id);
243 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
244 static tree emit_range_check (tree, Node_Id, Node_Id);
245 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
246 static tree emit_check (tree, tree, int, Node_Id);
247 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
248 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
249 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
250 static bool addressable_p (tree, tree);
251 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
252 static tree extract_values (tree, tree);
253 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
254 static void validate_unchecked_conversion (Node_Id);
255 static tree maybe_implicit_deref (tree);
256 static void set_expr_location_from_node (tree, Node_Id);
257 static void set_expr_location_from_node1 (tree, Node_Id, bool);
258 static bool Sloc_to_locus1 (Source_Ptr, location_t *, bool);
259 static bool set_end_locus_from_node (tree, Node_Id);
260 static void set_gnu_expr_location_from_node (tree, Node_Id);
261 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
262 static tree build_raise_check (int, enum exception_info_kind);
263 static tree create_init_temporary (const char *, tree, tree *, Node_Id);
265 /* Hooks for debug info back-ends, only supported and used in a restricted set
266 of configurations. */
267 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
268 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
270 /* This is the main program of the back-end. It sets up all the table
271 structures and then generates code. */
273 void
274 gigi (Node_Id gnat_root,
275 int max_gnat_node,
276 int number_name ATTRIBUTE_UNUSED,
277 struct Node *nodes_ptr,
278 struct Flags *flags_ptr,
279 Node_Id *next_node_ptr,
280 Node_Id *prev_node_ptr,
281 struct Elist_Header *elists_ptr,
282 struct Elmt_Item *elmts_ptr,
283 struct String_Entry *strings_ptr,
284 Char_Code *string_chars_ptr,
285 struct List_Header *list_headers_ptr,
286 Nat number_file,
287 struct File_Info_Type *file_info_ptr,
288 Entity_Id standard_boolean,
289 Entity_Id standard_integer,
290 Entity_Id standard_character,
291 Entity_Id standard_long_long_float,
292 Entity_Id standard_exception_type,
293 Int gigi_operating_mode)
295 Node_Id gnat_iter;
296 Entity_Id gnat_literal;
297 tree t, ftype, int64_type;
298 struct elab_info *info;
299 int i;
301 max_gnat_nodes = max_gnat_node;
303 Nodes_Ptr = nodes_ptr;
304 Flags_Ptr = flags_ptr;
305 Next_Node_Ptr = next_node_ptr;
306 Prev_Node_Ptr = prev_node_ptr;
307 Elists_Ptr = elists_ptr;
308 Elmts_Ptr = elmts_ptr;
309 Strings_Ptr = strings_ptr;
310 String_Chars_Ptr = string_chars_ptr;
311 List_Headers_Ptr = list_headers_ptr;
313 type_annotate_only = (gigi_operating_mode == 1);
315 for (i = 0; i < number_file; i++)
317 /* Use the identifier table to make a permanent copy of the filename as
318 the name table gets reallocated after Gigi returns but before all the
319 debugging information is output. The __gnat_to_canonical_file_spec
320 call translates filenames from pragmas Source_Reference that contain
321 host style syntax not understood by gdb. */
322 const char *filename
323 = IDENTIFIER_POINTER
324 (get_identifier
325 (__gnat_to_canonical_file_spec
326 (Get_Name_String (file_info_ptr[i].File_Name))));
328 /* We rely on the order isomorphism between files and line maps. */
329 gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i);
331 /* We create the line map for a source file at once, with a fixed number
332 of columns chosen to avoid jumping over the next power of 2. */
333 linemap_add (line_table, LC_ENTER, 0, filename, 1);
334 linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
335 linemap_position_for_column (line_table, 252 - 1);
336 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
339 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
341 /* Declare the name of the compilation unit as the first global
342 name in order to make the middle-end fully deterministic. */
343 t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
344 first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
346 /* Initialize ourselves. */
347 init_code_table ();
348 init_gnat_decl ();
349 init_gnat_utils ();
351 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
352 errors. */
353 if (type_annotate_only)
355 TYPE_SIZE (void_type_node) = bitsize_zero_node;
356 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
359 /* Enable GNAT stack checking method if needed */
360 if (!Stack_Check_Probes_On_Target)
361 set_stack_check_libfunc ("_gnat_stack_check");
363 /* Retrieve alignment settings. */
364 double_float_alignment = get_target_double_float_alignment ();
365 double_scalar_alignment = get_target_double_scalar_alignment ();
367 /* Record the builtin types. Define `integer' and `character' first so that
368 dbx will output them first. */
369 record_builtin_type ("integer", integer_type_node, false);
370 record_builtin_type ("character", unsigned_char_type_node, false);
371 record_builtin_type ("boolean", boolean_type_node, false);
372 record_builtin_type ("void", void_type_node, false);
374 /* Save the type we made for integer as the type for Standard.Integer. */
375 save_gnu_tree (Base_Type (standard_integer),
376 TYPE_NAME (integer_type_node),
377 false);
379 /* Likewise for character as the type for Standard.Character. */
380 save_gnu_tree (Base_Type (standard_character),
381 TYPE_NAME (unsigned_char_type_node),
382 false);
384 /* Likewise for boolean as the type for Standard.Boolean. */
385 save_gnu_tree (Base_Type (standard_boolean),
386 TYPE_NAME (boolean_type_node),
387 false);
388 gnat_literal = First_Literal (Base_Type (standard_boolean));
389 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
390 gcc_assert (t == boolean_false_node);
391 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
392 boolean_type_node, t, true, false, false, false,
393 NULL, gnat_literal);
394 DECL_IGNORED_P (t) = 1;
395 save_gnu_tree (gnat_literal, t, false);
396 gnat_literal = Next_Literal (gnat_literal);
397 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
398 gcc_assert (t == boolean_true_node);
399 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
400 boolean_type_node, t, true, false, false, false,
401 NULL, gnat_literal);
402 DECL_IGNORED_P (t) = 1;
403 save_gnu_tree (gnat_literal, t, false);
405 void_ftype = build_function_type_list (void_type_node, NULL_TREE);
406 ptr_void_ftype = build_pointer_type (void_ftype);
408 /* Now declare run-time functions. */
409 ftype = build_function_type_list (ptr_type_node, sizetype, NULL_TREE);
411 /* malloc is a function declaration tree for a function to allocate
412 memory. */
413 malloc_decl
414 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
415 ftype, NULL_TREE, is_disabled, true, true, true,
416 NULL, Empty);
417 DECL_IS_MALLOC (malloc_decl) = 1;
419 /* free is a function declaration tree for a function to free memory. */
420 free_decl
421 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
422 build_function_type_list (void_type_node,
423 ptr_type_node,
424 NULL_TREE),
425 NULL_TREE, is_disabled, true, true, true, NULL,
426 Empty);
428 /* This is used for 64-bit multiplication with overflow checking. */
429 int64_type = gnat_type_for_size (64, 0);
430 mulv64_decl
431 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
432 build_function_type_list (int64_type, int64_type,
433 int64_type, NULL_TREE),
434 NULL_TREE, is_disabled, true, true, true, NULL,
435 Empty);
437 /* Name of the _Parent field in tagged record types. */
438 parent_name_id = get_identifier (Get_Name_String (Name_uParent));
440 /* Name of the Exception_Data type defined in System.Standard_Library. */
441 exception_data_name_id
442 = get_identifier ("system__standard_library__exception_data");
444 /* Make the types and functions used for exception processing. */
445 jmpbuf_type
446 = build_array_type (gnat_type_for_mode (Pmode, 0),
447 build_index_type (size_int (5)));
448 record_builtin_type ("JMPBUF_T", jmpbuf_type, true);
449 jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
451 /* Functions to get and set the jumpbuf pointer for the current thread. */
452 get_jmpbuf_decl
453 = create_subprog_decl
454 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
455 NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
456 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
457 DECL_IGNORED_P (get_jmpbuf_decl) = 1;
459 set_jmpbuf_decl
460 = create_subprog_decl
461 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
462 NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
463 NULL_TREE),
464 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
465 DECL_IGNORED_P (set_jmpbuf_decl) = 1;
467 /* setjmp returns an integer and has one operand, which is a pointer to
468 a jmpbuf. */
469 setjmp_decl
470 = create_subprog_decl
471 (get_identifier ("__builtin_setjmp"), NULL_TREE,
472 build_function_type_list (integer_type_node, jmpbuf_ptr_type,
473 NULL_TREE),
474 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
475 DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
476 DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
478 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
479 address. */
480 update_setjmp_buf_decl
481 = create_subprog_decl
482 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
483 build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
484 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
485 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
486 DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
488 /* Hooks to call when entering/leaving an exception handler. */
489 ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
491 begin_handler_decl
492 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
493 ftype, NULL_TREE, is_disabled, true, true, true,
494 NULL, Empty);
495 DECL_IGNORED_P (begin_handler_decl) = 1;
497 end_handler_decl
498 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
499 ftype, NULL_TREE, is_disabled, true, true, true,
500 NULL, Empty);
501 DECL_IGNORED_P (end_handler_decl) = 1;
503 unhandled_except_decl
504 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
505 NULL_TREE,
506 ftype, NULL_TREE, is_disabled, true, true, true,
507 NULL, Empty);
508 DECL_IGNORED_P (unhandled_except_decl) = 1;
510 reraise_zcx_decl
511 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
512 ftype, NULL_TREE, is_disabled, true, true, true,
513 NULL, Empty);
514 /* Indicate that these never return. */
515 DECL_IGNORED_P (reraise_zcx_decl) = 1;
516 TREE_THIS_VOLATILE (reraise_zcx_decl) = 1;
517 TREE_SIDE_EFFECTS (reraise_zcx_decl) = 1;
518 TREE_TYPE (reraise_zcx_decl)
519 = build_qualified_type (TREE_TYPE (reraise_zcx_decl), TYPE_QUAL_VOLATILE);
521 /* If in no exception handlers mode, all raise statements are redirected to
522 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
523 this procedure will never be called in this mode. */
524 if (No_Exception_Handlers_Set ())
526 tree decl
527 = create_subprog_decl
528 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
529 build_function_type_list (void_type_node,
530 build_pointer_type
531 (unsigned_char_type_node),
532 integer_type_node, NULL_TREE),
533 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
534 TREE_THIS_VOLATILE (decl) = 1;
535 TREE_SIDE_EFFECTS (decl) = 1;
536 TREE_TYPE (decl)
537 = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
538 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
539 gnat_raise_decls[i] = decl;
541 else
543 /* Otherwise, make one decl for each exception reason. */
544 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
545 gnat_raise_decls[i] = build_raise_check (i, exception_simple);
546 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
547 gnat_raise_decls_ext[i]
548 = build_raise_check (i,
549 i == CE_Index_Check_Failed
550 || i == CE_Range_Check_Failed
551 || i == CE_Invalid_Data
552 ? exception_range : exception_column);
555 /* Set the types that GCC and Gigi use from the front end. */
556 except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type));
558 /* Make other functions used for exception processing. */
559 get_excptr_decl
560 = create_subprog_decl
561 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
562 build_function_type_list (build_pointer_type (except_type_node),
563 NULL_TREE),
564 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
565 DECL_IGNORED_P (get_excptr_decl) = 1;
567 set_exception_parameter_decl
568 = create_subprog_decl
569 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
570 build_function_type_list (void_type_node, ptr_type_node, ptr_type_node,
571 NULL_TREE),
572 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
574 raise_nodefer_decl
575 = create_subprog_decl
576 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
577 build_function_type_list (void_type_node,
578 build_pointer_type (except_type_node),
579 NULL_TREE),
580 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
582 /* Indicate that it never returns. */
583 TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
584 TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
585 TREE_TYPE (raise_nodefer_decl)
586 = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
587 TYPE_QUAL_VOLATILE);
589 /* Build the special descriptor type and its null node if needed. */
590 if (TARGET_VTABLE_USES_DESCRIPTORS)
592 tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
593 tree field_list = NULL_TREE;
594 int j;
595 vec<constructor_elt, va_gc> *null_vec = NULL;
596 constructor_elt *elt;
598 fdesc_type_node = make_node (RECORD_TYPE);
599 vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS);
600 elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
602 for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
604 tree field
605 = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
606 NULL_TREE, NULL_TREE, 0, 1);
607 DECL_CHAIN (field) = field_list;
608 field_list = field;
609 elt->index = field;
610 elt->value = null_node;
611 elt--;
614 finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
615 record_builtin_type ("descriptor", fdesc_type_node, true);
616 null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
619 longest_float_type_node
620 = get_unpadded_type (Base_Type (standard_long_long_float));
622 /* Dummy objects to materialize "others" and "all others" in the exception
623 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
624 the types to use. */
625 others_decl
626 = create_var_decl (get_identifier ("OTHERS"),
627 get_identifier ("__gnat_others_value"),
628 unsigned_char_type_node,
629 NULL_TREE, true, false, true, false, NULL, Empty);
631 all_others_decl
632 = create_var_decl (get_identifier ("ALL_OTHERS"),
633 get_identifier ("__gnat_all_others_value"),
634 unsigned_char_type_node,
635 NULL_TREE, true, false, true, false, NULL, Empty);
637 unhandled_others_decl
638 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
639 get_identifier ("__gnat_unhandled_others_value"),
640 unsigned_char_type_node,
641 NULL_TREE, true, false, true, false, NULL, Empty);
643 main_identifier_node = get_identifier ("main");
645 /* Install the builtins we might need, either internally or as
646 user available facilities for Intrinsic imports. */
647 gnat_install_builtins ();
649 vec_safe_push (gnu_except_ptr_stack, NULL_TREE);
650 vec_safe_push (gnu_constraint_error_label_stack, NULL_TREE);
651 vec_safe_push (gnu_storage_error_label_stack, NULL_TREE);
652 vec_safe_push (gnu_program_error_label_stack, NULL_TREE);
654 /* Process any Pragma Ident for the main unit. */
655 if (Present (Ident_String (Main_Unit)))
656 targetm.asm_out.output_ident
657 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
659 /* If we are using the GCC exception mechanism, let GCC know. */
660 if (Exception_Mechanism == Back_End_Exceptions)
661 gnat_init_gcc_eh ();
663 /* Initialize the GCC support for FP operations. */
664 gnat_init_gcc_fp ();
666 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
667 if (No_Strict_Aliasing_CP)
668 flag_strict_aliasing = 0;
670 /* Save the current optimization options again after the above possible
671 global_options changes. */
672 optimization_default_node = build_optimization_node (&global_options);
673 optimization_current_node = optimization_default_node;
675 /* Now translate the compilation unit proper. */
676 Compilation_Unit_to_gnu (gnat_root);
678 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
679 the very end to avoid having to second-guess the front-end when we run
680 into dummy nodes during the regular processing. */
681 for (i = 0; gnat_validate_uc_list.iterate (i, &gnat_iter); i++)
682 validate_unchecked_conversion (gnat_iter);
683 gnat_validate_uc_list.release ();
685 /* Finally see if we have any elaboration procedures to deal with. */
686 for (info = elab_info_list; info; info = info->next)
688 tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
690 /* We should have a BIND_EXPR but it may not have any statements in it.
691 If it doesn't have any, we have nothing to do except for setting the
692 flag on the GNAT node. Otherwise, process the function as others. */
693 gnu_stmts = gnu_body;
694 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
695 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
696 if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
697 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
698 else
700 begin_subprog_body (info->elab_proc);
701 end_subprog_body (gnu_body);
702 rest_of_subprog_body_compilation (info->elab_proc);
706 /* Destroy ourselves. */
707 destroy_gnat_decl ();
708 destroy_gnat_utils ();
710 /* We cannot track the location of errors past this point. */
711 error_gnat_node = Empty;
714 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
715 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
717 static tree
718 build_raise_check (int check, enum exception_info_kind kind)
720 tree result, ftype;
721 const char pfx[] = "__gnat_rcheck_";
723 strcpy (Name_Buffer, pfx);
724 Name_Len = sizeof (pfx) - 1;
725 Get_RT_Exception_Name (check);
727 if (kind == exception_simple)
729 Name_Buffer[Name_Len] = 0;
730 ftype
731 = build_function_type_list (void_type_node,
732 build_pointer_type
733 (unsigned_char_type_node),
734 integer_type_node, NULL_TREE);
736 else
738 tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
740 strcpy (Name_Buffer + Name_Len, "_ext");
741 Name_Buffer[Name_Len + 4] = 0;
742 ftype
743 = build_function_type_list (void_type_node,
744 build_pointer_type
745 (unsigned_char_type_node),
746 integer_type_node, integer_type_node,
747 t, t, NULL_TREE);
750 result
751 = create_subprog_decl (get_identifier (Name_Buffer),
752 NULL_TREE, ftype, NULL_TREE,
753 is_disabled, true, true, true, NULL, Empty);
755 /* Indicate that it never returns. */
756 TREE_THIS_VOLATILE (result) = 1;
757 TREE_SIDE_EFFECTS (result) = 1;
758 TREE_TYPE (result)
759 = build_qualified_type (TREE_TYPE (result), TYPE_QUAL_VOLATILE);
761 return result;
764 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
765 an N_Attribute_Reference. */
767 static int
768 lvalue_required_for_attribute_p (Node_Id gnat_node)
770 switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
772 case Attr_Pos:
773 case Attr_Val:
774 case Attr_Pred:
775 case Attr_Succ:
776 case Attr_First:
777 case Attr_Last:
778 case Attr_Range_Length:
779 case Attr_Length:
780 case Attr_Object_Size:
781 case Attr_Value_Size:
782 case Attr_Component_Size:
783 case Attr_Descriptor_Size:
784 case Attr_Max_Size_In_Storage_Elements:
785 case Attr_Min:
786 case Attr_Max:
787 case Attr_Null_Parameter:
788 case Attr_Passed_By_Reference:
789 case Attr_Mechanism_Code:
790 case Attr_Machine:
791 case Attr_Model:
792 return 0;
794 case Attr_Address:
795 case Attr_Access:
796 case Attr_Unchecked_Access:
797 case Attr_Unrestricted_Access:
798 case Attr_Code_Address:
799 case Attr_Pool_Address:
800 case Attr_Size:
801 case Attr_Alignment:
802 case Attr_Bit_Position:
803 case Attr_Position:
804 case Attr_First_Bit:
805 case Attr_Last_Bit:
806 case Attr_Bit:
807 case Attr_Asm_Input:
808 case Attr_Asm_Output:
809 default:
810 return 1;
814 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
815 is the type that will be used for GNAT_NODE in the translated GNU tree.
816 CONSTANT indicates whether the underlying object represented by GNAT_NODE
817 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
818 whether its value is the address of a constant and ALIASED whether it is
819 aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
821 The function climbs up the GNAT tree starting from the node and returns 1
822 upon encountering a node that effectively requires an lvalue downstream.
823 It returns int instead of bool to facilitate usage in non-purely binary
824 logic contexts. */
826 static int
827 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
828 bool address_of_constant, bool aliased)
830 Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
832 switch (Nkind (gnat_parent))
834 case N_Reference:
835 return 1;
837 case N_Attribute_Reference:
838 return lvalue_required_for_attribute_p (gnat_parent);
840 case N_Parameter_Association:
841 case N_Function_Call:
842 case N_Procedure_Call_Statement:
843 /* If the parameter is by reference, an lvalue is required. */
844 return (!constant
845 || must_pass_by_ref (gnu_type)
846 || default_pass_by_ref (gnu_type));
848 case N_Indexed_Component:
849 /* Only the array expression can require an lvalue. */
850 if (Prefix (gnat_parent) != gnat_node)
851 return 0;
853 /* ??? Consider that referencing an indexed component with a variable
854 index forces the whole aggregate to memory. Note that testing only
855 for literals is conservative, any static expression in the RM sense
856 could probably be accepted with some additional work. */
857 for (gnat_temp = First (Expressions (gnat_parent));
858 Present (gnat_temp);
859 gnat_temp = Next (gnat_temp))
860 if (Nkind (gnat_temp) != N_Character_Literal
861 && Nkind (gnat_temp) != N_Integer_Literal
862 && !(Is_Entity_Name (gnat_temp)
863 && Ekind (Entity (gnat_temp)) == E_Enumeration_Literal))
864 return 1;
866 /* ... fall through ... */
868 case N_Slice:
869 /* Only the array expression can require an lvalue. */
870 if (Prefix (gnat_parent) != gnat_node)
871 return 0;
873 aliased |= Has_Aliased_Components (Etype (gnat_node));
874 return lvalue_required_p (gnat_parent, gnu_type, constant,
875 address_of_constant, aliased);
877 case N_Selected_Component:
878 aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
879 return lvalue_required_p (gnat_parent, gnu_type, constant,
880 address_of_constant, aliased);
882 case N_Object_Renaming_Declaration:
883 /* We need to preserve addresses through a renaming. */
884 return 1;
886 case N_Object_Declaration:
887 /* We cannot use a constructor if this is an atomic object because
888 the actual assignment might end up being done component-wise. */
889 return (!constant
890 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
891 && Is_Atomic_Or_VFA (Defining_Entity (gnat_parent)))
892 /* We don't use a constructor if this is a class-wide object
893 because the effective type of the object is the equivalent
894 type of the class-wide subtype and it smashes most of the
895 data into an array of bytes to which we cannot convert. */
896 || Ekind ((Etype (Defining_Entity (gnat_parent))))
897 == E_Class_Wide_Subtype);
899 case N_Assignment_Statement:
900 /* We cannot use a constructor if the LHS is an atomic object because
901 the actual assignment might end up being done component-wise. */
902 return (!constant
903 || Name (gnat_parent) == gnat_node
904 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
905 && Is_Entity_Name (Name (gnat_parent))
906 && Is_Atomic_Or_VFA (Entity (Name (gnat_parent)))));
908 case N_Unchecked_Type_Conversion:
909 if (!constant)
910 return 1;
912 /* ... fall through ... */
914 case N_Type_Conversion:
915 case N_Qualified_Expression:
916 /* We must look through all conversions because we may need to bypass
917 an intermediate conversion that is meant to be purely formal. */
918 return lvalue_required_p (gnat_parent,
919 get_unpadded_type (Etype (gnat_parent)),
920 constant, address_of_constant, aliased);
922 case N_Allocator:
923 /* We should only reach here through the N_Qualified_Expression case.
924 Force an lvalue for composite types since a block-copy to the newly
925 allocated area of memory is made. */
926 return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
928 case N_Explicit_Dereference:
929 /* We look through dereferences for address of constant because we need
930 to handle the special cases listed above. */
931 if (constant && address_of_constant)
932 return lvalue_required_p (gnat_parent,
933 get_unpadded_type (Etype (gnat_parent)),
934 true, false, true);
936 /* ... fall through ... */
938 default:
939 return 0;
942 gcc_unreachable ();
945 /* Return true if T is a constant DECL node that can be safely replaced
946 by its initializer. */
948 static bool
949 constant_decl_with_initializer_p (tree t)
951 if (!TREE_CONSTANT (t) || !DECL_P (t) || !DECL_INITIAL (t))
952 return false;
954 /* Return false for aggregate types that contain a placeholder since
955 their initializers cannot be manipulated easily. */
956 if (AGGREGATE_TYPE_P (TREE_TYPE (t))
957 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t))
958 && type_contains_placeholder_p (TREE_TYPE (t)))
959 return false;
961 return true;
964 /* Return an expression equivalent to EXP but where constant DECL nodes
965 have been replaced by their initializer. */
967 static tree
968 fold_constant_decl_in_expr (tree exp)
970 enum tree_code code = TREE_CODE (exp);
971 tree op0;
973 switch (code)
975 case CONST_DECL:
976 case VAR_DECL:
977 if (!constant_decl_with_initializer_p (exp))
978 return exp;
980 return DECL_INITIAL (exp);
982 case BIT_FIELD_REF:
983 case COMPONENT_REF:
984 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
985 if (op0 == TREE_OPERAND (exp, 0))
986 return exp;
988 return fold_build3 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
989 TREE_OPERAND (exp, 2));
991 case ARRAY_REF:
992 case ARRAY_RANGE_REF:
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), TREE_OPERAND (exp, 3)));
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 does not equal the Etype of the Entity,
1037 something is wrong with the entity map, probably in generic
1038 instantiation. However, this does not apply to types. Since we sometime
1039 have strange Ekind's, just do this test for objects. Also, if the Etype of
1040 the Entity is private, the Etype of the N_Identifier is allowed to be the
1041 full type and also we consider a packed array type to be the same as the
1042 original type. Similarly, a class-wide type is equivalent to a subtype of
1043 itself. Finally, if the types are Itypes, one may be a copy of the other,
1044 which is also legal. */
1045 gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
1046 ? gnat_node : Entity (gnat_node));
1047 gnat_temp_type = Etype (gnat_temp);
1049 gcc_assert (Etype (gnat_node) == gnat_temp_type
1050 || (Is_Packed (gnat_temp_type)
1051 && (Etype (gnat_node)
1052 == Packed_Array_Impl_Type (gnat_temp_type)))
1053 || (Is_Class_Wide_Type (Etype (gnat_node)))
1054 || (IN (Ekind (gnat_temp_type), Private_Kind)
1055 && Present (Full_View (gnat_temp_type))
1056 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
1057 || (Is_Packed (Full_View (gnat_temp_type))
1058 && (Etype (gnat_node)
1059 == Packed_Array_Impl_Type
1060 (Full_View (gnat_temp_type))))))
1061 || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
1062 || !(Ekind (gnat_temp) == E_Variable
1063 || Ekind (gnat_temp) == E_Component
1064 || Ekind (gnat_temp) == E_Constant
1065 || Ekind (gnat_temp) == E_Loop_Parameter
1066 || IN (Ekind (gnat_temp), Formal_Kind)));
1068 /* If this is a reference to a deferred constant whose partial view is an
1069 unconstrained private type, the proper type is on the full view of the
1070 constant, not on the full view of the type, which may be unconstrained.
1072 This may be a reference to a type, for example in the prefix of the
1073 attribute Position, generated for dispatching code (see Make_DT in
1074 exp_disp,adb). In that case we need the type itself, not is parent,
1075 in particular if it is a derived type */
1076 if (Ekind (gnat_temp) == E_Constant
1077 && Is_Private_Type (gnat_temp_type)
1078 && (Has_Unknown_Discriminants (gnat_temp_type)
1079 || (Present (Full_View (gnat_temp_type))
1080 && Has_Discriminants (Full_View (gnat_temp_type))))
1081 && Present (Full_View (gnat_temp)))
1083 gnat_temp = Full_View (gnat_temp);
1084 gnat_temp_type = Etype (gnat_temp);
1086 else
1088 /* We want to use the Actual_Subtype if it has already been elaborated,
1089 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
1090 simplify things. */
1091 if ((Ekind (gnat_temp) == E_Constant
1092 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
1093 && !(Is_Array_Type (Etype (gnat_temp))
1094 && Present (Packed_Array_Impl_Type (Etype (gnat_temp))))
1095 && Present (Actual_Subtype (gnat_temp))
1096 && present_gnu_tree (Actual_Subtype (gnat_temp)))
1097 gnat_temp_type = Actual_Subtype (gnat_temp);
1098 else
1099 gnat_temp_type = Etype (gnat_node);
1102 /* Expand the type of this identifier first, in case it is an enumeral
1103 literal, which only get made when the type is expanded. There is no
1104 order-of-elaboration issue here. */
1105 gnu_result_type = get_unpadded_type (gnat_temp_type);
1107 /* If this is a non-imported elementary constant with an address clause,
1108 retrieve the value instead of a pointer to be dereferenced unless
1109 an lvalue is required. This is generally more efficient and actually
1110 required if this is a static expression because it might be used
1111 in a context where a dereference is inappropriate, such as a case
1112 statement alternative or a record discriminant. There is no possible
1113 volatile-ness short-circuit here since Volatile constants must be
1114 imported per C.6. */
1115 if (Ekind (gnat_temp) == E_Constant
1116 && Is_Elementary_Type (gnat_temp_type)
1117 && !Is_Imported (gnat_temp)
1118 && Present (Address_Clause (gnat_temp)))
1120 require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
1121 false, Is_Aliased (gnat_temp));
1122 use_constant_initializer = !require_lvalue;
1125 if (use_constant_initializer)
1127 /* If this is a deferred constant, the initializer is attached to
1128 the full view. */
1129 if (Present (Full_View (gnat_temp)))
1130 gnat_temp = Full_View (gnat_temp);
1132 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
1134 else
1135 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
1137 /* Some objects (such as parameters passed by reference, globals of
1138 variable size, and renamed objects) actually represent the address
1139 of the object. In that case, we must do the dereference. Likewise,
1140 deal with parameters to foreign convention subprograms. */
1141 if (DECL_P (gnu_result)
1142 && (DECL_BY_REF_P (gnu_result)
1143 || (TREE_CODE (gnu_result) == PARM_DECL
1144 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
1146 const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
1148 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1149 if (TREE_CODE (gnu_result) == PARM_DECL
1150 && DECL_BY_COMPONENT_PTR_P (gnu_result))
1151 gnu_result
1152 = convert (build_pointer_type (gnu_result_type), gnu_result);
1154 /* If it's a CONST_DECL, return the underlying constant like below. */
1155 else if (TREE_CODE (gnu_result) == CONST_DECL
1156 && !(DECL_CONST_ADDRESS_P (gnu_result)
1157 && lvalue_required_p (gnat_node, gnu_result_type, true,
1158 true, false)))
1159 gnu_result = DECL_INITIAL (gnu_result);
1161 /* If it's a renaming pointer, get to the renamed object. */
1162 if (TREE_CODE (gnu_result) == VAR_DECL
1163 && !DECL_LOOP_PARM_P (gnu_result)
1164 && DECL_RENAMED_OBJECT (gnu_result))
1165 gnu_result = DECL_RENAMED_OBJECT (gnu_result);
1167 /* Otherwise, do the final dereference. */
1168 else
1170 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1172 if ((TREE_CODE (gnu_result) == INDIRECT_REF
1173 || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
1174 && No (Address_Clause (gnat_temp)))
1175 TREE_THIS_NOTRAP (gnu_result) = 1;
1177 if (read_only)
1178 TREE_READONLY (gnu_result) = 1;
1182 /* If we have a constant declaration and its initializer, try to return the
1183 latter to avoid the need to call fold in lots of places and the need for
1184 elaboration code if this identifier is used as an initializer itself. */
1185 if (constant_decl_with_initializer_p (gnu_result))
1187 bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1188 && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1189 bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1190 && DECL_CONST_ADDRESS_P (gnu_result));
1192 /* If there is a (corresponding) variable or this is the address of a
1193 constant, we only want to return the initializer if an lvalue isn't
1194 required. Evaluate this now if we have not already done so. */
1195 if ((!constant_only || address_of_constant) && require_lvalue < 0)
1196 require_lvalue
1197 = lvalue_required_p (gnat_node, gnu_result_type, true,
1198 address_of_constant, Is_Aliased (gnat_temp));
1200 /* Finally retrieve the initializer if this is deemed valid. */
1201 if ((constant_only && !address_of_constant) || !require_lvalue)
1202 gnu_result = DECL_INITIAL (gnu_result);
1205 /* But for a constant renaming we couldn't do that incrementally for its
1206 definition because of the need to return an lvalue so, if the present
1207 context doesn't itself require an lvalue, we try again here. */
1208 else if (Ekind (gnat_temp) == E_Constant
1209 && Is_Elementary_Type (gnat_temp_type)
1210 && Present (Renamed_Object (gnat_temp)))
1212 if (require_lvalue < 0)
1213 require_lvalue
1214 = lvalue_required_p (gnat_node, gnu_result_type, true, false,
1215 Is_Aliased (gnat_temp));
1216 if (!require_lvalue)
1217 gnu_result = fold_constant_decl_in_expr (gnu_result);
1220 /* The GNAT tree has the type of a function set to its result type, so we
1221 adjust here. Also use the type of the result if the Etype is a subtype
1222 that is nominally unconstrained. Likewise if this is a deferred constant
1223 of a discriminated type whose full view can be elaborated statically, to
1224 avoid problematic conversions to the nominal subtype. But remove any
1225 padding from the resulting type. */
1226 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1227 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)
1228 || (Ekind (gnat_temp) == E_Constant
1229 && Present (Full_View (gnat_temp))
1230 && Has_Discriminants (gnat_temp_type)
1231 && TREE_CODE (gnu_result) == CONSTRUCTOR))
1233 gnu_result_type = TREE_TYPE (gnu_result);
1234 if (TYPE_IS_PADDING_P (gnu_result_type))
1235 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1238 *gnu_result_type_p = gnu_result_type;
1240 return gnu_result;
1243 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1244 any statements we generate. */
1246 static tree
1247 Pragma_to_gnu (Node_Id gnat_node)
1249 tree gnu_result = alloc_stmt_list ();
1250 unsigned char pragma_id;
1251 Node_Id gnat_temp;
1253 /* Do nothing if we are just annotating types and check for (and ignore)
1254 unrecognized pragmas. */
1255 if (type_annotate_only
1256 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1257 return gnu_result;
1259 pragma_id = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
1260 switch (pragma_id)
1262 case Pragma_Inspection_Point:
1263 /* Do nothing at top level: all such variables are already viewable. */
1264 if (global_bindings_p ())
1265 break;
1267 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1268 Present (gnat_temp);
1269 gnat_temp = Next (gnat_temp))
1271 Node_Id gnat_expr = Expression (gnat_temp);
1272 tree gnu_expr = gnat_to_gnu (gnat_expr);
1273 int use_address;
1274 machine_mode mode;
1275 tree asm_constraint = NULL_TREE;
1276 #ifdef ASM_COMMENT_START
1277 char *comment;
1278 #endif
1280 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1281 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1283 /* Use the value only if it fits into a normal register,
1284 otherwise use the address. */
1285 mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1286 use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1287 && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1288 || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1290 if (use_address)
1291 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1293 #ifdef ASM_COMMENT_START
1294 comment = concat (ASM_COMMENT_START,
1295 " inspection point: ",
1296 Get_Name_String (Chars (gnat_expr)),
1297 use_address ? " address" : "",
1298 " is in %0",
1299 NULL);
1300 asm_constraint = build_string (strlen (comment), comment);
1301 free (comment);
1302 #endif
1303 gnu_expr = build5 (ASM_EXPR, void_type_node,
1304 asm_constraint,
1305 NULL_TREE,
1306 tree_cons
1307 (build_tree_list (NULL_TREE,
1308 build_string (1, "g")),
1309 gnu_expr, NULL_TREE),
1310 NULL_TREE, NULL_TREE);
1311 ASM_VOLATILE_P (gnu_expr) = 1;
1312 set_expr_location_from_node (gnu_expr, gnat_node);
1313 append_to_statement_list (gnu_expr, &gnu_result);
1315 break;
1317 case Pragma_Loop_Optimize:
1318 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1319 Present (gnat_temp);
1320 gnat_temp = Next (gnat_temp))
1322 tree gnu_loop_stmt = gnu_loop_stack->last ()->stmt;
1324 switch (Chars (Expression (gnat_temp)))
1326 case Name_Ivdep:
1327 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
1328 break;
1330 case Name_No_Unroll:
1331 LOOP_STMT_NO_UNROLL (gnu_loop_stmt) = 1;
1332 break;
1334 case Name_Unroll:
1335 LOOP_STMT_UNROLL (gnu_loop_stmt) = 1;
1336 break;
1338 case Name_No_Vector:
1339 LOOP_STMT_NO_VECTOR (gnu_loop_stmt) = 1;
1340 break;
1342 case Name_Vector:
1343 LOOP_STMT_VECTOR (gnu_loop_stmt) = 1;
1344 break;
1346 default:
1347 gcc_unreachable ();
1350 break;
1352 case Pragma_Optimize:
1353 switch (Chars (Expression
1354 (First (Pragma_Argument_Associations (gnat_node)))))
1356 case Name_Off:
1357 if (optimize)
1358 post_error ("must specify -O0?", gnat_node);
1359 break;
1361 case Name_Space:
1362 if (!optimize_size)
1363 post_error ("must specify -Os?", gnat_node);
1364 break;
1366 case Name_Time:
1367 if (!optimize)
1368 post_error ("insufficient -O value?", gnat_node);
1369 break;
1371 default:
1372 gcc_unreachable ();
1374 break;
1376 case Pragma_Reviewable:
1377 if (write_symbols == NO_DEBUG)
1378 post_error ("must specify -g?", gnat_node);
1379 break;
1381 case Pragma_Warning_As_Error:
1382 case Pragma_Warnings:
1384 Node_Id gnat_expr;
1385 /* Preserve the location of the pragma. */
1386 const location_t location = input_location;
1387 struct cl_option_handlers handlers;
1388 unsigned int option_index;
1389 diagnostic_t kind;
1390 bool imply;
1392 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1394 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1395 if (Nkind (Expression (gnat_temp)) == N_String_Literal)
1397 switch (pragma_id)
1399 case Pragma_Warning_As_Error:
1400 kind = DK_ERROR;
1401 imply = false;
1402 break;
1404 case Pragma_Warnings:
1405 kind = DK_WARNING;
1406 imply = true;
1407 break;
1409 default:
1410 gcc_unreachable ();
1413 gnat_expr = Expression (gnat_temp);
1416 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1417 else if (Nkind (Expression (gnat_temp)) == N_Identifier)
1419 switch (Chars (Expression (gnat_temp)))
1421 case Name_Off:
1422 kind = DK_IGNORED;
1423 break;
1425 case Name_On:
1426 kind = DK_WARNING;
1427 break;
1429 default:
1430 gcc_unreachable ();
1433 /* Deal with optional pattern (but ignore Reason => "..."). */
1434 if (Present (Next (gnat_temp))
1435 && Chars (Next (gnat_temp)) != Name_Reason)
1437 /* pragma Warnings (On | Off, Name) is handled differently. */
1438 if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal)
1439 break;
1441 gnat_expr = Expression (Next (gnat_temp));
1443 else
1444 gnat_expr = Empty;
1446 imply = false;
1449 else
1450 gcc_unreachable ();
1452 /* This is the same implementation as in the C family of compilers. */
1453 if (Present (gnat_expr))
1455 tree gnu_expr = gnat_to_gnu (gnat_expr);
1456 const char *opt_string = TREE_STRING_POINTER (gnu_expr);
1457 const int len = TREE_STRING_LENGTH (gnu_expr);
1458 if (len < 3 || opt_string[0] != '-' || opt_string[1] != 'W')
1459 break;
1460 for (option_index = 0;
1461 option_index < cl_options_count;
1462 option_index++)
1463 if (strcmp (cl_options[option_index].opt_text, opt_string) == 0)
1464 break;
1465 if (option_index == cl_options_count)
1467 post_error ("unknown -W switch", gnat_node);
1468 break;
1471 else
1472 option_index = 0;
1474 set_default_handlers (&handlers);
1475 control_warning_option (option_index, (int) kind, imply, location,
1476 CL_Ada, &handlers, &global_options,
1477 &global_options_set, global_dc);
1479 break;
1481 default:
1482 break;
1485 return gnu_result;
1489 /* Check the inlining status of nested function FNDECL in the current context.
1491 If a non-inline nested function is referenced from an inline external
1492 function, we cannot honor both requests at the same time without cloning
1493 the nested function in the current unit since it is private to its unit.
1494 We could inline it as well but it's probably better to err on the side
1495 of too little inlining.
1497 This must be invoked only on nested functions present in the source code
1498 and not on nested functions generated by the compiler, e.g. finalizers,
1499 because they are not marked inline and we don't want them to block the
1500 inlining of the parent function. */
1502 static void
1503 check_inlining_for_nested_subprog (tree fndecl)
1505 if (!DECL_DECLARED_INLINE_P (fndecl)
1506 && current_function_decl
1507 && DECL_EXTERNAL (current_function_decl)
1508 && DECL_DECLARED_INLINE_P (current_function_decl))
1510 const location_t loc1 = DECL_SOURCE_LOCATION (fndecl);
1511 const location_t loc2 = DECL_SOURCE_LOCATION (current_function_decl);
1513 if (lookup_attribute ("always_inline",
1514 DECL_ATTRIBUTES (current_function_decl)))
1516 error_at (loc1, "subprogram %q+F not marked Inline_Always", fndecl);
1517 error_at (loc2, "parent subprogram cannot be inlined");
1519 else
1521 warning_at (loc1, OPT_Winline, "subprogram %q+F not marked Inline",
1522 fndecl);
1523 warning_at (loc2, OPT_Winline, "parent subprogram cannot be inlined");
1526 DECL_DECLARED_INLINE_P (current_function_decl) = 0;
1527 DECL_UNINLINABLE (current_function_decl) = 1;
1531 /* Return an expression for the length of TYPE, an integral type, computed in
1532 RESULT_TYPE, another integral type.
1534 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
1535 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
1536 which would only overflow in much rarer cases, for extremely large arrays
1537 we expect never to encounter in practice. Besides, the former computation
1538 required the use of potentially constraining signed arithmetics while the
1539 latter does not. Note that the comparison must be done in the original
1540 base index type in order to avoid any overflow during the conversion. */
1542 static tree
1543 get_type_length (tree type, tree result_type)
1545 tree comp_type = get_base_type (result_type);
1546 tree base_type = get_base_type (type);
1547 tree lb = convert (base_type, TYPE_MIN_VALUE (type));
1548 tree hb = convert (base_type, TYPE_MAX_VALUE (type));
1549 tree length
1550 = build_binary_op (PLUS_EXPR, comp_type,
1551 build_binary_op (MINUS_EXPR, comp_type,
1552 convert (comp_type, hb),
1553 convert (comp_type, lb)),
1554 convert (comp_type, integer_one_node));
1555 length
1556 = build_cond_expr (result_type,
1557 build_binary_op (GE_EXPR, boolean_type_node, hb, lb),
1558 convert (result_type, length),
1559 convert (result_type, integer_zero_node));
1560 return length;
1563 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1564 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1565 where we should place the result type. ATTRIBUTE is the attribute ID. */
1567 static tree
1568 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1570 const Node_Id gnat_prefix = Prefix (gnat_node);
1571 tree gnu_prefix, gnu_type, gnu_expr;
1572 tree gnu_result_type, gnu_result = error_mark_node;
1573 bool prefix_unused = false;
1575 /* ??? If this is an access attribute for a public subprogram to be used in
1576 a dispatch table, do not translate its type as it's useless in this case
1577 and the parameter types might be incomplete types coming from a limited
1578 context in Ada 2012 (AI05-0151). */
1579 if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
1580 && Is_Dispatch_Table_Entity (Etype (gnat_node))
1581 && Nkind (gnat_prefix) == N_Identifier
1582 && Is_Subprogram (Entity (gnat_prefix))
1583 && Is_Public (Entity (gnat_prefix))
1584 && !present_gnu_tree (Entity (gnat_prefix)))
1585 gnu_prefix = get_minimal_subprog_decl (Entity (gnat_prefix));
1586 else
1587 gnu_prefix = gnat_to_gnu (gnat_prefix);
1588 gnu_type = TREE_TYPE (gnu_prefix);
1590 /* If the input is a NULL_EXPR, make a new one. */
1591 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1593 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1594 *gnu_result_type_p = gnu_result_type;
1595 return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1598 switch (attribute)
1600 case Attr_Pos:
1601 case Attr_Val:
1602 /* These are just conversions since representation clauses for
1603 enumeration types are handled in the front-end. */
1605 bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1606 gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1607 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1608 gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1609 checkp, checkp, true, gnat_node);
1611 break;
1613 case Attr_Pred:
1614 case Attr_Succ:
1615 /* These just add or subtract the constant 1 since representation
1616 clauses for enumeration types are handled in the front-end. */
1617 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1618 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1620 if (Do_Range_Check (First (Expressions (gnat_node))))
1622 gnu_expr = gnat_protect_expr (gnu_expr);
1623 gnu_expr
1624 = emit_check
1625 (build_binary_op (EQ_EXPR, boolean_type_node,
1626 gnu_expr,
1627 attribute == Attr_Pred
1628 ? TYPE_MIN_VALUE (gnu_result_type)
1629 : TYPE_MAX_VALUE (gnu_result_type)),
1630 gnu_expr, CE_Range_Check_Failed, gnat_node);
1633 gnu_result
1634 = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1635 gnu_result_type, gnu_expr,
1636 convert (gnu_result_type, integer_one_node));
1637 break;
1639 case Attr_Address:
1640 case Attr_Unrestricted_Access:
1641 /* Conversions don't change addresses but can cause us to miss the
1642 COMPONENT_REF case below, so strip them off. */
1643 gnu_prefix = remove_conversions (gnu_prefix,
1644 !Must_Be_Byte_Aligned (gnat_node));
1646 /* If we are taking 'Address of an unconstrained object, this is the
1647 pointer to the underlying array. */
1648 if (attribute == Attr_Address)
1649 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1651 /* If we are building a static dispatch table, we have to honor
1652 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1653 with the C++ ABI. We do it in the non-static case as well,
1654 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1655 else if (TARGET_VTABLE_USES_DESCRIPTORS
1656 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1658 tree gnu_field, t;
1659 /* Descriptors can only be built here for top-level functions. */
1660 bool build_descriptor = (global_bindings_p () != 0);
1661 int i;
1662 vec<constructor_elt, va_gc> *gnu_vec = NULL;
1663 constructor_elt *elt;
1665 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1667 /* If we're not going to build the descriptor, we have to retrieve
1668 the one which will be built by the linker (or by the compiler
1669 later if a static chain is requested). */
1670 if (!build_descriptor)
1672 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1673 gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1674 gnu_result);
1675 gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1678 vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS);
1679 elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1680 for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1681 i < TARGET_VTABLE_USES_DESCRIPTORS;
1682 gnu_field = DECL_CHAIN (gnu_field), i++)
1684 if (build_descriptor)
1686 t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1687 build_int_cst (NULL_TREE, i));
1688 TREE_CONSTANT (t) = 1;
1690 else
1691 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1692 gnu_field, NULL_TREE);
1694 elt->index = gnu_field;
1695 elt->value = t;
1696 elt--;
1699 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1700 break;
1703 /* ... fall through ... */
1705 case Attr_Access:
1706 case Attr_Unchecked_Access:
1707 case Attr_Code_Address:
1708 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1709 gnu_result
1710 = build_unary_op (((attribute == Attr_Address
1711 || attribute == Attr_Unrestricted_Access)
1712 && !Must_Be_Byte_Aligned (gnat_node))
1713 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1714 gnu_result_type, gnu_prefix);
1716 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1717 don't try to build a trampoline. */
1718 if (attribute == Attr_Code_Address)
1720 gnu_expr = remove_conversions (gnu_result, false);
1722 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1723 TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1726 /* For 'Access, issue an error message if the prefix is a C++ method
1727 since it can use a special calling convention on some platforms,
1728 which cannot be propagated to the access type. */
1729 else if (attribute == Attr_Access
1730 && Nkind (gnat_prefix) == N_Identifier
1731 && is_cplusplus_method (Entity (gnat_prefix)))
1732 post_error ("access to C++ constructor or member function not allowed",
1733 gnat_node);
1735 /* For other address attributes applied to a nested function,
1736 find an inner ADDR_EXPR and annotate it so that we can issue
1737 a useful warning with -Wtrampolines. */
1738 else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1740 gnu_expr = remove_conversions (gnu_result, false);
1742 if (TREE_CODE (gnu_expr) == ADDR_EXPR
1743 && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1745 set_expr_location_from_node (gnu_expr, gnat_node);
1747 /* Also check the inlining status. */
1748 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0));
1750 /* Check that we're not violating the No_Implicit_Dynamic_Code
1751 restriction. Be conservative if we don't know anything
1752 about the trampoline strategy for the target. */
1753 Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1756 break;
1758 case Attr_Pool_Address:
1760 tree gnu_ptr = gnu_prefix;
1761 tree gnu_obj_type;
1763 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1765 /* If this is fat pointer, the object must have been allocated with the
1766 template in front of the array. So compute the template address; do
1767 it by converting to a thin pointer. */
1768 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1769 gnu_ptr
1770 = convert (build_pointer_type
1771 (TYPE_OBJECT_RECORD_TYPE
1772 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1773 gnu_ptr);
1775 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1777 /* If this is a thin pointer, the object must have been allocated with
1778 the template in front of the array. So compute the template address
1779 and return it. */
1780 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
1781 gnu_ptr
1782 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
1783 gnu_ptr,
1784 fold_build1 (NEGATE_EXPR, sizetype,
1785 byte_position
1786 (DECL_CHAIN
1787 TYPE_FIELDS ((gnu_obj_type)))));
1789 gnu_result = convert (gnu_result_type, gnu_ptr);
1791 break;
1793 case Attr_Size:
1794 case Attr_Object_Size:
1795 case Attr_Value_Size:
1796 case Attr_Max_Size_In_Storage_Elements:
1797 gnu_expr = gnu_prefix;
1799 /* Remove NOPs and conversions between original and packable version
1800 from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
1801 to see if a COMPONENT_REF was involved. */
1802 while (TREE_CODE (gnu_expr) == NOP_EXPR
1803 || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1804 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1805 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1806 == RECORD_TYPE
1807 && TYPE_NAME (TREE_TYPE (gnu_expr))
1808 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1809 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1811 gnu_prefix = remove_conversions (gnu_prefix, true);
1812 prefix_unused = true;
1813 gnu_type = TREE_TYPE (gnu_prefix);
1815 /* Replace an unconstrained array type with the type of the underlying
1816 array. We can't do this with a call to maybe_unconstrained_array
1817 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
1818 use the record type that will be used to allocate the object and its
1819 template. */
1820 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1822 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1823 if (attribute != Attr_Max_Size_In_Storage_Elements)
1824 gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
1827 /* If we're looking for the size of a field, return the field size. */
1828 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1829 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1831 /* Otherwise, if the prefix is an object, or if we are looking for
1832 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1833 GCC size of the type. We make an exception for padded objects,
1834 as we do not take into account alignment promotions for the size.
1835 This is in keeping with the object case of gnat_to_gnu_entity. */
1836 else if ((TREE_CODE (gnu_prefix) != TYPE_DECL
1837 && !(TYPE_IS_PADDING_P (gnu_type)
1838 && TREE_CODE (gnu_expr) == COMPONENT_REF))
1839 || attribute == Attr_Object_Size
1840 || attribute == Attr_Max_Size_In_Storage_Elements)
1842 /* If this is a dereference and we have a special dynamic constrained
1843 subtype on the prefix, use it to compute the size; otherwise, use
1844 the designated subtype. */
1845 if (Nkind (gnat_prefix) == N_Explicit_Dereference)
1847 Node_Id gnat_actual_subtype
1848 = Actual_Designated_Subtype (gnat_prefix);
1849 tree gnu_ptr_type
1850 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
1852 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1853 && Present (gnat_actual_subtype))
1855 tree gnu_actual_obj_type
1856 = gnat_to_gnu_type (gnat_actual_subtype);
1857 gnu_type
1858 = build_unc_object_type_from_ptr (gnu_ptr_type,
1859 gnu_actual_obj_type,
1860 get_identifier ("SIZE"),
1861 false);
1865 gnu_result = TYPE_SIZE (gnu_type);
1868 /* Otherwise, the result is the RM size of the type. */
1869 else
1870 gnu_result = rm_size (gnu_type);
1872 /* Deal with a self-referential size by returning the maximum size for
1873 a type and by qualifying the size with the object otherwise. */
1874 if (CONTAINS_PLACEHOLDER_P (gnu_result))
1876 if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1877 gnu_result = max_size (gnu_result, true);
1878 else
1879 gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1882 /* If the type contains a template, subtract its size. */
1883 if (TREE_CODE (gnu_type) == RECORD_TYPE
1884 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1885 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1886 DECL_SIZE (TYPE_FIELDS (gnu_type)));
1888 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
1889 if (attribute == Attr_Max_Size_In_Storage_Elements)
1890 gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1892 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1893 break;
1895 case Attr_Alignment:
1897 unsigned int align;
1899 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1900 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1901 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1903 gnu_type = TREE_TYPE (gnu_prefix);
1904 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1905 prefix_unused = true;
1907 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1908 align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1909 else
1911 Entity_Id gnat_type = Etype (gnat_prefix);
1912 unsigned int double_align;
1913 bool is_capped_double, align_clause;
1915 /* If the default alignment of "double" or larger scalar types is
1916 specifically capped and there is an alignment clause neither
1917 on the type nor on the prefix itself, return the cap. */
1918 if ((double_align = double_float_alignment) > 0)
1919 is_capped_double
1920 = is_double_float_or_array (gnat_type, &align_clause);
1921 else if ((double_align = double_scalar_alignment) > 0)
1922 is_capped_double
1923 = is_double_scalar_or_array (gnat_type, &align_clause);
1924 else
1925 is_capped_double = align_clause = false;
1927 if (is_capped_double
1928 && Nkind (gnat_prefix) == N_Identifier
1929 && Present (Alignment_Clause (Entity (gnat_prefix))))
1930 align_clause = true;
1932 if (is_capped_double && !align_clause)
1933 align = double_align;
1934 else
1935 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1938 gnu_result = size_int (align);
1940 break;
1942 case Attr_First:
1943 case Attr_Last:
1944 case Attr_Range_Length:
1945 prefix_unused = true;
1947 if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1949 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1951 if (attribute == Attr_First)
1952 gnu_result = TYPE_MIN_VALUE (gnu_type);
1953 else if (attribute == Attr_Last)
1954 gnu_result = TYPE_MAX_VALUE (gnu_type);
1955 else
1956 gnu_result = get_type_length (gnu_type, gnu_result_type);
1957 break;
1960 /* ... fall through ... */
1962 case Attr_Length:
1964 int Dimension = (Present (Expressions (gnat_node))
1965 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1966 : 1), i;
1967 struct parm_attr_d *pa = NULL;
1968 Entity_Id gnat_param = Empty;
1969 bool unconstrained_ptr_deref = false;
1971 /* Make sure any implicit dereference gets done. */
1972 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1973 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1975 /* We treat unconstrained array In parameters specially. We also note
1976 whether we are dereferencing a pointer to unconstrained array. */
1977 if (!Is_Constrained (Etype (gnat_prefix)))
1978 switch (Nkind (gnat_prefix))
1980 case N_Identifier:
1981 /* This is the direct case. */
1982 if (Ekind (Entity (gnat_prefix)) == E_In_Parameter)
1983 gnat_param = Entity (gnat_prefix);
1984 break;
1986 case N_Explicit_Dereference:
1987 /* This is the indirect case. Note that we need to be sure that
1988 the access value cannot be null as we'll hoist the load. */
1989 if (Nkind (Prefix (gnat_prefix)) == N_Identifier
1990 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter)
1992 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
1993 gnat_param = Entity (Prefix (gnat_prefix));
1995 else
1996 unconstrained_ptr_deref = true;
1997 break;
1999 default:
2000 break;
2003 /* If the prefix is the view conversion of a constrained array to an
2004 unconstrained form, we retrieve the constrained array because we
2005 might not be able to substitute the PLACEHOLDER_EXPR coming from
2006 the conversion. This can occur with the 'Old attribute applied
2007 to a parameter with an unconstrained type, which gets rewritten
2008 into a constrained local variable very late in the game. */
2009 if (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
2010 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix)))
2011 && !CONTAINS_PLACEHOLDER_P
2012 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
2013 gnu_type = TREE_TYPE (TREE_OPERAND (gnu_prefix, 0));
2014 else
2015 gnu_type = TREE_TYPE (gnu_prefix);
2017 prefix_unused = true;
2018 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2020 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
2022 int ndim;
2023 tree gnu_type_temp;
2025 for (ndim = 1, gnu_type_temp = gnu_type;
2026 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
2027 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
2028 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
2031 Dimension = ndim + 1 - Dimension;
2034 for (i = 1; i < Dimension; i++)
2035 gnu_type = TREE_TYPE (gnu_type);
2037 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2039 /* When not optimizing, look up the slot associated with the parameter
2040 and the dimension in the cache and create a new one on failure.
2041 Don't do this when the actual subtype needs debug info (this happens
2042 with -gnatD): in elaborate_expression_1, we create variables that
2043 hold the bounds, so caching attributes isn't very interesting and
2044 causes dependency issues between these variables and cached
2045 expressions. */
2046 if (!optimize
2047 && Present (gnat_param)
2048 && !(Present (Actual_Subtype (gnat_param))
2049 && Needs_Debug_Info (Actual_Subtype (gnat_param))))
2051 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa)
2052 if (pa->id == gnat_param && pa->dim == Dimension)
2053 break;
2055 if (!pa)
2057 pa = ggc_cleared_alloc<parm_attr_d> ();
2058 pa->id = gnat_param;
2059 pa->dim = Dimension;
2060 vec_safe_push (f_parm_attr_cache, pa);
2064 /* Return the cached expression or build a new one. */
2065 if (attribute == Attr_First)
2067 if (pa && pa->first)
2069 gnu_result = pa->first;
2070 break;
2073 gnu_result
2074 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2077 else if (attribute == Attr_Last)
2079 if (pa && pa->last)
2081 gnu_result = pa->last;
2082 break;
2085 gnu_result
2086 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2089 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2091 if (pa && pa->length)
2093 gnu_result = pa->length;
2094 break;
2097 gnu_result
2098 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)),
2099 gnu_result_type);
2102 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2103 handling. Note that these attributes could not have been used on
2104 an unconstrained array type. */
2105 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2107 /* Cache the expression we have just computed. Since we want to do it
2108 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2109 create the temporary in the outermost binding level. We will make
2110 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2111 paths by forcing its evaluation on entry of the function. */
2112 if (pa)
2114 gnu_result
2115 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2116 switch (attribute)
2118 case Attr_First:
2119 pa->first = gnu_result;
2120 break;
2122 case Attr_Last:
2123 pa->last = gnu_result;
2124 break;
2126 case Attr_Length:
2127 case Attr_Range_Length:
2128 pa->length = gnu_result;
2129 break;
2131 default:
2132 gcc_unreachable ();
2136 /* Otherwise, evaluate it each time it is referenced. */
2137 else
2138 switch (attribute)
2140 case Attr_First:
2141 case Attr_Last:
2142 /* If we are dereferencing a pointer to unconstrained array, we
2143 need to capture the value because the pointed-to bounds may
2144 subsequently be released. */
2145 if (unconstrained_ptr_deref)
2146 gnu_result
2147 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2148 break;
2150 case Attr_Length:
2151 case Attr_Range_Length:
2152 /* Set the source location onto the predicate of the condition
2153 but not if the expression is cached to avoid messing up the
2154 debug info. */
2155 if (TREE_CODE (gnu_result) == COND_EXPR
2156 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
2157 set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
2158 gnat_node);
2159 break;
2161 default:
2162 gcc_unreachable ();
2165 break;
2168 case Attr_Bit_Position:
2169 case Attr_Position:
2170 case Attr_First_Bit:
2171 case Attr_Last_Bit:
2172 case Attr_Bit:
2174 HOST_WIDE_INT bitsize;
2175 HOST_WIDE_INT bitpos;
2176 tree gnu_offset;
2177 tree gnu_field_bitpos;
2178 tree gnu_field_offset;
2179 tree gnu_inner;
2180 machine_mode mode;
2181 int unsignedp, volatilep;
2183 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2184 gnu_prefix = remove_conversions (gnu_prefix, true);
2185 prefix_unused = true;
2187 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2188 the result is 0. Don't allow 'Bit on a bare component, though. */
2189 if (attribute == Attr_Bit
2190 && TREE_CODE (gnu_prefix) != COMPONENT_REF
2191 && TREE_CODE (gnu_prefix) != FIELD_DECL)
2193 gnu_result = integer_zero_node;
2194 break;
2197 else
2198 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
2199 || (attribute == Attr_Bit_Position
2200 && TREE_CODE (gnu_prefix) == FIELD_DECL));
2202 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
2203 &mode, &unsignedp, &volatilep, false);
2205 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2207 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
2208 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
2210 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
2211 TREE_CODE (gnu_inner) == COMPONENT_REF
2212 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
2213 gnu_inner = TREE_OPERAND (gnu_inner, 0))
2215 gnu_field_bitpos
2216 = size_binop (PLUS_EXPR, gnu_field_bitpos,
2217 bit_position (TREE_OPERAND (gnu_inner, 1)));
2218 gnu_field_offset
2219 = size_binop (PLUS_EXPR, gnu_field_offset,
2220 byte_position (TREE_OPERAND (gnu_inner, 1)));
2223 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
2225 gnu_field_bitpos = bit_position (gnu_prefix);
2226 gnu_field_offset = byte_position (gnu_prefix);
2228 else
2230 gnu_field_bitpos = bitsize_zero_node;
2231 gnu_field_offset = size_zero_node;
2234 switch (attribute)
2236 case Attr_Position:
2237 gnu_result = gnu_field_offset;
2238 break;
2240 case Attr_First_Bit:
2241 case Attr_Bit:
2242 gnu_result = size_int (bitpos % BITS_PER_UNIT);
2243 break;
2245 case Attr_Last_Bit:
2246 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
2247 gnu_result = size_binop (PLUS_EXPR, gnu_result,
2248 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
2249 /* ??? Avoid a large unsigned result that will overflow when
2250 converted to the signed universal_integer. */
2251 if (integer_zerop (gnu_result))
2252 gnu_result = integer_minus_one_node;
2253 else
2254 gnu_result
2255 = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node);
2256 break;
2258 case Attr_Bit_Position:
2259 gnu_result = gnu_field_bitpos;
2260 break;
2263 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2264 handling. */
2265 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2266 break;
2269 case Attr_Min:
2270 case Attr_Max:
2272 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
2273 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
2275 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2277 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2278 a NaN so we implement the semantics of C99 f{min,max} to make it
2279 predictable in this case: if either operand is a NaN, the other
2280 is returned; if both operands are NaN's, a NaN is returned. */
2281 if (SCALAR_FLOAT_TYPE_P (gnu_result_type)
2282 && !Machine_Overflows_On_Target)
2284 const bool lhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_lhs);
2285 const bool rhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_rhs);
2286 tree t = builtin_decl_explicit (BUILT_IN_ISNAN);
2287 tree lhs_is_nan, rhs_is_nan;
2289 /* If the operands have side-effects, they need to be evaluated
2290 only once in spite of the multiple references in the result. */
2291 if (lhs_side_effects_p)
2292 gnu_lhs = gnat_protect_expr (gnu_lhs);
2293 if (rhs_side_effects_p)
2294 gnu_rhs = gnat_protect_expr (gnu_rhs);
2296 lhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2297 build_call_expr (t, 1, gnu_lhs),
2298 integer_zero_node);
2300 rhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2301 build_call_expr (t, 1, gnu_rhs),
2302 integer_zero_node);
2304 gnu_result = build_binary_op (attribute == Attr_Min
2305 ? MIN_EXPR : MAX_EXPR,
2306 gnu_result_type, gnu_lhs, gnu_rhs);
2307 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2308 rhs_is_nan, gnu_lhs, gnu_result);
2309 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2310 lhs_is_nan, gnu_rhs, gnu_result);
2312 /* If the operands have side-effects, they need to be evaluated
2313 before doing the tests above since the place they otherwise
2314 would end up being evaluated at run time could be wrong. */
2315 if (lhs_side_effects_p)
2316 gnu_result
2317 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_lhs, gnu_result);
2319 if (rhs_side_effects_p)
2320 gnu_result
2321 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_rhs, gnu_result);
2323 else
2324 gnu_result = build_binary_op (attribute == Attr_Min
2325 ? MIN_EXPR : MAX_EXPR,
2326 gnu_result_type, gnu_lhs, gnu_rhs);
2328 break;
2330 case Attr_Passed_By_Reference:
2331 gnu_result = size_int (default_pass_by_ref (gnu_type)
2332 || must_pass_by_ref (gnu_type));
2333 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2334 break;
2336 case Attr_Component_Size:
2337 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
2338 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
2339 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
2341 gnu_prefix = maybe_implicit_deref (gnu_prefix);
2342 gnu_type = TREE_TYPE (gnu_prefix);
2344 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
2345 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
2347 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2348 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
2349 gnu_type = TREE_TYPE (gnu_type);
2351 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2353 /* Note this size cannot be self-referential. */
2354 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
2355 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2356 prefix_unused = true;
2357 break;
2359 case Attr_Descriptor_Size:
2360 gnu_type = TREE_TYPE (gnu_prefix);
2361 gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
2363 /* What we want is the offset of the ARRAY field in the record
2364 that the thin pointer designates. */
2365 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
2366 gnu_result = bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
2367 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2368 prefix_unused = true;
2369 break;
2371 case Attr_Null_Parameter:
2372 /* This is just a zero cast to the pointer type for our prefix and
2373 dereferenced. */
2374 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2375 gnu_result
2376 = build_unary_op (INDIRECT_REF, NULL_TREE,
2377 convert (build_pointer_type (gnu_result_type),
2378 integer_zero_node));
2379 TREE_PRIVATE (gnu_result) = 1;
2380 break;
2382 case Attr_Mechanism_Code:
2384 Entity_Id gnat_obj = Entity (gnat_prefix);
2385 int code;
2387 prefix_unused = true;
2388 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2389 if (Present (Expressions (gnat_node)))
2391 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
2393 for (gnat_obj = First_Formal (gnat_obj); i > 1;
2394 i--, gnat_obj = Next_Formal (gnat_obj))
2398 code = Mechanism (gnat_obj);
2399 if (code == Default)
2400 code = ((present_gnu_tree (gnat_obj)
2401 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
2402 || ((TREE_CODE (get_gnu_tree (gnat_obj))
2403 == PARM_DECL)
2404 && (DECL_BY_COMPONENT_PTR_P
2405 (get_gnu_tree (gnat_obj))))))
2406 ? By_Reference : By_Copy);
2407 gnu_result = convert (gnu_result_type, size_int (- code));
2409 break;
2411 case Attr_Model:
2412 /* We treat Model as identical to Machine. This is true for at least
2413 IEEE and some other nice floating-point systems. */
2415 /* ... fall through ... */
2417 case Attr_Machine:
2418 /* The trick is to force the compiler to store the result in memory so
2419 that we do not have extra precision used. But do this only when this
2420 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2421 the type is lower than that of the longest floating-point type. */
2422 prefix_unused = true;
2423 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2424 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2425 gnu_result = convert (gnu_result_type, gnu_expr);
2427 if (TREE_CODE (gnu_result) != REAL_CST
2428 && fp_arith_may_widen
2429 && TYPE_PRECISION (gnu_result_type)
2430 < TYPE_PRECISION (longest_float_type_node))
2432 tree rec_type = make_node (RECORD_TYPE);
2433 tree field
2434 = create_field_decl (get_identifier ("OBJ"), gnu_result_type,
2435 rec_type, NULL_TREE, NULL_TREE, 0, 0);
2436 tree rec_val, asm_expr;
2438 finish_record_type (rec_type, field, 0, false);
2440 rec_val = build_constructor_single (rec_type, field, gnu_result);
2441 rec_val = build1 (SAVE_EXPR, rec_type, rec_val);
2443 asm_expr
2444 = build5 (ASM_EXPR, void_type_node,
2445 build_string (0, ""),
2446 tree_cons (build_tree_list (NULL_TREE,
2447 build_string (2, "=m")),
2448 rec_val, NULL_TREE),
2449 tree_cons (build_tree_list (NULL_TREE,
2450 build_string (1, "m")),
2451 rec_val, NULL_TREE),
2452 NULL_TREE, NULL_TREE);
2453 ASM_VOLATILE_P (asm_expr) = 1;
2455 gnu_result
2456 = build_compound_expr (gnu_result_type, asm_expr,
2457 build_component_ref (rec_val, NULL_TREE,
2458 field, false));
2460 break;
2462 case Attr_Deref:
2463 prefix_unused = true;
2464 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2465 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2466 /* This can be a random address so build an alias-all pointer type. */
2467 gnu_expr
2468 = convert (build_pointer_type_for_mode (gnu_result_type, ptr_mode,
2469 true),
2470 gnu_expr);
2471 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_expr);
2472 break;
2474 default:
2475 /* This abort means that we have an unimplemented attribute. */
2476 gcc_unreachable ();
2479 /* If this is an attribute where the prefix was unused, force a use of it if
2480 it has a side-effect. But don't do it if the prefix is just an entity
2481 name. However, if an access check is needed, we must do it. See second
2482 example in AARM 11.6(5.e). */
2483 if (prefix_unused
2484 && TREE_SIDE_EFFECTS (gnu_prefix)
2485 && !Is_Entity_Name (gnat_prefix))
2486 gnu_result
2487 = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result);
2489 *gnu_result_type_p = gnu_result_type;
2490 return gnu_result;
2493 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2494 to a GCC tree, which is returned. */
2496 static tree
2497 Case_Statement_to_gnu (Node_Id gnat_node)
2499 tree gnu_result, gnu_expr, gnu_label;
2500 Node_Id gnat_when;
2501 location_t end_locus;
2502 bool may_fallthru = false;
2504 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2505 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2507 /* The range of values in a case statement is determined by the rules in
2508 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
2509 of the expression. One exception arises in the case of a simple name that
2510 is parenthesized. This still has the Etype of the name, but since it is
2511 not a name, para 7 does not apply, and we need to go to the base type.
2512 This is the only case where parenthesization affects the dynamic
2513 semantics (i.e. the range of possible values at run time that is covered
2514 by the others alternative).
2516 Another exception is if the subtype of the expression is non-static. In
2517 that case, we also have to use the base type. */
2518 if (Paren_Count (Expression (gnat_node)) != 0
2519 || !Is_OK_Static_Subtype (Underlying_Type
2520 (Etype (Expression (gnat_node)))))
2521 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2523 /* We build a SWITCH_EXPR that contains the code with interspersed
2524 CASE_LABEL_EXPRs for each label. */
2525 if (!Sloc_to_locus (End_Location (gnat_node), &end_locus))
2526 end_locus = input_location;
2527 gnu_label = create_artificial_label (end_locus);
2528 start_stmt_group ();
2530 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2531 Present (gnat_when);
2532 gnat_when = Next_Non_Pragma (gnat_when))
2534 bool choices_added_p = false;
2535 Node_Id gnat_choice;
2537 /* First compile all the different case choices for the current WHEN
2538 alternative. */
2539 for (gnat_choice = First (Discrete_Choices (gnat_when));
2540 Present (gnat_choice);
2541 gnat_choice = Next (gnat_choice))
2543 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2544 tree label = create_artificial_label (input_location);
2546 switch (Nkind (gnat_choice))
2548 case N_Range:
2549 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2550 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2551 break;
2553 case N_Subtype_Indication:
2554 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2555 (Constraint (gnat_choice))));
2556 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2557 (Constraint (gnat_choice))));
2558 break;
2560 case N_Identifier:
2561 case N_Expanded_Name:
2562 /* This represents either a subtype range or a static value of
2563 some kind; Ekind says which. */
2564 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2566 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2568 gnu_low = TYPE_MIN_VALUE (gnu_type);
2569 gnu_high = TYPE_MAX_VALUE (gnu_type);
2570 break;
2573 /* ... fall through ... */
2575 case N_Character_Literal:
2576 case N_Integer_Literal:
2577 gnu_low = gnat_to_gnu (gnat_choice);
2578 break;
2580 case N_Others_Choice:
2581 break;
2583 default:
2584 gcc_unreachable ();
2587 /* Everything should be folded into constants at this point. */
2588 gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST);
2589 gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST);
2591 add_stmt_with_node (build_case_label (gnu_low, gnu_high, label),
2592 gnat_choice);
2593 choices_added_p = true;
2596 /* This construct doesn't define a scope so we shouldn't push a binding
2597 level around the statement list. Except that we have always done so
2598 historically and this makes it possible to reduce stack usage. As a
2599 compromise, we keep doing it for case statements, for which this has
2600 never been problematic, but not for case expressions in Ada 2012. */
2601 if (choices_added_p)
2603 const bool is_case_expression
2604 = (Nkind (Parent (gnat_node)) == N_Expression_With_Actions);
2605 tree group
2606 = build_stmt_group (Statements (gnat_when), !is_case_expression);
2607 bool group_may_fallthru = block_may_fallthru (group);
2608 add_stmt (group);
2609 if (group_may_fallthru)
2611 tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2612 SET_EXPR_LOCATION (stmt, end_locus);
2613 add_stmt (stmt);
2614 may_fallthru = true;
2619 /* Now emit a definition of the label the cases branch to, if any. */
2620 if (may_fallthru)
2621 add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2622 gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2623 end_stmt_group (), NULL_TREE);
2625 return gnu_result;
2628 /* Find out whether VAR is an iteration variable of an enclosing loop in the
2629 current function. If so, push a range_check_info structure onto the stack
2630 of this enclosing loop and return it. Otherwise, return NULL. */
2632 static struct range_check_info_d *
2633 push_range_check_info (tree var)
2635 struct loop_info_d *iter = NULL;
2636 unsigned int i;
2638 var = remove_conversions (var, false);
2640 if (TREE_CODE (var) != VAR_DECL)
2641 return NULL;
2643 if (decl_function_context (var) != current_function_decl)
2644 return NULL;
2646 gcc_assert (vec_safe_length (gnu_loop_stack) > 0);
2648 for (i = vec_safe_length (gnu_loop_stack) - 1;
2649 vec_safe_iterate (gnu_loop_stack, i, &iter);
2650 i--)
2651 if (var == iter->loop_var)
2652 break;
2654 if (iter)
2656 struct range_check_info_d *rci = ggc_alloc<range_check_info_d> ();
2657 vec_safe_push (iter->checks, rci);
2658 return rci;
2661 return NULL;
2664 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2665 false, or the maximum value if MAX is true, of TYPE. */
2667 static bool
2668 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2670 tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2672 if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2673 return true;
2675 if (TREE_CODE (val) == NOP_EXPR)
2676 val = (max
2677 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2678 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2680 if (TREE_CODE (val) != INTEGER_CST)
2681 return true;
2683 if (max)
2684 return tree_int_cst_lt (val, min_or_max_val) == 0;
2685 else
2686 return tree_int_cst_lt (min_or_max_val, val) == 0;
2689 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2690 If REVERSE is true, minimum value is taken as maximum value. */
2692 static inline bool
2693 can_equal_min_val_p (tree val, tree type, bool reverse)
2695 return can_equal_min_or_max_val_p (val, type, reverse);
2698 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2699 If REVERSE is true, maximum value is taken as minimum value. */
2701 static inline bool
2702 can_equal_max_val_p (tree val, tree type, bool reverse)
2704 return can_equal_min_or_max_val_p (val, type, !reverse);
2707 /* Return true if VAL1 can be lower than VAL2. */
2709 static bool
2710 can_be_lower_p (tree val1, tree val2)
2712 if (TREE_CODE (val1) == NOP_EXPR)
2713 val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0)));
2715 if (TREE_CODE (val1) != INTEGER_CST)
2716 return true;
2718 if (TREE_CODE (val2) == NOP_EXPR)
2719 val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0)));
2721 if (TREE_CODE (val2) != INTEGER_CST)
2722 return true;
2724 return tree_int_cst_lt (val1, val2);
2727 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2728 to a GCC tree, which is returned. */
2730 static tree
2731 Loop_Statement_to_gnu (Node_Id gnat_node)
2733 const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2734 struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> ();
2735 tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2736 NULL_TREE, NULL_TREE, NULL_TREE);
2737 tree gnu_loop_label = create_artificial_label (input_location);
2738 tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2739 tree gnu_result;
2741 /* Push the loop_info structure associated with the LOOP_STMT. */
2742 vec_safe_push (gnu_loop_stack, gnu_loop_info);
2744 /* Set location information for statement and end label. */
2745 set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2746 Sloc_to_locus (Sloc (End_Label (gnat_node)),
2747 &DECL_SOURCE_LOCATION (gnu_loop_label));
2748 LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2750 /* Save the statement for later reuse. */
2751 gnu_loop_info->stmt = gnu_loop_stmt;
2753 /* Set the condition under which the loop must keep going.
2754 For the case "LOOP .... END LOOP;" the condition is always true. */
2755 if (No (gnat_iter_scheme))
2758 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2759 else if (Present (Condition (gnat_iter_scheme)))
2760 LOOP_STMT_COND (gnu_loop_stmt)
2761 = gnat_to_gnu (Condition (gnat_iter_scheme));
2763 /* Otherwise we have an iteration scheme and the condition is given by the
2764 bounds of the subtype of the iteration variable. */
2765 else
2767 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2768 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2769 Entity_Id gnat_type = Etype (gnat_loop_var);
2770 tree gnu_type = get_unpadded_type (gnat_type);
2771 tree gnu_base_type = get_base_type (gnu_type);
2772 tree gnu_one_node = convert (gnu_base_type, integer_one_node);
2773 tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
2774 enum tree_code update_code, test_code, shift_code;
2775 bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
2777 gnu_low = convert (gnu_base_type, TYPE_MIN_VALUE (gnu_type));
2778 gnu_high = convert (gnu_base_type, TYPE_MAX_VALUE (gnu_type));
2780 /* We must disable modulo reduction for the iteration variable, if any,
2781 in order for the loop comparison to be effective. */
2782 if (reverse)
2784 gnu_first = gnu_high;
2785 gnu_last = gnu_low;
2786 update_code = MINUS_NOMOD_EXPR;
2787 test_code = GE_EXPR;
2788 shift_code = PLUS_NOMOD_EXPR;
2790 else
2792 gnu_first = gnu_low;
2793 gnu_last = gnu_high;
2794 update_code = PLUS_NOMOD_EXPR;
2795 test_code = LE_EXPR;
2796 shift_code = MINUS_NOMOD_EXPR;
2799 /* We use two different strategies to translate the loop, depending on
2800 whether optimization is enabled.
2802 If it is, we generate the canonical loop form expected by the loop
2803 optimizer and the loop vectorizer, which is the do-while form:
2805 ENTRY_COND
2806 loop:
2807 TOP_UPDATE
2808 BODY
2809 BOTTOM_COND
2810 GOTO loop
2812 This avoids an implicit dependency on loop header copying and makes
2813 it possible to turn BOTTOM_COND into an inequality test.
2815 If optimization is disabled, loop header copying doesn't come into
2816 play and we try to generate the loop form with the fewer conditional
2817 branches. First, the default form, which is:
2819 loop:
2820 TOP_COND
2821 BODY
2822 BOTTOM_UPDATE
2823 GOTO loop
2825 It should catch most loops with constant ending point. Then, if we
2826 cannot, we try to generate the shifted form:
2828 loop:
2829 TOP_COND
2830 TOP_UPDATE
2831 BODY
2832 GOTO loop
2834 which should catch loops with constant starting point. Otherwise, if
2835 we cannot, we generate the fallback form:
2837 ENTRY_COND
2838 loop:
2839 BODY
2840 BOTTOM_COND
2841 BOTTOM_UPDATE
2842 GOTO loop
2844 which works in all cases. */
2846 if (optimize)
2848 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
2849 overflow. */
2850 if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2853 /* Otherwise, use the do-while form with the help of a special
2854 induction variable in the unsigned version of the base type
2855 or the unsigned version of the size type, whichever is the
2856 largest, in order to have wrap-around arithmetics for it. */
2857 else
2859 if (TYPE_PRECISION (gnu_base_type)
2860 > TYPE_PRECISION (size_type_node))
2861 gnu_base_type
2862 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type), 1);
2863 else
2864 gnu_base_type = size_type_node;
2866 gnu_first = convert (gnu_base_type, gnu_first);
2867 gnu_last = convert (gnu_base_type, gnu_last);
2868 gnu_one_node = convert (gnu_base_type, integer_one_node);
2869 use_iv = true;
2872 gnu_first
2873 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2874 gnu_one_node);
2875 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2876 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2878 else
2880 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
2881 if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2884 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2885 GNU_LAST-1 does. */
2886 else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2887 && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2889 gnu_first
2890 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2891 gnu_one_node);
2892 gnu_last
2893 = build_binary_op (shift_code, gnu_base_type, gnu_last,
2894 gnu_one_node);
2895 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2898 /* Otherwise, use the fallback form. */
2899 else
2900 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2903 /* If we use the BOTTOM_COND, we can turn the test into an inequality
2904 test but we may have to add ENTRY_COND to protect the empty loop. */
2905 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
2907 test_code = NE_EXPR;
2908 if (can_be_lower_p (gnu_high, gnu_low))
2910 gnu_cond_expr
2911 = build3 (COND_EXPR, void_type_node,
2912 build_binary_op (LE_EXPR, boolean_type_node,
2913 gnu_low, gnu_high),
2914 NULL_TREE, alloc_stmt_list ());
2915 set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2919 /* Open a new nesting level that will surround the loop to declare the
2920 iteration variable. */
2921 start_stmt_group ();
2922 gnat_pushlevel ();
2924 /* If we use the special induction variable, create it and set it to
2925 its initial value. Morever, the regular iteration variable cannot
2926 itself be initialized, lest the initial value wrapped around. */
2927 if (use_iv)
2929 gnu_loop_iv
2930 = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
2931 add_stmt (gnu_stmt);
2932 gnu_first = NULL_TREE;
2934 else
2935 gnu_loop_iv = NULL_TREE;
2937 /* Declare the iteration variable and set it to its initial value. */
2938 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2939 if (DECL_BY_REF_P (gnu_loop_var))
2940 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2941 else if (use_iv)
2943 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
2944 SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
2946 gnu_loop_info->loop_var = gnu_loop_var;
2948 /* Do all the arithmetics in the base type. */
2949 gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2951 /* Set either the top or bottom exit condition. */
2952 if (use_iv)
2953 LOOP_STMT_COND (gnu_loop_stmt)
2954 = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
2955 gnu_last);
2956 else
2957 LOOP_STMT_COND (gnu_loop_stmt)
2958 = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
2959 gnu_last);
2961 /* Set either the top or bottom update statement and give it the source
2962 location of the iteration for better coverage info. */
2963 if (use_iv)
2965 gnu_stmt
2966 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
2967 build_binary_op (update_code, gnu_base_type,
2968 gnu_loop_iv, gnu_one_node));
2969 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2970 append_to_statement_list (gnu_stmt,
2971 &LOOP_STMT_UPDATE (gnu_loop_stmt));
2972 gnu_stmt
2973 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2974 gnu_loop_iv);
2975 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2976 append_to_statement_list (gnu_stmt,
2977 &LOOP_STMT_UPDATE (gnu_loop_stmt));
2979 else
2981 gnu_stmt
2982 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2983 build_binary_op (update_code, gnu_base_type,
2984 gnu_loop_var, gnu_one_node));
2985 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2986 LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
2990 /* If the loop was named, have the name point to this loop. In this case,
2991 the association is not a DECL node, but the end label of the loop. */
2992 if (Present (Identifier (gnat_node)))
2993 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2995 /* Make the loop body into its own block, so any allocated storage will be
2996 released every iteration. This is needed for stack allocation. */
2997 LOOP_STMT_BODY (gnu_loop_stmt)
2998 = build_stmt_group (Statements (gnat_node), true);
2999 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
3001 /* If we have an iteration scheme, then we are in a statement group. Add
3002 the LOOP_STMT to it, finish it and make it the "loop". */
3003 if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
3005 struct range_check_info_d *rci;
3006 unsigned n_checks = vec_safe_length (gnu_loop_info->checks);
3007 unsigned int i;
3009 /* First, if we have computed a small number of invariant conditions for
3010 range checks applied to the iteration variable, then initialize these
3011 conditions in front of the loop. Otherwise, leave them set to true.
3013 ??? The heuristics need to be improved, by taking into account the
3014 following datapoints:
3015 - loop unswitching is disabled for big loops. The cap is the
3016 parameter PARAM_MAX_UNSWITCH_INSNS (50).
3017 - loop unswitching can only be applied a small number of times
3018 to a given loop. The cap is PARAM_MAX_UNSWITCH_LEVEL (3).
3019 - the front-end quickly generates useless or redundant checks
3020 that can be entirely optimized away in the end. */
3021 if (1 <= n_checks && n_checks <= 4)
3022 for (i = 0;
3023 vec_safe_iterate (gnu_loop_info->checks, i, &rci);
3024 i++)
3026 tree low_ok
3027 = rci->low_bound
3028 ? build_binary_op (GE_EXPR, boolean_type_node,
3029 convert (rci->type, gnu_low),
3030 rci->low_bound)
3031 : boolean_true_node;
3033 tree high_ok
3034 = rci->high_bound
3035 ? build_binary_op (LE_EXPR, boolean_type_node,
3036 convert (rci->type, gnu_high),
3037 rci->high_bound)
3038 : boolean_true_node;
3040 tree range_ok
3041 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
3042 low_ok, high_ok);
3044 TREE_OPERAND (rci->invariant_cond, 0)
3045 = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
3047 add_stmt_with_node_force (rci->invariant_cond, gnat_node);
3050 add_stmt (gnu_loop_stmt);
3051 gnat_poplevel ();
3052 gnu_loop_stmt = end_stmt_group ();
3055 /* If we have an outer COND_EXPR, that's our result and this loop is its
3056 "true" statement. Otherwise, the result is the LOOP_STMT. */
3057 if (gnu_cond_expr)
3059 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
3060 TREE_SIDE_EFFECTS (gnu_cond_expr) = 1;
3061 gnu_result = gnu_cond_expr;
3063 else
3064 gnu_result = gnu_loop_stmt;
3066 gnu_loop_stack->pop ();
3068 return gnu_result;
3071 /* This page implements a form of Named Return Value optimization modelled
3072 on the C++ optimization of the same name. The main difference is that
3073 we disregard any semantical considerations when applying it here, the
3074 counterpart being that we don't try to apply it to semantically loaded
3075 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3077 We consider a function body of the following GENERIC form:
3079 return_type R1;
3080 [...]
3081 RETURN_EXPR [<retval> = ...]
3082 [...]
3083 RETURN_EXPR [<retval> = R1]
3084 [...]
3085 return_type Ri;
3086 [...]
3087 RETURN_EXPR [<retval> = ...]
3088 [...]
3089 RETURN_EXPR [<retval> = Ri]
3090 [...]
3092 and we try to fulfill a simple criterion that would make it possible to
3093 replace one or several Ri variables with the RESULT_DECL of the function.
3095 The first observation is that RETURN_EXPRs that don't directly reference
3096 any of the Ri variables on the RHS of their assignment are transparent wrt
3097 the optimization. This is because the Ri variables aren't addressable so
3098 any transformation applied to them doesn't affect the RHS; moreover, the
3099 assignment writes the full <retval> object so existing values are entirely
3100 discarded.
3102 This property can be extended to some forms of RETURN_EXPRs that reference
3103 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3104 case, in particular when function calls are involved.
3106 Therefore the algorithm is as follows:
3108 1. Collect the list of candidates for a Named Return Value (Ri variables
3109 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3110 other expressions on the RHS of such assignments.
3112 2. Prune the members of the first list (candidates) that are referenced
3113 by a member of the second list (expressions).
3115 3. Extract a set of candidates with non-overlapping live ranges from the
3116 first list. These are the Named Return Values.
3118 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3119 Named Return Values in the function with the RESULT_DECL.
3121 If the function returns an unconstrained type, things are a bit different
3122 because the anonymous return object is allocated on the secondary stack
3123 and RESULT_DECL is only a pointer to it. Each return object can be of a
3124 different size and is allocated separately so we need not care about the
3125 aforementioned overlapping issues. Therefore, we don't collect the other
3126 expressions and skip step #2 in the algorithm. */
3128 struct nrv_data
3130 bitmap nrv;
3131 tree result;
3132 Node_Id gnat_ret;
3133 hash_set<tree> *visited;
3136 /* Return true if T is a Named Return Value. */
3138 static inline bool
3139 is_nrv_p (bitmap nrv, tree t)
3141 return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t));
3144 /* Helper function for walk_tree, used by finalize_nrv below. */
3146 static tree
3147 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
3149 struct nrv_data *dp = (struct nrv_data *)data;
3150 tree t = *tp;
3152 /* No need to walk into types or decls. */
3153 if (IS_TYPE_OR_DECL_P (t))
3154 *walk_subtrees = 0;
3156 if (is_nrv_p (dp->nrv, t))
3157 bitmap_clear_bit (dp->nrv, DECL_UID (t));
3159 return NULL_TREE;
3162 /* Prune Named Return Values in BLOCK and return true if there is still a
3163 Named Return Value in BLOCK or one of its sub-blocks. */
3165 static bool
3166 prune_nrv_in_block (bitmap nrv, tree block)
3168 bool has_nrv = false;
3169 tree t;
3171 /* First recurse on the sub-blocks. */
3172 for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
3173 has_nrv |= prune_nrv_in_block (nrv, t);
3175 /* Then make sure to keep at most one NRV per block. */
3176 for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
3177 if (is_nrv_p (nrv, t))
3179 if (has_nrv)
3180 bitmap_clear_bit (nrv, DECL_UID (t));
3181 else
3182 has_nrv = true;
3185 return has_nrv;
3188 /* Helper function for walk_tree, used by finalize_nrv below. */
3190 static tree
3191 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
3193 struct nrv_data *dp = (struct nrv_data *)data;
3194 tree t = *tp;
3196 /* No need to walk into types. */
3197 if (TYPE_P (t))
3198 *walk_subtrees = 0;
3200 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3201 nop, but differs from using NULL_TREE in that it indicates that we care
3202 about the value of the RESULT_DECL. */
3203 else if (TREE_CODE (t) == RETURN_EXPR
3204 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3206 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1), init_expr;
3208 /* If this is the temporary created for a return value with variable
3209 size in Call_to_gnu, we replace the RHS with the init expression. */
3210 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3211 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
3212 && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
3213 == TREE_OPERAND (ret_val, 1))
3215 init_expr = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3216 ret_val = TREE_OPERAND (ret_val, 1);
3218 else
3219 init_expr = NULL_TREE;
3221 /* Strip useless conversions around the return value. */
3222 if (gnat_useless_type_conversion (ret_val))
3223 ret_val = TREE_OPERAND (ret_val, 0);
3225 if (is_nrv_p (dp->nrv, ret_val))
3227 if (init_expr)
3228 TREE_OPERAND (TREE_OPERAND (t, 0), 1) = init_expr;
3229 else
3230 TREE_OPERAND (t, 0) = dp->result;
3234 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3235 if needed. */
3236 else if (TREE_CODE (t) == DECL_EXPR
3237 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3239 tree var = DECL_EXPR_DECL (t), init;
3241 if (DECL_INITIAL (var))
3243 init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
3244 DECL_INITIAL (var));
3245 SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
3246 DECL_INITIAL (var) = NULL_TREE;
3248 else
3249 init = build_empty_stmt (EXPR_LOCATION (t));
3250 *tp = init;
3252 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3253 SET_DECL_VALUE_EXPR (var, dp->result);
3254 DECL_HAS_VALUE_EXPR_P (var) = 1;
3255 /* ??? Kludge to avoid an assertion failure during inlining. */
3256 DECL_SIZE (var) = bitsize_unit_node;
3257 DECL_SIZE_UNIT (var) = size_one_node;
3260 /* And replace all uses of NRVs with the RESULT_DECL. */
3261 else if (is_nrv_p (dp->nrv, t))
3262 *tp = convert (TREE_TYPE (t), dp->result);
3264 /* Avoid walking into the same tree more than once. Unfortunately, we
3265 can't just use walk_tree_without_duplicates because it would only
3266 call us for the first occurrence of NRVs in the function body. */
3267 if (dp->visited->add (*tp))
3268 *walk_subtrees = 0;
3270 return NULL_TREE;
3273 /* Likewise, but used when the function returns an unconstrained type. */
3275 static tree
3276 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
3278 struct nrv_data *dp = (struct nrv_data *)data;
3279 tree t = *tp;
3281 /* No need to walk into types. */
3282 if (TYPE_P (t))
3283 *walk_subtrees = 0;
3285 /* We need to see the DECL_EXPR of NRVs before any other references so we
3286 walk the body of BIND_EXPR before walking its variables. */
3287 else if (TREE_CODE (t) == BIND_EXPR)
3288 walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
3290 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3291 return value built by the allocator instead of the whole construct. */
3292 else if (TREE_CODE (t) == RETURN_EXPR
3293 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3295 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3297 /* This is the construct returned by the allocator. */
3298 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3299 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
3301 tree rhs = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3303 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
3304 ret_val = CONSTRUCTOR_ELT (rhs, 1)->value;
3305 else
3306 ret_val = rhs;
3309 /* Strip useless conversions around the return value. */
3310 if (gnat_useless_type_conversion (ret_val)
3311 || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
3312 ret_val = TREE_OPERAND (ret_val, 0);
3314 /* Strip unpadding around the return value. */
3315 if (TREE_CODE (ret_val) == COMPONENT_REF
3316 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
3317 ret_val = TREE_OPERAND (ret_val, 0);
3319 /* Assign the new return value to the RESULT_DECL. */
3320 if (is_nrv_p (dp->nrv, ret_val))
3321 TREE_OPERAND (TREE_OPERAND (t, 0), 1)
3322 = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
3325 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3326 into a new variable. */
3327 else if (TREE_CODE (t) == DECL_EXPR
3328 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3330 tree saved_current_function_decl = current_function_decl;
3331 tree var = DECL_EXPR_DECL (t);
3332 tree alloc, p_array, new_var, new_ret;
3333 vec<constructor_elt, va_gc> *v;
3334 vec_alloc (v, 2);
3336 /* Create an artificial context to build the allocation. */
3337 current_function_decl = decl_function_context (var);
3338 start_stmt_group ();
3339 gnat_pushlevel ();
3341 /* This will return a COMPOUND_EXPR with the allocation in the first
3342 arm and the final return value in the second arm. */
3343 alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
3344 TREE_TYPE (dp->result),
3345 Procedure_To_Call (dp->gnat_ret),
3346 Storage_Pool (dp->gnat_ret),
3347 Empty, false);
3349 /* The new variable is built as a reference to the allocated space. */
3350 new_var
3351 = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
3352 build_reference_type (TREE_TYPE (var)));
3353 DECL_BY_REFERENCE (new_var) = 1;
3355 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
3357 tree cst = TREE_OPERAND (alloc, 1);
3359 /* The new initial value is a COMPOUND_EXPR with the allocation in
3360 the first arm and the value of P_ARRAY in the second arm. */
3361 DECL_INITIAL (new_var)
3362 = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
3363 TREE_OPERAND (alloc, 0),
3364 CONSTRUCTOR_ELT (cst, 0)->value);
3366 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3367 p_array = TYPE_FIELDS (TREE_TYPE (alloc));
3368 CONSTRUCTOR_APPEND_ELT (v, p_array,
3369 fold_convert (TREE_TYPE (p_array), new_var));
3370 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
3371 CONSTRUCTOR_ELT (cst, 1)->value);
3372 new_ret = build_constructor (TREE_TYPE (alloc), v);
3374 else
3376 /* The new initial value is just the allocation. */
3377 DECL_INITIAL (new_var) = alloc;
3378 new_ret = fold_convert (TREE_TYPE (alloc), new_var);
3381 gnat_pushdecl (new_var, Empty);
3383 /* Destroy the artificial context and insert the new statements. */
3384 gnat_zaplevel ();
3385 *tp = end_stmt_group ();
3386 current_function_decl = saved_current_function_decl;
3388 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3389 DECL_CHAIN (new_var) = DECL_CHAIN (var);
3390 DECL_CHAIN (var) = new_var;
3391 DECL_IGNORED_P (var) = 1;
3393 /* Save the new return value and the dereference of NEW_VAR. */
3394 DECL_INITIAL (var)
3395 = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
3396 build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
3397 /* ??? Kludge to avoid messing up during inlining. */
3398 DECL_CONTEXT (var) = NULL_TREE;
3401 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3402 else if (is_nrv_p (dp->nrv, t))
3403 *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
3405 /* Avoid walking into the same tree more than once. Unfortunately, we
3406 can't just use walk_tree_without_duplicates because it would only
3407 call us for the first occurrence of NRVs in the function body. */
3408 if (dp->visited->add (*tp))
3409 *walk_subtrees = 0;
3411 return NULL_TREE;
3414 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3415 contains the candidates for Named Return Value and OTHER is a list of
3416 the other return values. GNAT_RET is a representative return node. */
3418 static void
3419 finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret)
3421 struct cgraph_node *node;
3422 struct nrv_data data;
3423 walk_tree_fn func;
3424 unsigned int i;
3425 tree iter;
3427 /* We shouldn't be applying the optimization to return types that we aren't
3428 allowed to manipulate freely. */
3429 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3431 /* Prune the candidates that are referenced by other return values. */
3432 data.nrv = nrv;
3433 data.result = NULL_TREE;
3434 data.visited = NULL;
3435 for (i = 0; vec_safe_iterate (other, i, &iter); i++)
3436 walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3437 if (bitmap_empty_p (nrv))
3438 return;
3440 /* Prune also the candidates that are referenced by nested functions. */
3441 node = cgraph_node::get_create (fndecl);
3442 for (node = node->nested; node; node = node->next_nested)
3443 walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r,
3444 &data);
3445 if (bitmap_empty_p (nrv))
3446 return;
3448 /* Extract a set of NRVs with non-overlapping live ranges. */
3449 if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3450 return;
3452 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3453 data.nrv = nrv;
3454 data.result = DECL_RESULT (fndecl);
3455 data.gnat_ret = gnat_ret;
3456 data.visited = new hash_set<tree>;
3457 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
3458 func = finalize_nrv_unc_r;
3459 else
3460 func = finalize_nrv_r;
3461 walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3462 delete data.visited;
3465 /* Return true if RET_VAL can be used as a Named Return Value for the
3466 anonymous return object RET_OBJ. */
3468 static bool
3469 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3471 if (TREE_CODE (ret_val) != VAR_DECL)
3472 return false;
3474 if (TREE_THIS_VOLATILE (ret_val))
3475 return false;
3477 if (DECL_CONTEXT (ret_val) != current_function_decl)
3478 return false;
3480 if (TREE_STATIC (ret_val))
3481 return false;
3483 if (TREE_ADDRESSABLE (ret_val))
3484 return false;
3486 if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3487 return false;
3489 return true;
3492 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3493 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3494 around RESULT_OBJ, which may be null in this case. */
3496 static tree
3497 build_return_expr (tree ret_obj, tree ret_val)
3499 tree result_expr;
3501 if (ret_val)
3503 /* The gimplifier explicitly enforces the following invariant:
3505 RETURN_EXPR
3507 INIT_EXPR
3510 RET_OBJ ...
3512 As a consequence, type consistency dictates that we use the type
3513 of the RET_OBJ as the operation type. */
3514 tree operation_type = TREE_TYPE (ret_obj);
3516 /* Convert the right operand to the operation type. Note that this is
3517 the transformation applied in the INIT_EXPR case of build_binary_op,
3518 with the assumption that the type cannot involve a placeholder. */
3519 if (operation_type != TREE_TYPE (ret_val))
3520 ret_val = convert (operation_type, ret_val);
3522 /* We always can use an INIT_EXPR for the return object. */
3523 result_expr = build2 (INIT_EXPR, void_type_node, ret_obj, ret_val);
3525 /* If the function returns an aggregate type, find out whether this is
3526 a candidate for Named Return Value. If so, record it. Otherwise,
3527 if this is an expression of some kind, record it elsewhere. */
3528 if (optimize
3529 && AGGREGATE_TYPE_P (operation_type)
3530 && !TYPE_IS_FAT_POINTER_P (operation_type)
3531 && TYPE_MODE (operation_type) == BLKmode
3532 && aggregate_value_p (operation_type, current_function_decl))
3534 /* Recognize the temporary created for a return value with variable
3535 size in Call_to_gnu. We want to eliminate it if possible. */
3536 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3537 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
3538 && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
3539 == TREE_OPERAND (ret_val, 1))
3540 ret_val = TREE_OPERAND (ret_val, 1);
3542 /* Strip useless conversions around the return value. */
3543 if (gnat_useless_type_conversion (ret_val))
3544 ret_val = TREE_OPERAND (ret_val, 0);
3546 /* Now apply the test to the return value. */
3547 if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3549 if (!f_named_ret_val)
3550 f_named_ret_val = BITMAP_GGC_ALLOC ();
3551 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3554 /* Note that we need not care about CONSTRUCTORs here, as they are
3555 totally transparent given the read-compose-write semantics of
3556 assignments from CONSTRUCTORs. */
3557 else if (EXPR_P (ret_val))
3558 vec_safe_push (f_other_ret_val, ret_val);
3561 else
3562 result_expr = ret_obj;
3564 return build1 (RETURN_EXPR, void_type_node, result_expr);
3567 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3568 don't return anything. */
3570 static void
3571 Subprogram_Body_to_gnu (Node_Id gnat_node)
3573 /* Defining identifier of a parameter to the subprogram. */
3574 Entity_Id gnat_param;
3575 /* The defining identifier for the subprogram body. Note that if a
3576 specification has appeared before for this body, then the identifier
3577 occurring in that specification will also be a defining identifier and all
3578 the calls to this subprogram will point to that specification. */
3579 Entity_Id gnat_subprog_id
3580 = (Present (Corresponding_Spec (gnat_node))
3581 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
3582 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3583 tree gnu_subprog_decl;
3584 /* Its RESULT_DECL node. */
3585 tree gnu_result_decl;
3586 /* Its FUNCTION_TYPE node. */
3587 tree gnu_subprog_type;
3588 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3589 tree gnu_cico_list;
3590 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3591 tree gnu_return_var_elmt = NULL_TREE;
3592 tree gnu_result;
3593 location_t locus;
3594 struct language_function *gnu_subprog_language;
3595 vec<parm_attr, va_gc> *cache;
3597 /* If this is a generic object or if it has been eliminated,
3598 ignore it. */
3599 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
3600 || Ekind (gnat_subprog_id) == E_Generic_Function
3601 || Is_Eliminated (gnat_subprog_id))
3602 return;
3604 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3605 the already-elaborated tree node. However, if this subprogram had its
3606 elaboration deferred, we will already have made a tree node for it. So
3607 treat it as not being defined in that case. Such a subprogram cannot
3608 have an address clause or a freeze node, so this test is safe, though it
3609 does disable some otherwise-useful error checking. */
3610 gnu_subprog_decl
3611 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
3612 Acts_As_Spec (gnat_node)
3613 && !present_gnu_tree (gnat_subprog_id));
3614 gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
3615 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
3616 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3617 if (gnu_cico_list && TREE_VALUE (gnu_cico_list) == void_type_node)
3618 gnu_return_var_elmt = gnu_cico_list;
3620 /* If the function returns by invisible reference, make it explicit in the
3621 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
3622 if (TREE_ADDRESSABLE (gnu_subprog_type))
3624 TREE_TYPE (gnu_result_decl)
3625 = build_reference_type (TREE_TYPE (gnu_result_decl));
3626 relayout_decl (gnu_result_decl);
3629 /* Set the line number in the decl to correspond to that of the body. */
3630 Sloc_to_locus (Sloc (gnat_node), &locus);
3631 DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus;
3633 /* Initialize the information structure for the function. */
3634 allocate_struct_function (gnu_subprog_decl, false);
3635 gnu_subprog_language = ggc_cleared_alloc<language_function> ();
3636 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
3637 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_start_locus = locus;
3638 set_cfun (NULL);
3640 begin_subprog_body (gnu_subprog_decl);
3642 /* If there are copy-in/copy-out parameters, we need to ensure that they are
3643 properly copied out by the return statement. We do this by making a new
3644 block and converting any return into a goto to a label at the end of the
3645 block. */
3646 if (gnu_cico_list)
3648 tree gnu_return_var = NULL_TREE;
3650 vec_safe_push (gnu_return_label_stack,
3651 create_artificial_label (input_location));
3653 start_stmt_group ();
3654 gnat_pushlevel ();
3656 /* If this is a function with copy-in/copy-out parameters and which does
3657 not return by invisible reference, we also need a variable for the
3658 return value to be placed. */
3659 if (gnu_return_var_elmt && !TREE_ADDRESSABLE (gnu_subprog_type))
3661 tree gnu_return_type
3662 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
3664 gnu_return_var
3665 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
3666 gnu_return_type, NULL_TREE, false, false,
3667 false, false, NULL, gnat_subprog_id);
3668 TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
3671 vec_safe_push (gnu_return_var_stack, gnu_return_var);
3673 /* See whether there are parameters for which we don't have a GCC tree
3674 yet. These must be Out parameters. Make a VAR_DECL for them and
3675 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3676 We can match up the entries because TYPE_CI_CO_LIST is in the order
3677 of the parameters. */
3678 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3679 Present (gnat_param);
3680 gnat_param = Next_Formal_With_Extras (gnat_param))
3681 if (!present_gnu_tree (gnat_param))
3683 tree gnu_cico_entry = gnu_cico_list;
3684 tree gnu_decl;
3686 /* Skip any entries that have been already filled in; they must
3687 correspond to In Out parameters. */
3688 while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
3689 gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
3691 /* Do any needed dereferences for by-ref objects. */
3692 gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, 1);
3693 gcc_assert (DECL_P (gnu_decl));
3694 if (DECL_BY_REF_P (gnu_decl))
3695 gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl);
3697 /* Do any needed references for padded types. */
3698 TREE_VALUE (gnu_cico_entry)
3699 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl);
3702 else
3703 vec_safe_push (gnu_return_label_stack, NULL_TREE);
3705 /* Get a tree corresponding to the code for the subprogram. */
3706 start_stmt_group ();
3707 gnat_pushlevel ();
3709 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3711 /* Generate the code of the subprogram itself. A return statement will be
3712 present and any Out parameters will be handled there. */
3713 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3714 gnat_poplevel ();
3715 gnu_result = end_stmt_group ();
3717 /* If we populated the parameter attributes cache, we need to make sure that
3718 the cached expressions are evaluated on all the possible paths leading to
3719 their uses. So we force their evaluation on entry of the function. */
3720 cache = gnu_subprog_language->parm_attr_cache;
3721 if (cache)
3723 struct parm_attr_d *pa;
3724 int i;
3726 start_stmt_group ();
3728 FOR_EACH_VEC_ELT (*cache, i, pa)
3730 if (pa->first)
3731 add_stmt_with_node_force (pa->first, gnat_node);
3732 if (pa->last)
3733 add_stmt_with_node_force (pa->last, gnat_node);
3734 if (pa->length)
3735 add_stmt_with_node_force (pa->length, gnat_node);
3738 add_stmt (gnu_result);
3739 gnu_result = end_stmt_group ();
3741 gnu_subprog_language->parm_attr_cache = NULL;
3744 /* If we are dealing with a return from an Ada procedure with parameters
3745 passed by copy-in/copy-out, we need to return a record containing the
3746 final values of these parameters. If the list contains only one entry,
3747 return just that entry though.
3749 For a full description of the copy-in/copy-out parameter mechanism, see
3750 the part of the gnat_to_gnu_entity routine dealing with the translation
3751 of subprograms.
3753 We need to make a block that contains the definition of that label and
3754 the copying of the return value. It first contains the function, then
3755 the label and copy statement. */
3756 if (gnu_cico_list)
3758 const Node_Id gnat_end_label
3759 = End_Label (Handled_Statement_Sequence (gnat_node));
3761 gnu_return_var_stack->pop ();
3763 add_stmt (gnu_result);
3764 add_stmt (build1 (LABEL_EXPR, void_type_node,
3765 gnu_return_label_stack->last ()));
3767 /* If this is a function which returns by invisible reference, the
3768 return value has already been dealt with at the return statements,
3769 so we only need to indirectly copy out the parameters. */
3770 if (TREE_ADDRESSABLE (gnu_subprog_type))
3772 tree gnu_ret_deref
3773 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result_decl);
3774 tree t;
3776 gcc_assert (TREE_VALUE (gnu_cico_list) == void_type_node);
3778 for (t = TREE_CHAIN (gnu_cico_list); t; t = TREE_CHAIN (t))
3780 tree gnu_field_deref
3781 = build_component_ref (gnu_ret_deref, NULL_TREE,
3782 TREE_PURPOSE (t), true);
3783 gnu_result = build2 (MODIFY_EXPR, void_type_node,
3784 gnu_field_deref, TREE_VALUE (t));
3785 add_stmt_with_node (gnu_result, gnat_end_label);
3789 /* Otherwise, if this is a procedure or a function which does not return
3790 by invisible reference, we can do a direct block-copy out. */
3791 else
3793 tree gnu_retval;
3795 if (list_length (gnu_cico_list) == 1)
3796 gnu_retval = TREE_VALUE (gnu_cico_list);
3797 else
3798 gnu_retval
3799 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
3800 gnu_cico_list);
3802 gnu_result = build_return_expr (gnu_result_decl, gnu_retval);
3803 add_stmt_with_node (gnu_result, gnat_end_label);
3806 gnat_poplevel ();
3807 gnu_result = end_stmt_group ();
3810 gnu_return_label_stack->pop ();
3812 /* Attempt setting the end_locus of our GCC body tree, typically a
3813 BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
3814 declaration tree. */
3815 set_end_locus_from_node (gnu_result, gnat_node);
3816 set_end_locus_from_node (gnu_subprog_decl, gnat_node);
3818 /* On SEH targets, install an exception handler around the main entry
3819 point to catch unhandled exceptions. */
3820 if (DECL_NAME (gnu_subprog_decl) == main_identifier_node
3821 && targetm_common.except_unwind_info (&global_options) == UI_SEH)
3823 tree t;
3824 tree etype;
3826 t = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
3827 1, integer_zero_node);
3828 t = build_call_n_expr (unhandled_except_decl, 1, t);
3830 etype = build_unary_op (ADDR_EXPR, NULL_TREE, unhandled_others_decl);
3831 etype = tree_cons (NULL_TREE, etype, NULL_TREE);
3833 t = build2 (CATCH_EXPR, void_type_node, etype, t);
3834 gnu_result = build2 (TRY_CATCH_EXPR, TREE_TYPE (gnu_result),
3835 gnu_result, t);
3838 end_subprog_body (gnu_result);
3840 /* Finally annotate the parameters and disconnect the trees for parameters
3841 that we have turned into variables since they are now unusable. */
3842 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3843 Present (gnat_param);
3844 gnat_param = Next_Formal_With_Extras (gnat_param))
3846 tree gnu_param = get_gnu_tree (gnat_param);
3847 bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
3849 annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
3850 DECL_BY_REF_P (gnu_param));
3852 if (is_var_decl)
3853 save_gnu_tree (gnat_param, NULL_TREE, false);
3856 /* Disconnect the variable created for the return value. */
3857 if (gnu_return_var_elmt)
3858 TREE_VALUE (gnu_return_var_elmt) = void_type_node;
3860 /* If the function returns an aggregate type and we have candidates for
3861 a Named Return Value, finalize the optimization. */
3862 if (optimize && gnu_subprog_language->named_ret_val)
3864 finalize_nrv (gnu_subprog_decl,
3865 gnu_subprog_language->named_ret_val,
3866 gnu_subprog_language->other_ret_val,
3867 gnu_subprog_language->gnat_ret);
3868 gnu_subprog_language->named_ret_val = NULL;
3869 gnu_subprog_language->other_ret_val = NULL;
3872 /* If this is an inlined external function that has been marked uninlinable,
3873 drop the body and stop there. Otherwise compile the body. */
3874 if (DECL_EXTERNAL (gnu_subprog_decl) && DECL_UNINLINABLE (gnu_subprog_decl))
3875 DECL_SAVED_TREE (gnu_subprog_decl) = NULL_TREE;
3876 else
3877 rest_of_subprog_body_compilation (gnu_subprog_decl);
3880 /* Return true if GNAT_NODE references an Atomic entity. */
3882 static bool
3883 node_is_atomic (Node_Id gnat_node)
3885 Entity_Id gnat_entity;
3887 switch (Nkind (gnat_node))
3889 case N_Identifier:
3890 case N_Expanded_Name:
3891 gnat_entity = Entity (gnat_node);
3892 if (Ekind (gnat_entity) != E_Variable)
3893 break;
3894 return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
3896 case N_Selected_Component:
3897 gnat_entity = Entity (Selector_Name (gnat_node));
3898 return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
3900 case N_Indexed_Component:
3901 if (Has_Atomic_Components (Etype (Prefix (gnat_node))))
3902 return true;
3904 /* ... fall through ... */
3906 case N_Explicit_Dereference:
3907 return Is_Atomic (Etype (gnat_node));
3909 default:
3910 break;
3913 return false;
3916 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. */
3918 static bool
3919 node_has_volatile_full_access (Node_Id gnat_node)
3921 Entity_Id gnat_entity;
3923 switch (Nkind (gnat_node))
3925 case N_Identifier:
3926 case N_Expanded_Name:
3927 gnat_entity = Entity (gnat_node);
3928 if (Ekind (gnat_entity) != E_Variable)
3929 break;
3930 return Is_Volatile_Full_Access (gnat_entity)
3931 || Is_Volatile_Full_Access (Etype (gnat_entity));
3933 case N_Selected_Component:
3934 gnat_entity = Entity (Selector_Name (gnat_node));
3935 return Is_Volatile_Full_Access (gnat_entity)
3936 || Is_Volatile_Full_Access (Etype (gnat_entity));
3938 case N_Indexed_Component:
3939 case N_Explicit_Dereference:
3940 return Is_Volatile_Full_Access (Etype (gnat_node));
3942 default:
3943 break;
3946 return false;
3949 /* Strip any type conversion on GNAT_NODE and return the result. */
3951 static Node_Id
3952 gnat_strip_type_conversion (Node_Id gnat_node)
3954 Node_Kind kind = Nkind (gnat_node);
3956 if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
3957 gnat_node = Expression (gnat_node);
3959 return gnat_node;
3962 /* Return true if GNAT_NODE requires outer atomic access, i.e. atomic access
3963 of an object of which GNAT_NODE is a component. */
3965 static bool
3966 outer_atomic_access_required_p (Node_Id gnat_node)
3968 gnat_node = gnat_strip_type_conversion (gnat_node);
3970 while (true)
3972 switch (Nkind (gnat_node))
3974 case N_Identifier:
3975 case N_Expanded_Name:
3976 if (No (Renamed_Object (Entity (gnat_node))))
3977 return false;
3978 gnat_node
3979 = gnat_strip_type_conversion (Renamed_Object (Entity (gnat_node)));
3980 break;
3982 case N_Indexed_Component:
3983 case N_Selected_Component:
3984 case N_Slice:
3985 gnat_node = gnat_strip_type_conversion (Prefix (gnat_node));
3986 if (node_has_volatile_full_access (gnat_node))
3987 return true;
3988 break;
3990 default:
3991 return false;
3995 gcc_unreachable ();
3998 /* Return true if GNAT_NODE requires atomic access and set SYNC according to
3999 the associated synchronization setting. */
4001 static bool
4002 atomic_access_required_p (Node_Id gnat_node, bool *sync)
4004 const Node_Id gnat_parent = Parent (gnat_node);
4005 unsigned char attr_id;
4006 bool as_a_whole = true;
4008 /* First, scan the parent to find out cases where the flag is irrelevant. */
4009 switch (Nkind (gnat_parent))
4011 case N_Attribute_Reference:
4012 attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
4013 /* Do not mess up machine code insertions. */
4014 if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
4015 return false;
4017 /* Nothing to do if we are the prefix of an attribute, since we do not
4018 want an atomic access for things like 'Size. */
4020 /* ... fall through ... */
4022 case N_Reference:
4023 /* The N_Reference node is like an attribute. */
4024 if (Prefix (gnat_parent) == gnat_node)
4025 return false;
4026 break;
4028 case N_Indexed_Component:
4029 case N_Selected_Component:
4030 case N_Slice:
4031 /* If we are the prefix, then the access is only partial. */
4032 if (Prefix (gnat_parent) == gnat_node)
4033 as_a_whole = false;
4034 break;
4036 case N_Object_Renaming_Declaration:
4037 /* Nothing to do for the identifier in an object renaming declaration,
4038 the renaming itself does not need atomic access. */
4039 return false;
4041 default:
4042 break;
4045 /* Then, scan the node to find the atomic object. */
4046 gnat_node = gnat_strip_type_conversion (gnat_node);
4048 /* For Atomic itself, only reads and updates of the object as a whole require
4049 atomic access (RM C.6 (15)). But for Volatile_Full_Access, all reads and
4050 updates require atomic access. */
4051 if (!(as_a_whole && node_is_atomic (gnat_node))
4052 && !node_has_volatile_full_access (gnat_node))
4053 return false;
4055 /* If an outer atomic access will also be required, it cancels this one. */
4056 if (outer_atomic_access_required_p (gnat_node))
4057 return false;
4059 *sync = Atomic_Sync_Required (gnat_node);
4061 return true;
4064 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4066 static tree
4067 create_temporary (const char *prefix, tree type)
4069 tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
4070 type, NULL_TREE, false, false, false, false,
4071 NULL, Empty);
4072 DECL_ARTIFICIAL (gnu_temp) = 1;
4073 DECL_IGNORED_P (gnu_temp) = 1;
4075 return gnu_temp;
4078 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4079 Put the initialization statement into GNU_INIT_STMT and annotate it with
4080 the SLOC of GNAT_NODE. Return the temporary variable. */
4082 static tree
4083 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
4084 Node_Id gnat_node)
4086 tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
4088 *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
4089 set_expr_location_from_node (*gnu_init_stmt, gnat_node);
4091 return gnu_temp;
4094 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
4095 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4096 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4097 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4098 N_Assignment_Statement and the result is to be placed into that object.
4099 If OUTER_ATOMIC_ACCESS is true, then the assignment to GNU_TARGET must be a
4100 load-modify-store sequence. Otherwise, if ATOMIC_ACCESS is true, then the
4101 assignment to GNU_TARGET must be atomic. If, in addition, ATOMIC_SYNC is
4102 true, then the assignment to GNU_TARGET requires atomic synchronization. */
4104 static tree
4105 Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
4106 bool outer_atomic_access, bool atomic_access, bool atomic_sync)
4108 const bool function_call = (Nkind (gnat_node) == N_Function_Call);
4109 const bool returning_value = (function_call && !gnu_target);
4110 /* The GCC node corresponding to the GNAT subprogram name. This can either
4111 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
4112 or an indirect reference expression (an INDIRECT_REF node) pointing to a
4113 subprogram. */
4114 tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
4115 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
4116 tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
4117 /* The return type of the FUNCTION_TYPE. */
4118 tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
4119 tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
4120 vec<tree, va_gc> *gnu_actual_vec = NULL;
4121 tree gnu_name_list = NULL_TREE;
4122 tree gnu_stmt_list = NULL_TREE;
4123 tree gnu_after_list = NULL_TREE;
4124 tree gnu_retval = NULL_TREE;
4125 tree gnu_call, gnu_result;
4126 bool went_into_elab_proc = false;
4127 bool pushed_binding_level = false;
4128 Entity_Id gnat_formal;
4129 Node_Id gnat_actual;
4130 bool sync;
4132 gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
4134 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
4135 all our args first. */
4136 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
4138 tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
4139 gnat_node, N_Raise_Program_Error);
4141 for (gnat_actual = First_Actual (gnat_node);
4142 Present (gnat_actual);
4143 gnat_actual = Next_Actual (gnat_actual))
4144 add_stmt (gnat_to_gnu (gnat_actual));
4146 if (returning_value)
4148 *gnu_result_type_p = gnu_result_type;
4149 return build1 (NULL_EXPR, gnu_result_type, call_expr);
4152 return call_expr;
4155 /* For a call to a nested function, check the inlining status. */
4156 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL
4157 && decl_function_context (gnu_subprog))
4158 check_inlining_for_nested_subprog (gnu_subprog);
4160 /* The only way we can be making a call via an access type is if Name is an
4161 explicit dereference. In that case, get the list of formal args from the
4162 type the access type is pointing to. Otherwise, get the formals from the
4163 entity being called. */
4164 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
4165 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
4166 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
4167 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4168 gnat_formal = Empty;
4169 else
4170 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4172 /* The lifetime of the temporaries created for the call ends right after the
4173 return value is copied, so we can give them the scope of the elaboration
4174 routine at top level. */
4175 if (!current_function_decl)
4177 current_function_decl = get_elaboration_procedure ();
4178 went_into_elab_proc = true;
4181 /* First, create the temporary for the return value when:
4183 1. There is no target and the function has copy-in/copy-out parameters,
4184 because we need to preserve the return value before copying back the
4185 parameters.
4187 2. There is no target and this is neither an object nor a renaming
4188 declaration, and the return type has variable size, because in
4189 these cases the gimplifier cannot create the temporary.
4191 3. There is a target and it is a slice or an array with fixed size,
4192 and the return type has variable size, because the gimplifier
4193 doesn't handle these cases.
4195 This must be done before we push a binding level around the call, since
4196 we will pop it before copying the return value. */
4197 if (function_call
4198 && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
4199 || (!gnu_target
4200 && Nkind (Parent (gnat_node)) != N_Object_Declaration
4201 && Nkind (Parent (gnat_node)) != N_Object_Renaming_Declaration
4202 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
4203 || (gnu_target
4204 && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
4205 || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
4206 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
4207 == INTEGER_CST))
4208 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)))
4209 gnu_retval = create_temporary ("R", gnu_result_type);
4211 /* Create the list of the actual parameters as GCC expects it, namely a
4212 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4213 is an expression and the TREE_PURPOSE field is null. But skip Out
4214 parameters not passed by reference and that need not be copied in. */
4215 for (gnat_actual = First_Actual (gnat_node);
4216 Present (gnat_actual);
4217 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4218 gnat_actual = Next_Actual (gnat_actual))
4220 Entity_Id gnat_formal_type = Etype (gnat_formal);
4221 tree gnu_formal = present_gnu_tree (gnat_formal)
4222 ? get_gnu_tree (gnat_formal) : NULL_TREE;
4223 tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
4224 const bool is_true_formal_parm
4225 = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
4226 const bool is_by_ref_formal_parm
4227 = is_true_formal_parm
4228 && (DECL_BY_REF_P (gnu_formal)
4229 || DECL_BY_COMPONENT_PTR_P (gnu_formal));
4230 /* In the Out or In Out case, we must suppress conversions that yield
4231 an lvalue but can nevertheless cause the creation of a temporary,
4232 because we need the real object in this case, either to pass its
4233 address if it's passed by reference or as target of the back copy
4234 done after the call if it uses the copy-in/copy-out mechanism.
4235 We do it in the In case too, except for an unchecked conversion
4236 to an elementary type or a constrained composite type because it
4237 alone can cause the actual to be misaligned and the addressability
4238 test is applied to the real object. */
4239 const bool suppress_type_conversion
4240 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
4241 && (Ekind (gnat_formal) != E_In_Parameter
4242 || (Is_Composite_Type (Underlying_Type (gnat_formal_type))
4243 && !Is_Constrained (Underlying_Type (gnat_formal_type)))))
4244 || (Nkind (gnat_actual) == N_Type_Conversion
4245 && Is_Composite_Type (Underlying_Type (gnat_formal_type))));
4246 Node_Id gnat_name = suppress_type_conversion
4247 ? Expression (gnat_actual) : gnat_actual;
4248 tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
4249 tree gnu_actual;
4251 /* If it's possible we may need to use this expression twice, make sure
4252 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4253 to force side-effects before the call. */
4254 if (Ekind (gnat_formal) != E_In_Parameter
4255 && !is_by_ref_formal_parm
4256 && TREE_CODE (gnu_name) != NULL_EXPR)
4258 tree init = NULL_TREE;
4259 gnu_name = gnat_stabilize_reference (gnu_name, true, &init);
4260 if (init)
4261 gnu_name
4262 = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
4265 /* If we are passing a non-addressable parameter by reference, pass the
4266 address of a copy. In the Out or In Out case, set up to copy back
4267 out after the call. */
4268 if (is_by_ref_formal_parm
4269 && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
4270 && !addressable_p (gnu_name, gnu_name_type))
4272 bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
4273 tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
4275 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4276 but sort of an instantiation for them. */
4277 if (TREE_CODE (gnu_name) == CONSTRUCTOR)
4280 /* If the type is passed by reference, a copy is not allowed. */
4281 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type))
4282 post_error ("misaligned actual cannot be passed by reference",
4283 gnat_actual);
4285 /* For users of Starlet we issue a warning because the interface
4286 apparently assumes that by-ref parameters outlive the procedure
4287 invocation. The code still will not work as intended, but we
4288 cannot do much better since low-level parts of the back-end
4289 would allocate temporaries at will because of the misalignment
4290 if we did not do so here. */
4291 else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
4293 post_error
4294 ("?possible violation of implicit assumption", gnat_actual);
4295 post_error_ne
4296 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
4297 Entity (Name (gnat_node)));
4298 post_error_ne ("?because of misalignment of &", gnat_actual,
4299 gnat_formal);
4302 /* If the actual type of the object is already the nominal type,
4303 we have nothing to do, except if the size is self-referential
4304 in which case we'll remove the unpadding below. */
4305 if (TREE_TYPE (gnu_name) == gnu_name_type
4306 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
4309 /* Otherwise remove the unpadding from all the objects. */
4310 else if (TREE_CODE (gnu_name) == COMPONENT_REF
4311 && TYPE_IS_PADDING_P
4312 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
4313 gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
4315 /* Otherwise convert to the nominal type of the object if needed.
4316 There are several cases in which we need to make the temporary
4317 using this type instead of the actual type of the object when
4318 they are distinct, because the expectations of the callee would
4319 otherwise not be met:
4320 - if it's a justified modular type,
4321 - if the actual type is a smaller form of it,
4322 - if it's a smaller form of the actual type. */
4323 else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
4324 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
4325 || smaller_form_type_p (TREE_TYPE (gnu_name),
4326 gnu_name_type)))
4327 || (INTEGRAL_TYPE_P (gnu_name_type)
4328 && smaller_form_type_p (gnu_name_type,
4329 TREE_TYPE (gnu_name))))
4330 gnu_name = convert (gnu_name_type, gnu_name);
4332 /* If this is an In Out or Out parameter and we're returning a value,
4333 we need to create a temporary for the return value because we must
4334 preserve it before copying back at the very end. */
4335 if (!in_param && returning_value && !gnu_retval)
4336 gnu_retval = create_temporary ("R", gnu_result_type);
4338 /* If we haven't pushed a binding level, push a new one. This will
4339 narrow the lifetime of the temporary we are about to make as much
4340 as possible. The drawback is that we'd need to create a temporary
4341 for the return value, if any (see comment before the loop). So do
4342 it only when this temporary was already created just above. */
4343 if (!pushed_binding_level && !(in_param && returning_value))
4345 start_stmt_group ();
4346 gnat_pushlevel ();
4347 pushed_binding_level = true;
4350 /* Create an explicit temporary holding the copy. */
4351 gnu_temp
4352 = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
4354 /* But initialize it on the fly like for an implicit temporary as
4355 we aren't necessarily having a statement list. */
4356 gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
4357 gnu_temp);
4359 /* Set up to move the copy back to the original if needed. */
4360 if (!in_param)
4362 /* If the original is a COND_EXPR whose first arm isn't meant to
4363 be further used, just deal with the second arm. This is very
4364 likely the conditional expression built for a check. */
4365 if (TREE_CODE (gnu_orig) == COND_EXPR
4366 && TREE_CODE (TREE_OPERAND (gnu_orig, 1)) == COMPOUND_EXPR
4367 && integer_zerop
4368 (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1)))
4369 gnu_orig = TREE_OPERAND (gnu_orig, 2);
4371 gnu_stmt
4372 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp);
4373 set_expr_location_from_node (gnu_stmt, gnat_node);
4375 append_to_statement_list (gnu_stmt, &gnu_after_list);
4379 /* Start from the real object and build the actual. */
4380 gnu_actual = gnu_name;
4382 /* If atomic access is required for an In or In Out actual parameter,
4383 build the atomic load. */
4384 if (is_true_formal_parm
4385 && !is_by_ref_formal_parm
4386 && Ekind (gnat_formal) != E_Out_Parameter
4387 && atomic_access_required_p (gnat_actual, &sync))
4388 gnu_actual = build_atomic_load (gnu_actual, sync);
4390 /* If this was a procedure call, we may not have removed any padding.
4391 So do it here for the part we will use as an input, if any. */
4392 if (Ekind (gnat_formal) != E_Out_Parameter
4393 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4394 gnu_actual
4395 = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
4397 /* Put back the conversion we suppressed above in the computation of the
4398 real object. And even if we didn't suppress any conversion there, we
4399 may have suppressed a conversion to the Etype of the actual earlier,
4400 since the parent is a procedure call, so put it back here. */
4401 if (suppress_type_conversion
4402 && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4403 gnu_actual
4404 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
4405 gnu_actual, No_Truncation (gnat_actual));
4406 else
4407 gnu_actual
4408 = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
4410 /* Make sure that the actual is in range of the formal's type. */
4411 if (Ekind (gnat_formal) != E_Out_Parameter
4412 && Do_Range_Check (gnat_actual))
4413 gnu_actual
4414 = emit_range_check (gnu_actual, gnat_formal_type, gnat_actual);
4416 /* Unless this is an In parameter, we must remove any justified modular
4417 building from GNU_NAME to get an lvalue. */
4418 if (Ekind (gnat_formal) != E_In_Parameter
4419 && TREE_CODE (gnu_name) == CONSTRUCTOR
4420 && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
4421 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
4422 gnu_name
4423 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
4425 /* First see if the parameter is passed by reference. */
4426 if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal))
4428 if (Ekind (gnat_formal) != E_In_Parameter)
4430 /* In Out or Out parameters passed by reference don't use the
4431 copy-in/copy-out mechanism so the address of the real object
4432 must be passed to the function. */
4433 gnu_actual = gnu_name;
4435 /* If we have a padded type, be sure we've removed padding. */
4436 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4437 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
4438 gnu_actual);
4440 /* If we have the constructed subtype of an aliased object
4441 with an unconstrained nominal subtype, the type of the
4442 actual includes the template, although it is formally
4443 constrained. So we need to convert it back to the real
4444 constructed subtype to retrieve the constrained part
4445 and takes its address. */
4446 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
4447 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
4448 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
4449 && Is_Array_Type (Underlying_Type (Etype (gnat_actual))))
4450 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
4451 gnu_actual);
4454 /* There is no need to convert the actual to the formal's type before
4455 taking its address. The only exception is for unconstrained array
4456 types because of the way we build fat pointers. */
4457 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4459 /* Put back a view conversion for In Out or Out parameters. */
4460 if (Ekind (gnat_formal) != E_In_Parameter)
4461 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
4462 gnu_actual);
4463 gnu_actual = convert (gnu_formal_type, gnu_actual);
4466 /* The symmetry of the paths to the type of an entity is broken here
4467 since arguments don't know that they will be passed by ref. */
4468 gnu_formal_type = TREE_TYPE (gnu_formal);
4469 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4472 /* Then see if the parameter is an array passed to a foreign convention
4473 subprogram. */
4474 else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
4476 gnu_formal_type = TREE_TYPE (gnu_formal);
4477 gnu_actual = maybe_implicit_deref (gnu_actual);
4478 gnu_actual = maybe_unconstrained_array (gnu_actual);
4480 if (TYPE_IS_PADDING_P (gnu_formal_type))
4482 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
4483 gnu_actual = convert (gnu_formal_type, gnu_actual);
4486 /* Take the address of the object and convert to the proper pointer
4487 type. We'd like to actually compute the address of the beginning
4488 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4489 possibility that the ARRAY_REF might return a constant and we'd be
4490 getting the wrong address. Neither approach is exactly correct,
4491 but this is the most likely to work in all cases. */
4492 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4495 /* Otherwise the parameter is passed by copy. */
4496 else
4498 tree gnu_size;
4500 if (Ekind (gnat_formal) != E_In_Parameter)
4501 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
4503 /* If we didn't create a PARM_DECL for the formal, this means that
4504 it is an Out parameter not passed by reference and that need not
4505 be copied in. In this case, the value of the actual need not be
4506 read. However, we still need to make sure that its side-effects
4507 are evaluated before the call, so we evaluate its address. */
4508 if (!is_true_formal_parm)
4510 if (TREE_SIDE_EFFECTS (gnu_name))
4512 tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
4513 append_to_statement_list (addr, &gnu_stmt_list);
4515 continue;
4518 gnu_actual = convert (gnu_formal_type, gnu_actual);
4520 /* If this is 'Null_Parameter, pass a zero even though we are
4521 dereferencing it. */
4522 if (TREE_CODE (gnu_actual) == INDIRECT_REF
4523 && TREE_PRIVATE (gnu_actual)
4524 && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
4525 && TREE_CODE (gnu_size) == INTEGER_CST
4526 && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
4527 gnu_actual
4528 = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
4529 convert (gnat_type_for_size
4530 (TREE_INT_CST_LOW (gnu_size), 1),
4531 integer_zero_node),
4532 false);
4533 else
4534 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
4537 vec_safe_push (gnu_actual_vec, gnu_actual);
4540 gnu_call
4541 = build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec);
4542 set_expr_location_from_node (gnu_call, gnat_node);
4544 /* If we have created a temporary for the return value, initialize it. */
4545 if (gnu_retval)
4547 tree gnu_stmt
4548 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
4549 set_expr_location_from_node (gnu_stmt, gnat_node);
4550 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4551 gnu_call = gnu_retval;
4554 /* If this is a subprogram with copy-in/copy-out parameters, we need to
4555 unpack the valued returned from the function into the In Out or Out
4556 parameters. We deal with the function return (if this is an Ada
4557 function) below. */
4558 if (TYPE_CI_CO_LIST (gnu_subprog_type))
4560 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
4561 copy-out parameters. */
4562 tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
4563 const int length = list_length (gnu_cico_list);
4565 /* The call sequence must contain one and only one call, even though the
4566 function is pure. Save the result into a temporary if needed. */
4567 if (length > 1)
4569 if (!gnu_retval)
4571 tree gnu_stmt;
4572 /* If we haven't pushed a binding level, push a new one. This
4573 will narrow the lifetime of the temporary we are about to
4574 make as much as possible. */
4575 if (!pushed_binding_level)
4577 start_stmt_group ();
4578 gnat_pushlevel ();
4579 pushed_binding_level = true;
4581 gnu_call
4582 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
4583 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4586 gnu_name_list = nreverse (gnu_name_list);
4589 /* The first entry is for the actual return value if this is a
4590 function, so skip it. */
4591 if (function_call)
4592 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4594 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
4595 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
4596 else
4597 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4599 for (gnat_actual = First_Actual (gnat_node);
4600 Present (gnat_actual);
4601 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4602 gnat_actual = Next_Actual (gnat_actual))
4603 /* If we are dealing with a copy-in/copy-out parameter, we must
4604 retrieve its value from the record returned in the call. */
4605 if (!(present_gnu_tree (gnat_formal)
4606 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
4607 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
4608 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))))
4609 && Ekind (gnat_formal) != E_In_Parameter)
4611 /* Get the value to assign to this Out or In Out parameter. It is
4612 either the result of the function if there is only a single such
4613 parameter or the appropriate field from the record returned. */
4614 tree gnu_result
4615 = length == 1
4616 ? gnu_call
4617 : build_component_ref (gnu_call, NULL_TREE,
4618 TREE_PURPOSE (gnu_cico_list), false);
4620 /* If the actual is a conversion, get the inner expression, which
4621 will be the real destination, and convert the result to the
4622 type of the actual parameter. */
4623 tree gnu_actual
4624 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
4626 /* If the result is a padded type, remove the padding. */
4627 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4628 gnu_result
4629 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4630 gnu_result);
4632 /* If the actual is a type conversion, the real target object is
4633 denoted by the inner Expression and we need to convert the
4634 result to the associated type.
4635 We also need to convert our gnu assignment target to this type
4636 if the corresponding GNU_NAME was constructed from the GNAT
4637 conversion node and not from the inner Expression. */
4638 if (Nkind (gnat_actual) == N_Type_Conversion)
4640 gnu_result
4641 = convert_with_check
4642 (Etype (Expression (gnat_actual)), gnu_result,
4643 Do_Overflow_Check (gnat_actual),
4644 Do_Range_Check (Expression (gnat_actual)),
4645 Float_Truncate (gnat_actual), gnat_actual);
4647 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
4648 gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
4651 /* Unchecked conversions as actuals for Out parameters are not
4652 allowed in user code because they are not variables, but do
4653 occur in front-end expansions. The associated GNU_NAME is
4654 always obtained from the inner expression in such cases. */
4655 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4656 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
4657 gnu_result,
4658 No_Truncation (gnat_actual));
4659 else
4661 if (Do_Range_Check (gnat_actual))
4662 gnu_result
4663 = emit_range_check (gnu_result, Etype (gnat_actual),
4664 gnat_actual);
4666 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
4667 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
4668 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
4671 /* If an outer atomic access is required for an actual parameter,
4672 build the load-modify-store sequence. */
4673 if (outer_atomic_access_required_p (gnat_actual))
4674 gnu_result
4675 = build_load_modify_store (gnu_actual, gnu_result, gnat_node);
4677 /* Or else, if simple atomic access is required, build the atomic
4678 store. */
4679 else if (atomic_access_required_p (gnat_actual, &sync))
4680 gnu_result = build_atomic_store (gnu_actual, gnu_result, sync);
4682 /* Otherwise build a regular assignment. */
4683 else
4684 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
4685 gnu_actual, gnu_result);
4687 if (EXPR_P (gnu_result))
4688 set_expr_location_from_node (gnu_result, gnat_node);
4689 append_to_statement_list (gnu_result, &gnu_stmt_list);
4690 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4691 gnu_name_list = TREE_CHAIN (gnu_name_list);
4695 /* If this is a function call, the result is the call expression unless a
4696 target is specified, in which case we copy the result into the target
4697 and return the assignment statement. */
4698 if (function_call)
4700 /* If this is a function with copy-in/copy-out parameters, extract the
4701 return value from it and update the return type. */
4702 if (TYPE_CI_CO_LIST (gnu_subprog_type))
4704 tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type);
4705 gnu_call = build_component_ref (gnu_call, NULL_TREE,
4706 TREE_PURPOSE (gnu_elmt), false);
4707 gnu_result_type = TREE_TYPE (gnu_call);
4710 /* If the function returns an unconstrained array or by direct reference,
4711 we have to dereference the pointer. */
4712 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
4713 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
4714 gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
4716 if (gnu_target)
4718 Node_Id gnat_parent = Parent (gnat_node);
4719 enum tree_code op_code;
4721 /* If range check is needed, emit code to generate it. */
4722 if (Do_Range_Check (gnat_node))
4723 gnu_call
4724 = emit_range_check (gnu_call, Etype (Name (gnat_parent)),
4725 gnat_parent);
4727 /* ??? If the return type has variable size, then force the return
4728 slot optimization as we would not be able to create a temporary.
4729 That's what has been done historically. */
4730 if (return_type_with_variable_size_p (gnu_result_type))
4731 op_code = INIT_EXPR;
4732 else
4733 op_code = MODIFY_EXPR;
4735 /* Use the required method to move the result to the target. */
4736 if (outer_atomic_access)
4737 gnu_call
4738 = build_load_modify_store (gnu_target, gnu_call, gnat_node);
4739 else if (atomic_access)
4740 gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync);
4741 else
4742 gnu_call
4743 = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
4745 if (EXPR_P (gnu_call))
4746 set_expr_location_from_node (gnu_call, gnat_parent);
4747 append_to_statement_list (gnu_call, &gnu_stmt_list);
4749 else
4750 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
4753 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
4754 parameters, the result is just the call statement. */
4755 else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
4756 append_to_statement_list (gnu_call, &gnu_stmt_list);
4758 /* Finally, add the copy back statements, if any. */
4759 append_to_statement_list (gnu_after_list, &gnu_stmt_list);
4761 if (went_into_elab_proc)
4762 current_function_decl = NULL_TREE;
4764 /* If we have pushed a binding level, pop it and finish up the enclosing
4765 statement group. */
4766 if (pushed_binding_level)
4768 add_stmt (gnu_stmt_list);
4769 gnat_poplevel ();
4770 gnu_result = end_stmt_group ();
4773 /* Otherwise, retrieve the statement list, if any. */
4774 else if (gnu_stmt_list)
4775 gnu_result = gnu_stmt_list;
4777 /* Otherwise, just return the call expression. */
4778 else
4779 return gnu_call;
4781 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
4782 But first simplify if we have only one statement in the list. */
4783 if (returning_value)
4785 tree first = expr_first (gnu_result), last = expr_last (gnu_result);
4786 if (first == last)
4787 gnu_result = first;
4788 gnu_result
4789 = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
4792 return gnu_result;
4795 /* Subroutine of gnat_to_gnu to translate gnat_node, an
4796 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
4798 static tree
4799 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
4801 tree gnu_jmpsave_decl = NULL_TREE;
4802 tree gnu_jmpbuf_decl = NULL_TREE;
4803 /* If just annotating, ignore all EH and cleanups. */
4804 bool gcc_zcx = (!type_annotate_only
4805 && Present (Exception_Handlers (gnat_node))
4806 && Exception_Mechanism == Back_End_Exceptions);
4807 bool setjmp_longjmp
4808 = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
4809 && Exception_Mechanism == Setjmp_Longjmp);
4810 bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
4811 bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
4812 tree gnu_inner_block; /* The statement(s) for the block itself. */
4813 tree gnu_result;
4814 tree gnu_expr;
4815 Node_Id gnat_temp;
4816 /* Node providing the sloc for the cleanup actions. */
4817 Node_Id gnat_cleanup_loc_node = (Present (End_Label (gnat_node)) ?
4818 End_Label (gnat_node) :
4819 gnat_node);
4821 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
4822 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
4823 add_cleanup, and when we leave the binding, end_stmt_group will create
4824 the TRY_FINALLY_EXPR.
4826 ??? The region level calls down there have been specifically put in place
4827 for a ZCX context and currently the order in which things are emitted
4828 (region/handlers) is different from the SJLJ case. Instead of putting
4829 other calls with different conditions at other places for the SJLJ case,
4830 it seems cleaner to reorder things for the SJLJ case and generalize the
4831 condition to make it not ZCX specific.
4833 If there are any exceptions or cleanup processing involved, we need an
4834 outer statement group (for Setjmp_Longjmp) and binding level. */
4835 if (binding_for_block)
4837 start_stmt_group ();
4838 gnat_pushlevel ();
4841 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
4842 area for address of previous buffer. Do this first since we need to have
4843 the setjmp buf known for any decls in this block. */
4844 if (setjmp_longjmp)
4846 gnu_jmpsave_decl
4847 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
4848 jmpbuf_ptr_type,
4849 build_call_n_expr (get_jmpbuf_decl, 0),
4850 false, false, false, false, NULL, gnat_node);
4851 DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
4853 /* The __builtin_setjmp receivers will immediately reinstall it. Now
4854 because of the unstructured form of EH used by setjmp_longjmp, there
4855 might be forward edges going to __builtin_setjmp receivers on which
4856 it is uninitialized, although they will never be actually taken. */
4857 TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
4858 gnu_jmpbuf_decl
4859 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE,
4860 jmpbuf_type,
4861 NULL_TREE,
4862 false, false, false, false, NULL, gnat_node);
4863 DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
4865 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
4867 /* When we exit this block, restore the saved value. */
4868 add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl),
4869 gnat_cleanup_loc_node);
4872 /* If we are to call a function when exiting this block, add a cleanup
4873 to the binding level we made above. Note that add_cleanup is FIFO
4874 so we must register this cleanup after the EH cleanup just above. */
4875 if (at_end)
4876 add_cleanup (build_call_n_expr (gnat_to_gnu (At_End_Proc (gnat_node)), 0),
4877 gnat_cleanup_loc_node);
4879 /* Now build the tree for the declarations and statements inside this block.
4880 If this is SJLJ, set our jmp_buf as the current buffer. */
4881 start_stmt_group ();
4883 if (setjmp_longjmp)
4885 gnu_expr = build_call_n_expr (set_jmpbuf_decl, 1,
4886 build_unary_op (ADDR_EXPR, NULL_TREE,
4887 gnu_jmpbuf_decl));
4888 set_expr_location_from_node (gnu_expr, gnat_node);
4889 add_stmt (gnu_expr);
4892 if (Present (First_Real_Statement (gnat_node)))
4893 process_decls (Statements (gnat_node), Empty,
4894 First_Real_Statement (gnat_node), true, true);
4896 /* Generate code for each statement in the block. */
4897 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
4898 ? First_Real_Statement (gnat_node)
4899 : First (Statements (gnat_node)));
4900 Present (gnat_temp); gnat_temp = Next (gnat_temp))
4901 add_stmt (gnat_to_gnu (gnat_temp));
4902 gnu_inner_block = end_stmt_group ();
4904 /* Now generate code for the two exception models, if either is relevant for
4905 this block. */
4906 if (setjmp_longjmp)
4908 tree *gnu_else_ptr = 0;
4909 tree gnu_handler;
4911 /* Make a binding level for the exception handling declarations and code
4912 and set up gnu_except_ptr_stack for the handlers to use. */
4913 start_stmt_group ();
4914 gnat_pushlevel ();
4916 vec_safe_push (gnu_except_ptr_stack,
4917 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
4918 build_pointer_type (except_type_node),
4919 build_call_n_expr (get_excptr_decl, 0),
4920 false, false, false, false,
4921 NULL, gnat_node));
4923 /* Generate code for each handler. The N_Exception_Handler case does the
4924 real work and returns a COND_EXPR for each handler, which we chain
4925 together here. */
4926 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
4927 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
4929 gnu_expr = gnat_to_gnu (gnat_temp);
4931 /* If this is the first one, set it as the outer one. Otherwise,
4932 point the "else" part of the previous handler to us. Then point
4933 to our "else" part. */
4934 if (!gnu_else_ptr)
4935 add_stmt (gnu_expr);
4936 else
4937 *gnu_else_ptr = gnu_expr;
4939 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
4942 /* If none of the exception handlers did anything, re-raise but do not
4943 defer abortion. */
4944 gnu_expr = build_call_n_expr (raise_nodefer_decl, 1,
4945 gnu_except_ptr_stack->last ());
4946 set_expr_location_from_node
4947 (gnu_expr,
4948 Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
4950 if (gnu_else_ptr)
4951 *gnu_else_ptr = gnu_expr;
4952 else
4953 add_stmt (gnu_expr);
4955 /* End the binding level dedicated to the exception handlers and get the
4956 whole statement group. */
4957 gnu_except_ptr_stack->pop ();
4958 gnat_poplevel ();
4959 gnu_handler = end_stmt_group ();
4961 /* If the setjmp returns 1, we restore our incoming longjmp value and
4962 then check the handlers. */
4963 start_stmt_group ();
4964 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl, 1,
4965 gnu_jmpsave_decl),
4966 gnat_node);
4967 add_stmt (gnu_handler);
4968 gnu_handler = end_stmt_group ();
4970 /* This block is now "if (setjmp) ... <handlers> else <block>". */
4971 gnu_result = build3 (COND_EXPR, void_type_node,
4972 (build_call_n_expr
4973 (setjmp_decl, 1,
4974 build_unary_op (ADDR_EXPR, NULL_TREE,
4975 gnu_jmpbuf_decl))),
4976 gnu_handler, gnu_inner_block);
4978 else if (gcc_zcx)
4980 tree gnu_handlers;
4981 location_t locus;
4983 /* First make a block containing the handlers. */
4984 start_stmt_group ();
4985 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
4986 Present (gnat_temp);
4987 gnat_temp = Next_Non_Pragma (gnat_temp))
4988 add_stmt (gnat_to_gnu (gnat_temp));
4989 gnu_handlers = end_stmt_group ();
4991 /* Now make the TRY_CATCH_EXPR for the block. */
4992 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
4993 gnu_inner_block, gnu_handlers);
4994 /* Set a location. We need to find a unique location for the dispatching
4995 code, otherwise we can get coverage or debugging issues. Try with
4996 the location of the end label. */
4997 if (Present (End_Label (gnat_node))
4998 && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus))
4999 SET_EXPR_LOCATION (gnu_result, locus);
5000 else
5001 /* Clear column information so that the exception handler of an
5002 implicit transient block does not incorrectly inherit the slocs
5003 of a decision, which would otherwise confuse control flow based
5004 coverage analysis tools. */
5005 set_expr_location_from_node1 (gnu_result, gnat_node, true);
5007 else
5008 gnu_result = gnu_inner_block;
5010 /* Now close our outer block, if we had to make one. */
5011 if (binding_for_block)
5013 add_stmt (gnu_result);
5014 gnat_poplevel ();
5015 gnu_result = end_stmt_group ();
5018 return gnu_result;
5021 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5022 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
5023 exception handling. */
5025 static tree
5026 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
5028 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
5029 an "if" statement to select the proper exceptions. For "Others", exclude
5030 exceptions where Handled_By_Others is nonzero unless the All_Others flag
5031 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
5032 tree gnu_choice = boolean_false_node;
5033 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
5034 Node_Id gnat_temp;
5036 for (gnat_temp = First (Exception_Choices (gnat_node));
5037 gnat_temp; gnat_temp = Next (gnat_temp))
5039 tree this_choice;
5041 if (Nkind (gnat_temp) == N_Others_Choice)
5043 if (All_Others (gnat_temp))
5044 this_choice = boolean_true_node;
5045 else
5046 this_choice
5047 = build_binary_op
5048 (EQ_EXPR, boolean_type_node,
5049 convert
5050 (integer_type_node,
5051 build_component_ref
5052 (build_unary_op
5053 (INDIRECT_REF, NULL_TREE,
5054 gnu_except_ptr_stack->last ()),
5055 get_identifier ("not_handled_by_others"), NULL_TREE,
5056 false)),
5057 integer_zero_node);
5060 else if (Nkind (gnat_temp) == N_Identifier
5061 || Nkind (gnat_temp) == N_Expanded_Name)
5063 Entity_Id gnat_ex_id = Entity (gnat_temp);
5064 tree gnu_expr;
5066 /* Exception may be a renaming. Recover original exception which is
5067 the one elaborated and registered. */
5068 if (Present (Renamed_Object (gnat_ex_id)))
5069 gnat_ex_id = Renamed_Object (gnat_ex_id);
5071 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
5073 this_choice
5074 = build_binary_op
5075 (EQ_EXPR, boolean_type_node,
5076 gnu_except_ptr_stack->last (),
5077 convert (TREE_TYPE (gnu_except_ptr_stack->last ()),
5078 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
5080 else
5081 gcc_unreachable ();
5083 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
5084 gnu_choice, this_choice);
5087 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
5090 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5091 to a GCC tree, which is returned. This is the variant for ZCX. */
5093 static tree
5094 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
5096 tree gnu_etypes_list = NULL_TREE;
5097 tree gnu_current_exc_ptr, prev_gnu_incoming_exc_ptr;
5098 Node_Id gnat_temp;
5100 /* We build a TREE_LIST of nodes representing what exception types this
5101 handler can catch, with special cases for others and all others cases.
5103 Each exception type is actually identified by a pointer to the exception
5104 id, or to a dummy object for "others" and "all others". */
5105 for (gnat_temp = First (Exception_Choices (gnat_node));
5106 gnat_temp; gnat_temp = Next (gnat_temp))
5108 tree gnu_expr, gnu_etype;
5110 if (Nkind (gnat_temp) == N_Others_Choice)
5112 gnu_expr = All_Others (gnat_temp) ? all_others_decl : others_decl;
5113 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5115 else if (Nkind (gnat_temp) == N_Identifier
5116 || Nkind (gnat_temp) == N_Expanded_Name)
5118 Entity_Id gnat_ex_id = Entity (gnat_temp);
5120 /* Exception may be a renaming. Recover original exception which is
5121 the one elaborated and registered. */
5122 if (Present (Renamed_Object (gnat_ex_id)))
5123 gnat_ex_id = Renamed_Object (gnat_ex_id);
5125 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
5126 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5128 else
5129 gcc_unreachable ();
5131 /* The GCC interface expects NULL to be passed for catch all handlers, so
5132 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
5133 is integer_zero_node. It would not work, however, because GCC's
5134 notion of "catch all" is stronger than our notion of "others". Until
5135 we correctly use the cleanup interface as well, doing that would
5136 prevent the "all others" handlers from being seen, because nothing
5137 can be caught beyond a catch all from GCC's point of view. */
5138 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
5141 start_stmt_group ();
5142 gnat_pushlevel ();
5144 /* Expand a call to the begin_handler hook at the beginning of the handler,
5145 and arrange for a call to the end_handler hook to occur on every possible
5146 exit path.
5148 The hooks expect a pointer to the low level occurrence. This is required
5149 for our stack management scheme because a raise inside the handler pushes
5150 a new occurrence on top of the stack, which means that this top does not
5151 necessarily match the occurrence this handler was dealing with.
5153 __builtin_eh_pointer references the exception occurrence being
5154 propagated. Upon handler entry, this is the exception for which the
5155 handler is triggered. This might not be the case upon handler exit,
5156 however, as we might have a new occurrence propagated by the handler's
5157 body, and the end_handler hook called as a cleanup in this context.
5159 We use a local variable to retrieve the incoming value at handler entry
5160 time, and reuse it to feed the end_handler hook's argument at exit. */
5162 gnu_current_exc_ptr
5163 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
5164 1, integer_zero_node);
5165 prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
5166 gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
5167 ptr_type_node, gnu_current_exc_ptr,
5168 false, false, false, false,
5169 NULL, gnat_node);
5171 add_stmt_with_node (build_call_n_expr (begin_handler_decl, 1,
5172 gnu_incoming_exc_ptr),
5173 gnat_node);
5175 /* Declare and initialize the choice parameter, if present. */
5176 if (Present (Choice_Parameter (gnat_node)))
5178 tree gnu_param
5179 = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, 1);
5181 add_stmt (build_call_n_expr
5182 (set_exception_parameter_decl, 2,
5183 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_param),
5184 gnu_incoming_exc_ptr));
5187 /* We don't have an End_Label at hand to set the location of the cleanup
5188 actions, so we use that of the exception handler itself instead. */
5189 add_cleanup (build_call_n_expr (end_handler_decl, 1, gnu_incoming_exc_ptr),
5190 gnat_node);
5191 add_stmt_list (Statements (gnat_node));
5192 gnat_poplevel ();
5194 gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
5196 return
5197 build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, end_stmt_group ());
5200 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
5202 static void
5203 Compilation_Unit_to_gnu (Node_Id gnat_node)
5205 const Node_Id gnat_unit = Unit (gnat_node);
5206 const bool body_p = (Nkind (gnat_unit) == N_Package_Body
5207 || Nkind (gnat_unit) == N_Subprogram_Body);
5208 const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
5209 Entity_Id gnat_entity;
5210 Node_Id gnat_pragma;
5211 /* Make the decl for the elaboration procedure. */
5212 tree gnu_elab_proc_decl
5213 = create_subprog_decl
5214 (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
5215 NULL_TREE, void_ftype, NULL_TREE, is_disabled, true, false, true, NULL,
5216 gnat_unit);
5217 struct elab_info *info;
5219 vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
5220 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
5222 /* Initialize the information structure for the function. */
5223 allocate_struct_function (gnu_elab_proc_decl, false);
5224 set_cfun (NULL);
5226 current_function_decl = NULL_TREE;
5228 start_stmt_group ();
5229 gnat_pushlevel ();
5231 /* For a body, first process the spec if there is one. */
5232 if (Nkind (gnat_unit) == N_Package_Body
5233 || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
5234 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
5236 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
5238 elaborate_all_entities (gnat_node);
5240 if (Nkind (gnat_unit) == N_Subprogram_Declaration
5241 || Nkind (gnat_unit) == N_Generic_Package_Declaration
5242 || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
5243 return;
5246 /* Then process any pragmas and declarations preceding the unit. */
5247 for (gnat_pragma = First (Context_Items (gnat_node));
5248 Present (gnat_pragma);
5249 gnat_pragma = Next (gnat_pragma))
5250 if (Nkind (gnat_pragma) == N_Pragma)
5251 add_stmt (gnat_to_gnu (gnat_pragma));
5252 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
5253 true, true);
5255 /* Process the unit itself. */
5256 add_stmt (gnat_to_gnu (gnat_unit));
5258 /* Generate code for all the inlined subprograms. */
5259 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5260 Present (gnat_entity);
5261 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5263 Node_Id gnat_body;
5265 /* Without optimization, process only the required subprograms. */
5266 if (!optimize && !Has_Pragma_Inline_Always (gnat_entity))
5267 continue;
5269 gnat_body = Parent (Declaration_Node (gnat_entity));
5270 if (Nkind (gnat_body) != N_Subprogram_Body)
5272 /* ??? This happens when only the spec of a package is provided. */
5273 if (No (Corresponding_Body (gnat_body)))
5274 continue;
5276 gnat_body
5277 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5280 /* Define the entity first so we set DECL_EXTERNAL. */
5281 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5282 add_stmt (gnat_to_gnu (gnat_body));
5285 /* Process any pragmas and actions following the unit. */
5286 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
5287 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
5288 finalize_from_limited_with ();
5290 /* Save away what we've made so far and finish it up. */
5291 set_current_block_context (gnu_elab_proc_decl);
5292 gnat_poplevel ();
5293 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
5294 set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
5295 gnu_elab_proc_stack->pop ();
5297 /* Record this potential elaboration procedure for later processing. */
5298 info = ggc_alloc<elab_info> ();
5299 info->next = elab_info_list;
5300 info->elab_proc = gnu_elab_proc_decl;
5301 info->gnat_node = gnat_node;
5302 elab_info_list = info;
5304 /* Force the processing for all nodes that remain in the queue. */
5305 process_deferred_decl_context (true);
5308 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Raise_xxx_Error,
5309 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where
5310 we should place the result type. LABEL_P is true if there is a label to
5311 branch to for the exception. */
5313 static tree
5314 Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
5316 const Node_Kind kind = Nkind (gnat_node);
5317 const int reason = UI_To_Int (Reason (gnat_node));
5318 const Node_Id gnat_cond = Condition (gnat_node);
5319 const bool with_extra_info
5320 = Exception_Extra_Info
5321 && !No_Exception_Handlers_Set ()
5322 && !get_exception_label (kind);
5323 tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
5325 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
5327 switch (reason)
5329 case CE_Access_Check_Failed:
5330 if (with_extra_info)
5331 gnu_result = build_call_raise_column (reason, gnat_node);
5332 break;
5334 case CE_Index_Check_Failed:
5335 case CE_Range_Check_Failed:
5336 case CE_Invalid_Data:
5337 if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not)
5339 Node_Id gnat_range, gnat_index, gnat_type;
5340 tree gnu_index, gnu_low_bound, gnu_high_bound;
5341 struct range_check_info_d *rci;
5343 switch (Nkind (Right_Opnd (gnat_cond)))
5345 case N_In:
5346 gnat_range = Right_Opnd (Right_Opnd (gnat_cond));
5347 gcc_assert (Nkind (gnat_range) == N_Range);
5348 gnu_low_bound = gnat_to_gnu (Low_Bound (gnat_range));
5349 gnu_high_bound = gnat_to_gnu (High_Bound (gnat_range));
5350 break;
5352 case N_Op_Ge:
5353 gnu_low_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
5354 gnu_high_bound = NULL_TREE;
5355 break;
5357 case N_Op_Le:
5358 gnu_low_bound = NULL_TREE;
5359 gnu_high_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
5360 break;
5362 default:
5363 goto common;
5366 gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
5367 gnat_type = Etype (gnat_index);
5368 gnu_index = gnat_to_gnu (gnat_index);
5370 if (with_extra_info
5371 && gnu_low_bound
5372 && gnu_high_bound
5373 && Known_Esize (gnat_type)
5374 && UI_To_Int (Esize (gnat_type)) <= 32)
5375 gnu_result
5376 = build_call_raise_range (reason, gnat_node, gnu_index,
5377 gnu_low_bound, gnu_high_bound);
5379 /* If loop unswitching is enabled, we try to compute invariant
5380 conditions for checks applied to iteration variables, i.e.
5381 conditions that are both independent of the variable and
5382 necessary in order for the check to fail in the course of
5383 some iteration, and prepend them to the original condition
5384 of the checks. This will make it possible later for the
5385 loop unswitching pass to replace the loop with two loops,
5386 one of which has the checks eliminated and the other has
5387 the original checks reinstated, and a run time selection.
5388 The former loop will be suitable for vectorization. */
5389 if (flag_unswitch_loops
5390 && !vec_safe_is_empty (gnu_loop_stack)
5391 && (!gnu_low_bound
5392 || (gnu_low_bound = gnat_invariant_expr (gnu_low_bound)))
5393 && (!gnu_high_bound
5394 || (gnu_high_bound = gnat_invariant_expr (gnu_high_bound)))
5395 && (rci = push_range_check_info (gnu_index)))
5397 rci->low_bound = gnu_low_bound;
5398 rci->high_bound = gnu_high_bound;
5399 rci->type = get_unpadded_type (gnat_type);
5400 rci->invariant_cond = build1 (SAVE_EXPR, boolean_type_node,
5401 boolean_true_node);
5402 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
5403 boolean_type_node,
5404 rci->invariant_cond,
5405 gnat_to_gnu (gnat_cond));
5408 break;
5410 default:
5411 break;
5414 common:
5415 if (!gnu_result)
5416 gnu_result = build_call_raise (reason, gnat_node, kind);
5417 set_expr_location_from_node (gnu_result, gnat_node);
5419 /* If the type is VOID, this is a statement, so we need to generate the code
5420 for the call. Handle a condition, if there is one. */
5421 if (VOID_TYPE_P (*gnu_result_type_p))
5423 if (Present (gnat_cond))
5425 if (!gnu_cond)
5426 gnu_cond = gnat_to_gnu (gnat_cond);
5427 gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
5428 alloc_stmt_list ());
5431 else
5432 gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
5434 return gnu_result;
5437 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
5438 parameter of a call. */
5440 static bool
5441 lhs_or_actual_p (Node_Id gnat_node)
5443 Node_Id gnat_parent = Parent (gnat_node);
5444 Node_Kind kind = Nkind (gnat_parent);
5446 if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
5447 return true;
5449 if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call)
5450 && Name (gnat_parent) != gnat_node)
5451 return true;
5453 if (kind == N_Parameter_Association)
5454 return true;
5456 return false;
5459 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
5460 of an assignment or an actual parameter of a call. */
5462 static bool
5463 present_in_lhs_or_actual_p (Node_Id gnat_node)
5465 Node_Kind kind;
5467 if (lhs_or_actual_p (gnat_node))
5468 return true;
5470 kind = Nkind (Parent (gnat_node));
5472 if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
5473 && lhs_or_actual_p (Parent (gnat_node)))
5474 return true;
5476 return false;
5479 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
5480 as gigi is concerned. This is used to avoid conversions on the LHS. */
5482 static bool
5483 unchecked_conversion_nop (Node_Id gnat_node)
5485 Entity_Id from_type, to_type;
5487 /* The conversion must be on the LHS of an assignment or an actual parameter
5488 of a call. Otherwise, even if the conversion was essentially a no-op, it
5489 could de facto ensure type consistency and this should be preserved. */
5490 if (!lhs_or_actual_p (gnat_node))
5491 return false;
5493 from_type = Etype (Expression (gnat_node));
5495 /* We're interested in artificial conversions generated by the front-end
5496 to make private types explicit, e.g. in Expand_Assign_Array. */
5497 if (!Is_Private_Type (from_type))
5498 return false;
5500 from_type = Underlying_Type (from_type);
5501 to_type = Etype (gnat_node);
5503 /* The direct conversion to the underlying type is a no-op. */
5504 if (to_type == from_type)
5505 return true;
5507 /* For an array subtype, the conversion to the PAIT is a no-op. */
5508 if (Ekind (from_type) == E_Array_Subtype
5509 && to_type == Packed_Array_Impl_Type (from_type))
5510 return true;
5512 /* For a record subtype, the conversion to the type is a no-op. */
5513 if (Ekind (from_type) == E_Record_Subtype
5514 && to_type == Etype (from_type))
5515 return true;
5517 return false;
5520 /* This function is the driver of the GNAT to GCC tree transformation process.
5521 It is the entry point of the tree transformer. GNAT_NODE is the root of
5522 some GNAT tree. Return the root of the corresponding GCC tree. If this
5523 is an expression, return the GCC equivalent of the expression. If this
5524 is a statement, return the statement or add it to the current statement
5525 group, in which case anything returned is to be interpreted as occurring
5526 after anything added. */
5528 tree
5529 gnat_to_gnu (Node_Id gnat_node)
5531 const Node_Kind kind = Nkind (gnat_node);
5532 bool went_into_elab_proc = false;
5533 tree gnu_result = error_mark_node; /* Default to no value. */
5534 tree gnu_result_type = void_type_node;
5535 tree gnu_expr, gnu_lhs, gnu_rhs;
5536 Node_Id gnat_temp;
5537 bool sync;
5539 /* Save node number for error message and set location information. */
5540 error_gnat_node = gnat_node;
5541 Sloc_to_locus (Sloc (gnat_node), &input_location);
5543 /* If this node is a statement and we are only annotating types, return an
5544 empty statement list. */
5545 if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call))
5546 return alloc_stmt_list ();
5548 /* If this node is a non-static subexpression and we are only annotating
5549 types, make this into a NULL_EXPR. */
5550 if (type_annotate_only
5551 && IN (kind, N_Subexpr)
5552 && kind != N_Identifier
5553 && !Compile_Time_Known_Value (gnat_node))
5554 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
5555 build_call_raise (CE_Range_Check_Failed, gnat_node,
5556 N_Raise_Constraint_Error));
5558 if ((IN (kind, N_Statement_Other_Than_Procedure_Call)
5559 && kind != N_Null_Statement)
5560 || kind == N_Procedure_Call_Statement
5561 || kind == N_Label
5562 || kind == N_Implicit_Label_Declaration
5563 || kind == N_Handled_Sequence_Of_Statements
5564 || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
5566 tree current_elab_proc = get_elaboration_procedure ();
5568 /* If this is a statement and we are at top level, it must be part of
5569 the elaboration procedure, so mark us as being in that procedure. */
5570 if (!current_function_decl)
5572 current_function_decl = current_elab_proc;
5573 went_into_elab_proc = true;
5576 /* If we are in the elaboration procedure, check if we are violating a
5577 No_Elaboration_Code restriction by having a statement there. Don't
5578 check for a possible No_Elaboration_Code restriction violation on
5579 N_Handled_Sequence_Of_Statements, as we want to signal an error on
5580 every nested real statement instead. This also avoids triggering
5581 spurious errors on dummy (empty) sequences created by the front-end
5582 for package bodies in some cases. */
5583 if (current_function_decl == current_elab_proc
5584 && kind != N_Handled_Sequence_Of_Statements)
5585 Check_Elaboration_Code_Allowed (gnat_node);
5588 switch (kind)
5590 /********************************/
5591 /* Chapter 2: Lexical Elements */
5592 /********************************/
5594 case N_Identifier:
5595 case N_Expanded_Name:
5596 case N_Operator_Symbol:
5597 case N_Defining_Identifier:
5598 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
5600 /* If atomic access is required on the RHS, build the atomic load. */
5601 if (atomic_access_required_p (gnat_node, &sync)
5602 && !present_in_lhs_or_actual_p (gnat_node))
5603 gnu_result = build_atomic_load (gnu_result, sync);
5604 break;
5606 case N_Integer_Literal:
5608 tree gnu_type;
5610 /* Get the type of the result, looking inside any padding and
5611 justified modular types. Then get the value in that type. */
5612 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
5614 if (TREE_CODE (gnu_type) == RECORD_TYPE
5615 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
5616 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
5618 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
5620 /* If the result overflows (meaning it doesn't fit in its base type),
5621 abort. We would like to check that the value is within the range
5622 of the subtype, but that causes problems with subtypes whose usage
5623 will raise Constraint_Error and with biased representation, so
5624 we don't. */
5625 gcc_assert (!TREE_OVERFLOW (gnu_result));
5627 break;
5629 case N_Character_Literal:
5630 /* If a Entity is present, it means that this was one of the
5631 literals in a user-defined character type. In that case,
5632 just return the value in the CONST_DECL. Otherwise, use the
5633 character code. In that case, the base type should be an
5634 INTEGER_TYPE, but we won't bother checking for that. */
5635 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5636 if (Present (Entity (gnat_node)))
5637 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
5638 else
5639 gnu_result
5640 = build_int_cst_type
5641 (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
5642 break;
5644 case N_Real_Literal:
5645 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5647 /* If this is of a fixed-point type, the value we want is the value of
5648 the corresponding integer. */
5649 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
5651 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
5652 gnu_result_type);
5653 gcc_assert (!TREE_OVERFLOW (gnu_result));
5656 else
5658 Ureal ur_realval = Realval (gnat_node);
5660 /* First convert the value to a machine number if it isn't already.
5661 That will force the base to 2 for non-zero values and simplify
5662 the rest of the logic. */
5663 if (!Is_Machine_Number (gnat_node))
5664 ur_realval
5665 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
5666 ur_realval, Round_Even, gnat_node);
5668 if (UR_Is_Zero (ur_realval))
5669 gnu_result = convert (gnu_result_type, integer_zero_node);
5670 else
5672 REAL_VALUE_TYPE tmp;
5674 gnu_result = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
5676 /* The base must be 2 as Machine guarantees this, so we scale
5677 the value, which we know can fit in the mantissa of the type
5678 (hence the use of that type above). */
5679 gcc_assert (Rbase (ur_realval) == 2);
5680 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
5681 - UI_To_Int (Denominator (ur_realval)));
5682 gnu_result = build_real (gnu_result_type, tmp);
5685 /* Now see if we need to negate the result. Do it this way to
5686 properly handle -0. */
5687 if (UR_Is_Negative (Realval (gnat_node)))
5688 gnu_result
5689 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
5690 gnu_result);
5693 break;
5695 case N_String_Literal:
5696 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5697 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
5699 String_Id gnat_string = Strval (gnat_node);
5700 int length = String_Length (gnat_string);
5701 int i;
5702 char *string;
5703 if (length >= ALLOCA_THRESHOLD)
5704 string = XNEWVEC (char, length + 1);
5705 else
5706 string = (char *) alloca (length + 1);
5708 /* Build the string with the characters in the literal. Note
5709 that Ada strings are 1-origin. */
5710 for (i = 0; i < length; i++)
5711 string[i] = Get_String_Char (gnat_string, i + 1);
5713 /* Put a null at the end of the string in case it's in a context
5714 where GCC will want to treat it as a C string. */
5715 string[i] = 0;
5717 gnu_result = build_string (length, string);
5719 /* Strings in GCC don't normally have types, but we want
5720 this to not be converted to the array type. */
5721 TREE_TYPE (gnu_result) = gnu_result_type;
5723 if (length >= ALLOCA_THRESHOLD)
5724 free (string);
5726 else
5728 /* Build a list consisting of each character, then make
5729 the aggregate. */
5730 String_Id gnat_string = Strval (gnat_node);
5731 int length = String_Length (gnat_string);
5732 int i;
5733 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
5734 tree gnu_one_node = convert (TREE_TYPE (gnu_idx), integer_one_node);
5735 vec<constructor_elt, va_gc> *gnu_vec;
5736 vec_alloc (gnu_vec, length);
5738 for (i = 0; i < length; i++)
5740 tree t = build_int_cst (TREE_TYPE (gnu_result_type),
5741 Get_String_Char (gnat_string, i + 1));
5743 CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
5744 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, gnu_one_node);
5747 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
5749 break;
5751 case N_Pragma:
5752 gnu_result = Pragma_to_gnu (gnat_node);
5753 break;
5755 /**************************************/
5756 /* Chapter 3: Declarations and Types */
5757 /**************************************/
5759 case N_Subtype_Declaration:
5760 case N_Full_Type_Declaration:
5761 case N_Incomplete_Type_Declaration:
5762 case N_Private_Type_Declaration:
5763 case N_Private_Extension_Declaration:
5764 case N_Task_Type_Declaration:
5765 process_type (Defining_Entity (gnat_node));
5766 gnu_result = alloc_stmt_list ();
5767 break;
5769 case N_Object_Declaration:
5770 case N_Exception_Declaration:
5771 gnat_temp = Defining_Entity (gnat_node);
5772 gnu_result = alloc_stmt_list ();
5774 /* If we are just annotating types and this object has an unconstrained
5775 or task type, don't elaborate it. */
5776 if (type_annotate_only
5777 && (((Is_Array_Type (Etype (gnat_temp))
5778 || Is_Record_Type (Etype (gnat_temp)))
5779 && !Is_Constrained (Etype (gnat_temp)))
5780 || Is_Concurrent_Type (Etype (gnat_temp))))
5781 break;
5783 if (Present (Expression (gnat_node))
5784 && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
5785 && (!type_annotate_only
5786 || Compile_Time_Known_Value (Expression (gnat_node))))
5788 gnu_expr = gnat_to_gnu (Expression (gnat_node));
5789 if (Do_Range_Check (Expression (gnat_node)))
5790 gnu_expr
5791 = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
5793 if (type_annotate_only && TREE_CODE (gnu_expr) == ERROR_MARK)
5794 gnu_expr = NULL_TREE;
5796 else
5797 gnu_expr = NULL_TREE;
5799 /* If this is a deferred constant with an address clause, we ignore the
5800 full view since the clause is on the partial view and we cannot have
5801 2 different GCC trees for the object. The only bits of the full view
5802 we will use is the initializer, but it will be directly fetched. */
5803 if (Ekind(gnat_temp) == E_Constant
5804 && Present (Address_Clause (gnat_temp))
5805 && Present (Full_View (gnat_temp)))
5806 save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
5808 /* If this object has its elaboration delayed, we must force evaluation
5809 of GNU_EXPR now and save it for the freeze point. Note that we need
5810 not do anything special at the global level since the lifetime of the
5811 temporary is fully contained within the elaboration routine. */
5812 if (Present (Freeze_Node (gnat_temp)))
5814 if (gnu_expr)
5816 gnu_result = gnat_save_expr (gnu_expr);
5817 save_gnu_tree (gnat_node, gnu_result, true);
5820 else
5821 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
5822 break;
5824 case N_Object_Renaming_Declaration:
5825 gnat_temp = Defining_Entity (gnat_node);
5826 gnu_result = alloc_stmt_list ();
5828 /* Don't do anything if this renaming is handled by the front end or if
5829 we are just annotating types and this object has a composite or task
5830 type, don't elaborate it. */
5831 if (!Is_Renaming_Of_Object (gnat_temp)
5832 && ! (type_annotate_only
5833 && (Is_Array_Type (Etype (gnat_temp))
5834 || Is_Record_Type (Etype (gnat_temp))
5835 || Is_Concurrent_Type (Etype (gnat_temp)))))
5837 tree gnu_temp
5838 = gnat_to_gnu_entity (gnat_temp,
5839 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
5840 /* See case 2 of renaming in gnat_to_gnu_entity. */
5841 if (TREE_SIDE_EFFECTS (gnu_temp))
5842 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
5844 break;
5846 case N_Exception_Renaming_Declaration:
5847 gnat_temp = Defining_Entity (gnat_node);
5848 gnu_result = alloc_stmt_list ();
5850 /* See the above case for the rationale. */
5851 if (Present (Renamed_Entity (gnat_temp)))
5853 tree gnu_temp
5854 = gnat_to_gnu_entity (gnat_temp,
5855 gnat_to_gnu (Renamed_Entity (gnat_temp)), 1);
5856 if (TREE_SIDE_EFFECTS (gnu_temp))
5857 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
5859 break;
5861 case N_Implicit_Label_Declaration:
5862 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
5863 gnu_result = alloc_stmt_list ();
5864 break;
5866 case N_Number_Declaration:
5867 case N_Subprogram_Renaming_Declaration:
5868 case N_Package_Renaming_Declaration:
5869 /* These are fully handled in the front end. */
5870 /* ??? For package renamings, find a way to use GENERIC namespaces so
5871 that we get proper debug information for them. */
5872 gnu_result = alloc_stmt_list ();
5873 break;
5875 /*************************************/
5876 /* Chapter 4: Names and Expressions */
5877 /*************************************/
5879 case N_Explicit_Dereference:
5880 gnu_result = gnat_to_gnu (Prefix (gnat_node));
5881 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5882 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
5884 /* If atomic access is required on the RHS, build the atomic load. */
5885 if (atomic_access_required_p (gnat_node, &sync)
5886 && !present_in_lhs_or_actual_p (gnat_node))
5887 gnu_result = build_atomic_load (gnu_result, sync);
5888 break;
5890 case N_Indexed_Component:
5892 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
5893 tree gnu_type;
5894 int ndim;
5895 int i;
5896 Node_Id *gnat_expr_array;
5898 gnu_array_object = maybe_implicit_deref (gnu_array_object);
5900 /* Convert vector inputs to their representative array type, to fit
5901 what the code below expects. */
5902 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object)))
5904 if (present_in_lhs_or_actual_p (gnat_node))
5905 gnat_mark_addressable (gnu_array_object);
5906 gnu_array_object = maybe_vector_array (gnu_array_object);
5909 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
5911 /* If we got a padded type, remove it too. */
5912 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
5913 gnu_array_object
5914 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
5915 gnu_array_object);
5917 gnu_result = gnu_array_object;
5919 /* The failure of this assertion will very likely come from a missing
5920 expansion for a packed array access. */
5921 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
5923 /* First compute the number of dimensions of the array, then
5924 fill the expression array, the order depending on whether
5925 this is a Convention_Fortran array or not. */
5926 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
5927 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5928 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
5929 ndim++, gnu_type = TREE_TYPE (gnu_type))
5932 gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
5934 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
5935 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
5936 i >= 0;
5937 i--, gnat_temp = Next (gnat_temp))
5938 gnat_expr_array[i] = gnat_temp;
5939 else
5940 for (i = 0, gnat_temp = First (Expressions (gnat_node));
5941 i < ndim;
5942 i++, gnat_temp = Next (gnat_temp))
5943 gnat_expr_array[i] = gnat_temp;
5945 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
5946 i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
5948 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
5949 gnat_temp = gnat_expr_array[i];
5950 gnu_expr = gnat_to_gnu (gnat_temp);
5952 if (Do_Range_Check (gnat_temp))
5953 gnu_expr
5954 = emit_index_check
5955 (gnu_array_object, gnu_expr,
5956 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
5957 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
5958 gnat_temp);
5960 gnu_result
5961 = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
5963 /* Array accesses are bound-checked so they cannot trap, but this
5964 is valid only if they are not hoisted ahead of the check. We
5965 need to mark them as no-trap to get decent loop optimizations
5966 in the presence of -fnon-call-exceptions, so we do it when we
5967 know that the original expression had no side-effects. */
5968 if (TREE_CODE (gnu_result) == ARRAY_REF
5969 && !(Nkind (gnat_temp) == N_Identifier
5970 && Ekind (Entity (gnat_temp)) == E_Constant))
5971 TREE_THIS_NOTRAP (gnu_result) = 1;
5974 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5976 /* If atomic access is required on the RHS, build the atomic load. */
5977 if (atomic_access_required_p (gnat_node, &sync)
5978 && !present_in_lhs_or_actual_p (gnat_node))
5979 gnu_result = build_atomic_load (gnu_result, sync);
5981 break;
5983 case N_Slice:
5985 Node_Id gnat_range_node = Discrete_Range (gnat_node);
5986 tree gnu_type;
5988 gnu_result = gnat_to_gnu (Prefix (gnat_node));
5989 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5991 /* Do any implicit dereferences of the prefix and do any needed
5992 range check. */
5993 gnu_result = maybe_implicit_deref (gnu_result);
5994 gnu_result = maybe_unconstrained_array (gnu_result);
5995 gnu_type = TREE_TYPE (gnu_result);
5996 if (Do_Range_Check (gnat_range_node))
5998 /* Get the bounds of the slice. */
5999 tree gnu_index_type
6000 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
6001 tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
6002 tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
6003 /* Get the permitted bounds. */
6004 tree gnu_base_index_type
6005 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
6006 tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
6007 (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result);
6008 tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
6009 (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
6010 tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
6012 gnu_min_expr = gnat_protect_expr (gnu_min_expr);
6013 gnu_max_expr = gnat_protect_expr (gnu_max_expr);
6015 /* Derive a good type to convert everything to. */
6016 gnu_expr_type = get_base_type (gnu_index_type);
6018 /* Test whether the minimum slice value is too small. */
6019 gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node,
6020 convert (gnu_expr_type,
6021 gnu_min_expr),
6022 convert (gnu_expr_type,
6023 gnu_base_min_expr));
6025 /* Test whether the maximum slice value is too large. */
6026 gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node,
6027 convert (gnu_expr_type,
6028 gnu_max_expr),
6029 convert (gnu_expr_type,
6030 gnu_base_max_expr));
6032 /* Build a slice index check that returns the low bound,
6033 assuming the slice is not empty. */
6034 gnu_expr = emit_check
6035 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
6036 gnu_expr_l, gnu_expr_h),
6037 gnu_min_expr, CE_Index_Check_Failed, gnat_node);
6039 /* Build a conditional expression that does the index checks and
6040 returns the low bound if the slice is not empty (max >= min),
6041 and returns the naked low bound otherwise (max < min), unless
6042 it is non-constant and the high bound is; this prevents VRP
6043 from inferring bogus ranges on the unlikely path. */
6044 gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
6045 build_binary_op (GE_EXPR, gnu_expr_type,
6046 convert (gnu_expr_type,
6047 gnu_max_expr),
6048 convert (gnu_expr_type,
6049 gnu_min_expr)),
6050 gnu_expr,
6051 TREE_CODE (gnu_min_expr) != INTEGER_CST
6052 && TREE_CODE (gnu_max_expr) == INTEGER_CST
6053 ? gnu_max_expr : gnu_min_expr);
6055 else
6056 /* Simply return the naked low bound. */
6057 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6059 /* If this is a slice with non-constant size of an array with constant
6060 size, set the maximum size for the allocation of temporaries. */
6061 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
6062 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
6063 TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
6065 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
6066 gnu_result, gnu_expr);
6068 break;
6070 case N_Selected_Component:
6072 Entity_Id gnat_prefix = Prefix (gnat_node);
6073 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
6074 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
6075 tree gnu_field;
6077 gnu_prefix = maybe_implicit_deref (gnu_prefix);
6079 /* For discriminant references in tagged types always substitute the
6080 corresponding discriminant as the actual selected component. */
6081 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix))))
6082 while (Present (Corresponding_Discriminant (gnat_field)))
6083 gnat_field = Corresponding_Discriminant (gnat_field);
6085 /* For discriminant references of untagged types always substitute the
6086 corresponding stored discriminant. */
6087 else if (Present (Corresponding_Discriminant (gnat_field)))
6088 gnat_field = Original_Record_Component (gnat_field);
6090 /* Handle extracting the real or imaginary part of a complex.
6091 The real part is the first field and the imaginary the last. */
6092 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
6093 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
6094 ? REALPART_EXPR : IMAGPART_EXPR,
6095 NULL_TREE, gnu_prefix);
6096 else
6098 gnu_field = gnat_to_gnu_field_decl (gnat_field);
6100 gnu_result
6101 = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
6102 (Nkind (Parent (gnat_node))
6103 == N_Attribute_Reference)
6104 && lvalue_required_for_attribute_p
6105 (Parent (gnat_node)));
6108 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6110 /* If atomic access is required on the RHS, build the atomic load. */
6111 if (atomic_access_required_p (gnat_node, &sync)
6112 && !present_in_lhs_or_actual_p (gnat_node))
6113 gnu_result = build_atomic_load (gnu_result, sync);
6115 break;
6117 case N_Attribute_Reference:
6119 /* The attribute designator. */
6120 const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
6122 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
6123 is a unit, not an object with a GCC equivalent. */
6124 if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
6125 return
6126 create_subprog_decl (create_concat_name
6127 (Entity (Prefix (gnat_node)),
6128 attr == Attr_Elab_Body ? "elabb" : "elabs"),
6129 NULL_TREE, void_ftype, NULL_TREE, is_disabled,
6130 true, true, true, NULL, gnat_node);
6132 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
6134 break;
6136 case N_Reference:
6137 /* Like 'Access as far as we are concerned. */
6138 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6139 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6140 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6141 break;
6143 case N_Aggregate:
6144 case N_Extension_Aggregate:
6146 tree gnu_aggr_type;
6148 /* ??? It is wrong to evaluate the type now, but there doesn't
6149 seem to be any other practical way of doing it. */
6151 gcc_assert (!Expansion_Delayed (gnat_node));
6153 gnu_aggr_type = gnu_result_type
6154 = get_unpadded_type (Etype (gnat_node));
6156 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
6157 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
6158 gnu_aggr_type
6159 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type)));
6160 else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
6161 gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
6163 if (Null_Record_Present (gnat_node))
6164 gnu_result = gnat_build_constructor (gnu_aggr_type,
6165 NULL);
6167 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
6168 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
6169 gnu_result
6170 = assoc_to_constructor (Etype (gnat_node),
6171 First (Component_Associations (gnat_node)),
6172 gnu_aggr_type);
6173 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
6174 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
6175 gnu_aggr_type,
6176 Component_Type (Etype (gnat_node)));
6177 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
6178 gnu_result
6179 = build_binary_op
6180 (COMPLEX_EXPR, gnu_aggr_type,
6181 gnat_to_gnu (Expression (First
6182 (Component_Associations (gnat_node)))),
6183 gnat_to_gnu (Expression
6184 (Next
6185 (First (Component_Associations (gnat_node))))));
6186 else
6187 gcc_unreachable ();
6189 gnu_result = convert (gnu_result_type, gnu_result);
6191 break;
6193 case N_Null:
6194 if (TARGET_VTABLE_USES_DESCRIPTORS
6195 && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
6196 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
6197 gnu_result = null_fdesc_node;
6198 else
6199 gnu_result = null_pointer_node;
6200 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6201 break;
6203 case N_Type_Conversion:
6204 case N_Qualified_Expression:
6205 /* Get the operand expression. */
6206 gnu_result = gnat_to_gnu (Expression (gnat_node));
6207 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6209 /* If this is a qualified expression for a tagged type, we mark the type
6210 as used. Because of polymorphism, this might be the only reference to
6211 the tagged type in the program while objects have it as dynamic type.
6212 The debugger needs to see it to display these objects properly. */
6213 if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node)))
6214 used_types_insert (gnu_result_type);
6216 gnu_result
6217 = convert_with_check (Etype (gnat_node), gnu_result,
6218 Do_Overflow_Check (gnat_node),
6219 Do_Range_Check (Expression (gnat_node)),
6220 kind == N_Type_Conversion
6221 && Float_Truncate (gnat_node), gnat_node);
6222 break;
6224 case N_Unchecked_Type_Conversion:
6225 gnu_result = gnat_to_gnu (Expression (gnat_node));
6227 /* Skip further processing if the conversion is deemed a no-op. */
6228 if (unchecked_conversion_nop (gnat_node))
6230 gnu_result_type = TREE_TYPE (gnu_result);
6231 break;
6234 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6236 /* If the result is a pointer type, see if we are improperly
6237 converting to a stricter alignment. */
6238 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
6239 && IN (Ekind (Etype (gnat_node)), Access_Kind))
6241 unsigned int align = known_alignment (gnu_result);
6242 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
6243 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
6245 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
6246 post_error_ne_tree_2
6247 ("?source alignment (^) '< alignment of & (^)",
6248 gnat_node, Designated_Type (Etype (gnat_node)),
6249 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
6252 /* If we are converting a descriptor to a function pointer, first
6253 build the pointer. */
6254 if (TARGET_VTABLE_USES_DESCRIPTORS
6255 && TREE_TYPE (gnu_result) == fdesc_type_node
6256 && POINTER_TYPE_P (gnu_result_type))
6257 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6259 gnu_result = unchecked_convert (gnu_result_type, gnu_result,
6260 No_Truncation (gnat_node));
6261 break;
6263 case N_In:
6264 case N_Not_In:
6266 tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
6267 Node_Id gnat_range = Right_Opnd (gnat_node);
6268 tree gnu_low, gnu_high;
6270 /* GNAT_RANGE is either an N_Range node or an identifier denoting a
6271 subtype. */
6272 if (Nkind (gnat_range) == N_Range)
6274 gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
6275 gnu_high = gnat_to_gnu (High_Bound (gnat_range));
6277 else if (Nkind (gnat_range) == N_Identifier
6278 || Nkind (gnat_range) == N_Expanded_Name)
6280 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
6281 tree gnu_range_base_type = get_base_type (gnu_range_type);
6283 gnu_low
6284 = convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type));
6285 gnu_high
6286 = convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type));
6288 else
6289 gcc_unreachable ();
6291 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6293 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
6294 ensure that GNU_OBJ is evaluated only once and perform a full range
6295 test. */
6296 if (operand_equal_p (gnu_low, gnu_high, 0))
6297 gnu_result
6298 = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
6299 else
6301 tree t1, t2;
6302 gnu_obj = gnat_protect_expr (gnu_obj);
6303 t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
6304 if (EXPR_P (t1))
6305 set_expr_location_from_node (t1, gnat_node);
6306 t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
6307 if (EXPR_P (t2))
6308 set_expr_location_from_node (t2, gnat_node);
6309 gnu_result
6310 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
6313 if (kind == N_Not_In)
6314 gnu_result
6315 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
6317 break;
6319 case N_Op_Divide:
6320 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6321 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6322 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6323 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
6324 ? RDIV_EXPR
6325 : (Rounded_Result (gnat_node)
6326 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
6327 gnu_result_type, gnu_lhs, gnu_rhs);
6328 break;
6330 case N_Op_Or: case N_Op_And: case N_Op_Xor:
6331 /* These can either be operations on booleans or on modular types.
6332 Fall through for boolean types since that's the way GNU_CODES is
6333 set up. */
6334 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
6336 enum tree_code code
6337 = (kind == N_Op_Or ? BIT_IOR_EXPR
6338 : kind == N_Op_And ? BIT_AND_EXPR
6339 : BIT_XOR_EXPR);
6341 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6342 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6343 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6344 gnu_result = build_binary_op (code, gnu_result_type,
6345 gnu_lhs, gnu_rhs);
6346 break;
6349 /* ... fall through ... */
6351 case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
6352 case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
6353 case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
6354 case N_Op_Mod: case N_Op_Rem:
6355 case N_Op_Rotate_Left:
6356 case N_Op_Rotate_Right:
6357 case N_Op_Shift_Left:
6358 case N_Op_Shift_Right:
6359 case N_Op_Shift_Right_Arithmetic:
6360 case N_And_Then: case N_Or_Else:
6362 enum tree_code code = gnu_codes[kind];
6363 bool ignore_lhs_overflow = false;
6364 location_t saved_location = input_location;
6365 tree gnu_type;
6367 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6368 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6369 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
6371 /* Pending generic support for efficient vector logical operations in
6372 GCC, convert vectors to their representative array type view and
6373 fallthrough. */
6374 gnu_lhs = maybe_vector_array (gnu_lhs);
6375 gnu_rhs = maybe_vector_array (gnu_rhs);
6377 /* If this is a comparison operator, convert any references to an
6378 unconstrained array value into a reference to the actual array. */
6379 if (TREE_CODE_CLASS (code) == tcc_comparison)
6381 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
6382 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
6385 /* If this is a shift whose count is not guaranteed to be correct,
6386 we need to adjust the shift count. */
6387 if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
6389 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
6390 tree gnu_max_shift
6391 = convert (gnu_count_type, TYPE_SIZE (gnu_type));
6393 if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
6394 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
6395 gnu_rhs, gnu_max_shift);
6396 else if (kind == N_Op_Shift_Right_Arithmetic)
6397 gnu_rhs
6398 = build_binary_op
6399 (MIN_EXPR, gnu_count_type,
6400 build_binary_op (MINUS_EXPR,
6401 gnu_count_type,
6402 gnu_max_shift,
6403 convert (gnu_count_type,
6404 integer_one_node)),
6405 gnu_rhs);
6408 /* For right shifts, the type says what kind of shift to do,
6409 so we may need to choose a different type. In this case,
6410 we have to ignore integer overflow lest it propagates all
6411 the way down and causes a CE to be explicitly raised. */
6412 if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
6414 gnu_type = gnat_unsigned_type (gnu_type);
6415 ignore_lhs_overflow = true;
6417 else if (kind == N_Op_Shift_Right_Arithmetic
6418 && TYPE_UNSIGNED (gnu_type))
6420 gnu_type = gnat_signed_type (gnu_type);
6421 ignore_lhs_overflow = true;
6424 if (gnu_type != gnu_result_type)
6426 tree gnu_old_lhs = gnu_lhs;
6427 gnu_lhs = convert (gnu_type, gnu_lhs);
6428 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
6429 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
6430 gnu_rhs = convert (gnu_type, gnu_rhs);
6433 /* Instead of expanding overflow checks for addition, subtraction
6434 and multiplication itself, the front end will leave this to
6435 the back end when Backend_Overflow_Checks_On_Target is set.
6436 As the GCC back end itself does not know yet how to properly
6437 do overflow checking, do it here. The goal is to push
6438 the expansions further into the back end over time. */
6439 if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
6440 && (kind == N_Op_Add
6441 || kind == N_Op_Subtract
6442 || kind == N_Op_Multiply)
6443 && !TYPE_UNSIGNED (gnu_type)
6444 && !FLOAT_TYPE_P (gnu_type))
6445 gnu_result = build_binary_op_trapv (code, gnu_type,
6446 gnu_lhs, gnu_rhs, gnat_node);
6447 else
6449 /* Some operations, e.g. comparisons of arrays, generate complex
6450 trees that need to be annotated while they are being built. */
6451 input_location = saved_location;
6452 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
6455 /* If this is a logical shift with the shift count not verified,
6456 we must return zero if it is too large. We cannot compensate
6457 above in this case. */
6458 if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
6459 && !Shift_Count_OK (gnat_node))
6460 gnu_result
6461 = build_cond_expr
6462 (gnu_type,
6463 build_binary_op (GE_EXPR, boolean_type_node,
6464 gnu_rhs,
6465 convert (TREE_TYPE (gnu_rhs),
6466 TYPE_SIZE (gnu_type))),
6467 convert (gnu_type, integer_zero_node),
6468 gnu_result);
6470 break;
6472 case N_If_Expression:
6474 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
6475 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
6476 tree gnu_false
6477 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
6479 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6480 gnu_result
6481 = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
6483 break;
6485 case N_Op_Plus:
6486 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
6487 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6488 break;
6490 case N_Op_Not:
6491 /* This case can apply to a boolean or a modular type.
6492 Fall through for a boolean operand since GNU_CODES is set
6493 up to handle this. */
6494 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
6496 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
6497 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6498 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
6499 gnu_expr);
6500 break;
6503 /* ... fall through ... */
6505 case N_Op_Minus: case N_Op_Abs:
6506 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
6507 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6509 if (Do_Overflow_Check (gnat_node)
6510 && !TYPE_UNSIGNED (gnu_result_type)
6511 && !FLOAT_TYPE_P (gnu_result_type))
6512 gnu_result
6513 = build_unary_op_trapv (gnu_codes[kind],
6514 gnu_result_type, gnu_expr, gnat_node);
6515 else
6516 gnu_result = build_unary_op (gnu_codes[kind],
6517 gnu_result_type, gnu_expr);
6518 break;
6520 case N_Allocator:
6522 tree gnu_init = 0;
6523 tree gnu_type;
6524 bool ignore_init_type = false;
6526 gnat_temp = Expression (gnat_node);
6528 /* The Expression operand can either be an N_Identifier or
6529 Expanded_Name, which must represent a type, or a
6530 N_Qualified_Expression, which contains both the object type and an
6531 initial value for the object. */
6532 if (Nkind (gnat_temp) == N_Identifier
6533 || Nkind (gnat_temp) == N_Expanded_Name)
6534 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
6535 else if (Nkind (gnat_temp) == N_Qualified_Expression)
6537 Entity_Id gnat_desig_type
6538 = Designated_Type (Underlying_Type (Etype (gnat_node)));
6540 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
6541 gnu_init = gnat_to_gnu (Expression (gnat_temp));
6543 gnu_init = maybe_unconstrained_array (gnu_init);
6544 if (Do_Range_Check (Expression (gnat_temp)))
6545 gnu_init
6546 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
6548 if (Is_Elementary_Type (gnat_desig_type)
6549 || Is_Constrained (gnat_desig_type))
6550 gnu_type = gnat_to_gnu_type (gnat_desig_type);
6551 else
6553 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
6554 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
6555 gnu_type = TREE_TYPE (gnu_init);
6558 /* See the N_Qualified_Expression case for the rationale. */
6559 if (Is_Tagged_Type (gnat_desig_type))
6560 used_types_insert (gnu_type);
6562 gnu_init = convert (gnu_type, gnu_init);
6564 else
6565 gcc_unreachable ();
6567 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6568 return build_allocator (gnu_type, gnu_init, gnu_result_type,
6569 Procedure_To_Call (gnat_node),
6570 Storage_Pool (gnat_node), gnat_node,
6571 ignore_init_type);
6573 break;
6575 /**************************/
6576 /* Chapter 5: Statements */
6577 /**************************/
6579 case N_Label:
6580 gnu_result = build1 (LABEL_EXPR, void_type_node,
6581 gnat_to_gnu (Identifier (gnat_node)));
6582 break;
6584 case N_Null_Statement:
6585 /* When not optimizing, turn null statements from source into gotos to
6586 the next statement that the middle-end knows how to preserve. */
6587 if (!optimize && Comes_From_Source (gnat_node))
6589 tree stmt, label = create_label_decl (NULL_TREE, gnat_node);
6590 DECL_IGNORED_P (label) = 1;
6591 start_stmt_group ();
6592 stmt = build1 (GOTO_EXPR, void_type_node, label);
6593 set_expr_location_from_node (stmt, gnat_node);
6594 add_stmt (stmt);
6595 stmt = build1 (LABEL_EXPR, void_type_node, label);
6596 set_expr_location_from_node (stmt, gnat_node);
6597 add_stmt (stmt);
6598 gnu_result = end_stmt_group ();
6600 else
6601 gnu_result = alloc_stmt_list ();
6602 break;
6604 case N_Assignment_Statement:
6605 /* Get the LHS and RHS of the statement and convert any reference to an
6606 unconstrained array into a reference to the underlying array. */
6607 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
6609 /* If the type has a size that overflows, convert this into raise of
6610 Storage_Error: execution shouldn't have gotten here anyway. */
6611 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
6612 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
6613 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
6614 N_Raise_Storage_Error);
6615 else if (Nkind (Expression (gnat_node)) == N_Function_Call)
6617 bool outer_atomic_access
6618 = outer_atomic_access_required_p (Name (gnat_node));
6619 bool atomic_access
6620 = !outer_atomic_access
6621 && atomic_access_required_p (Name (gnat_node), &sync);
6622 gnu_result
6623 = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
6624 outer_atomic_access, atomic_access, sync);
6626 else
6628 const Node_Id gnat_expr = Expression (gnat_node);
6629 const Entity_Id gnat_type
6630 = Underlying_Type (Etype (Name (gnat_node)));
6631 const bool regular_array_type_p
6632 = (Is_Array_Type (gnat_type) && !Is_Bit_Packed_Array (gnat_type));
6633 const bool use_memset_p
6634 = (regular_array_type_p
6635 && Nkind (gnat_expr) == N_Aggregate
6636 && Is_Others_Aggregate (gnat_expr));
6638 /* If we'll use memset, we need to find the inner expression. */
6639 if (use_memset_p)
6641 Node_Id gnat_inner
6642 = Expression (First (Component_Associations (gnat_expr)));
6643 while (Nkind (gnat_inner) == N_Aggregate
6644 && Is_Others_Aggregate (gnat_inner))
6645 gnat_inner
6646 = Expression (First (Component_Associations (gnat_inner)));
6647 gnu_rhs = gnat_to_gnu (gnat_inner);
6649 else
6650 gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr));
6652 /* If range check is needed, emit code to generate it. */
6653 if (Do_Range_Check (gnat_expr))
6654 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
6655 gnat_node);
6657 /* If an outer atomic access is required on the LHS, build the load-
6658 modify-store sequence. */
6659 if (outer_atomic_access_required_p (Name (gnat_node)))
6660 gnu_result = build_load_modify_store (gnu_lhs, gnu_rhs, gnat_node);
6662 /* Or else, if atomic access is required, build the atomic store. */
6663 else if (atomic_access_required_p (Name (gnat_node), &sync))
6664 gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, sync);
6666 /* Or else, use memset when the conditions are met. */
6667 else if (use_memset_p)
6669 tree value = fold_convert (integer_type_node, gnu_rhs);
6670 tree to = gnu_lhs;
6671 tree type = TREE_TYPE (to);
6672 tree size
6673 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), to);
6674 tree to_ptr = build_fold_addr_expr (to);
6675 tree t = builtin_decl_explicit (BUILT_IN_MEMSET);
6676 if (TREE_CODE (value) == INTEGER_CST)
6678 tree mask
6679 = build_int_cst (integer_type_node,
6680 ((HOST_WIDE_INT) 1 << BITS_PER_UNIT) - 1);
6681 value = int_const_binop (BIT_AND_EXPR, value, mask);
6683 gnu_result = build_call_expr (t, 3, to_ptr, value, size);
6686 /* Otherwise build a regular assignment. */
6687 else
6688 gnu_result
6689 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
6691 /* If the assignment type is a regular array and the two sides are
6692 not completely disjoint, play safe and use memmove. But don't do
6693 it for a bit-packed array as it might not be byte-aligned. */
6694 if (TREE_CODE (gnu_result) == MODIFY_EXPR
6695 && regular_array_type_p
6696 && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
6698 tree to = TREE_OPERAND (gnu_result, 0);
6699 tree from = TREE_OPERAND (gnu_result, 1);
6700 tree type = TREE_TYPE (from);
6701 tree size
6702 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), from);
6703 tree to_ptr = build_fold_addr_expr (to);
6704 tree from_ptr = build_fold_addr_expr (from);
6705 tree t = builtin_decl_explicit (BUILT_IN_MEMMOVE);
6706 gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
6709 break;
6711 case N_If_Statement:
6713 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
6715 /* Make the outer COND_EXPR. Avoid non-determinism. */
6716 gnu_result = build3 (COND_EXPR, void_type_node,
6717 gnat_to_gnu (Condition (gnat_node)),
6718 NULL_TREE, NULL_TREE);
6719 COND_EXPR_THEN (gnu_result)
6720 = build_stmt_group (Then_Statements (gnat_node), false);
6721 TREE_SIDE_EFFECTS (gnu_result) = 1;
6722 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
6724 /* Now make a COND_EXPR for each of the "else if" parts. Put each
6725 into the previous "else" part and point to where to put any
6726 outer "else". Also avoid non-determinism. */
6727 if (Present (Elsif_Parts (gnat_node)))
6728 for (gnat_temp = First (Elsif_Parts (gnat_node));
6729 Present (gnat_temp); gnat_temp = Next (gnat_temp))
6731 gnu_expr = build3 (COND_EXPR, void_type_node,
6732 gnat_to_gnu (Condition (gnat_temp)),
6733 NULL_TREE, NULL_TREE);
6734 COND_EXPR_THEN (gnu_expr)
6735 = build_stmt_group (Then_Statements (gnat_temp), false);
6736 TREE_SIDE_EFFECTS (gnu_expr) = 1;
6737 set_expr_location_from_node (gnu_expr, gnat_temp);
6738 *gnu_else_ptr = gnu_expr;
6739 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
6742 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
6744 break;
6746 case N_Case_Statement:
6747 gnu_result = Case_Statement_to_gnu (gnat_node);
6748 break;
6750 case N_Loop_Statement:
6751 gnu_result = Loop_Statement_to_gnu (gnat_node);
6752 break;
6754 case N_Block_Statement:
6755 /* The only way to enter the block is to fall through to it. */
6756 if (stmt_group_may_fallthru ())
6758 start_stmt_group ();
6759 gnat_pushlevel ();
6760 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
6761 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
6762 gnat_poplevel ();
6763 gnu_result = end_stmt_group ();
6765 else
6766 gnu_result = alloc_stmt_list ();
6767 break;
6769 case N_Exit_Statement:
6770 gnu_result
6771 = build2 (EXIT_STMT, void_type_node,
6772 (Present (Condition (gnat_node))
6773 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
6774 (Present (Name (gnat_node))
6775 ? get_gnu_tree (Entity (Name (gnat_node)))
6776 : LOOP_STMT_LABEL (gnu_loop_stack->last ()->stmt)));
6777 break;
6779 case N_Simple_Return_Statement:
6781 tree gnu_ret_obj, gnu_ret_val;
6783 /* If the subprogram is a function, we must return the expression. */
6784 if (Present (Expression (gnat_node)))
6786 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
6788 /* If this function has copy-in/copy-out parameters parameters and
6789 doesn't return by invisible reference, get the real object for
6790 the return. See Subprogram_Body_to_gnu. */
6791 if (TYPE_CI_CO_LIST (gnu_subprog_type)
6792 && !TREE_ADDRESSABLE (gnu_subprog_type))
6793 gnu_ret_obj = gnu_return_var_stack->last ();
6794 else
6795 gnu_ret_obj = DECL_RESULT (current_function_decl);
6797 /* Get the GCC tree for the expression to be returned. */
6798 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
6800 /* Do not remove the padding from GNU_RET_VAL if the inner type is
6801 self-referential since we want to allocate the fixed size. */
6802 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
6803 && type_is_padding_self_referential
6804 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
6805 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
6807 /* If the function returns by direct reference, return a pointer
6808 to the return value. */
6809 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
6810 || By_Ref (gnat_node))
6811 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
6813 /* Otherwise, if it returns an unconstrained array, we have to
6814 allocate a new version of the result and return it. */
6815 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
6817 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
6819 /* And find out whether this is a candidate for Named Return
6820 Value. If so, record it. */
6821 if (!TYPE_CI_CO_LIST (gnu_subprog_type) && optimize)
6823 tree ret_val = gnu_ret_val;
6825 /* Strip useless conversions around the return value. */
6826 if (gnat_useless_type_conversion (ret_val))
6827 ret_val = TREE_OPERAND (ret_val, 0);
6829 /* Strip unpadding around the return value. */
6830 if (TREE_CODE (ret_val) == COMPONENT_REF
6831 && TYPE_IS_PADDING_P
6832 (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
6833 ret_val = TREE_OPERAND (ret_val, 0);
6835 /* Now apply the test to the return value. */
6836 if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
6838 if (!f_named_ret_val)
6839 f_named_ret_val = BITMAP_GGC_ALLOC ();
6840 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
6841 if (!f_gnat_ret)
6842 f_gnat_ret = gnat_node;
6846 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
6847 gnu_ret_val,
6848 TREE_TYPE (gnu_ret_obj),
6849 Procedure_To_Call (gnat_node),
6850 Storage_Pool (gnat_node),
6851 gnat_node, false);
6854 /* Otherwise, if it returns by invisible reference, dereference
6855 the pointer it is passed using the type of the return value
6856 and build the copy operation manually. This ensures that we
6857 don't copy too much data, for example if the return type is
6858 unconstrained with a maximum size. */
6859 else if (TREE_ADDRESSABLE (gnu_subprog_type))
6861 tree gnu_ret_deref
6862 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
6863 gnu_ret_obj);
6864 gnu_result = build2 (INIT_EXPR, void_type_node,
6865 gnu_ret_deref, gnu_ret_val);
6866 add_stmt_with_node (gnu_result, gnat_node);
6867 gnu_ret_val = NULL_TREE;
6871 else
6872 gnu_ret_obj = gnu_ret_val = NULL_TREE;
6874 /* If we have a return label defined, convert this into a branch to
6875 that label. The return proper will be handled elsewhere. */
6876 if (gnu_return_label_stack->last ())
6878 if (gnu_ret_val)
6879 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
6880 gnu_ret_val));
6882 gnu_result = build1 (GOTO_EXPR, void_type_node,
6883 gnu_return_label_stack->last ());
6885 /* When not optimizing, make sure the return is preserved. */
6886 if (!optimize && Comes_From_Source (gnat_node))
6887 DECL_ARTIFICIAL (gnu_return_label_stack->last ()) = 0;
6890 /* Otherwise, build a regular return. */
6891 else
6892 gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
6894 break;
6896 case N_Goto_Statement:
6897 gnu_result
6898 = build1 (GOTO_EXPR, void_type_node, gnat_to_gnu (Name (gnat_node)));
6899 break;
6901 /***************************/
6902 /* Chapter 6: Subprograms */
6903 /***************************/
6905 case N_Subprogram_Declaration:
6906 /* Unless there is a freeze node, declare the subprogram. We consider
6907 this a "definition" even though we're not generating code for
6908 the subprogram because we will be making the corresponding GCC
6909 node here. */
6911 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
6912 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
6913 NULL_TREE, 1);
6914 gnu_result = alloc_stmt_list ();
6915 break;
6917 case N_Abstract_Subprogram_Declaration:
6918 /* This subprogram doesn't exist for code generation purposes, but we
6919 have to elaborate the types of any parameters and result, unless
6920 they are imported types (nothing to generate in this case).
6922 The parameter list may contain types with freeze nodes, e.g. not null
6923 subtypes, so the subprogram itself may carry a freeze node, in which
6924 case its elaboration must be deferred. */
6926 /* Process the parameter types first. */
6927 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
6928 for (gnat_temp
6929 = First_Formal_With_Extras
6930 (Defining_Entity (Specification (gnat_node)));
6931 Present (gnat_temp);
6932 gnat_temp = Next_Formal_With_Extras (gnat_temp))
6933 if (Is_Itype (Etype (gnat_temp))
6934 && !From_Limited_With (Etype (gnat_temp)))
6935 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
6937 /* Then the result type, set to Standard_Void_Type for procedures. */
6939 Entity_Id gnat_temp_type
6940 = Etype (Defining_Entity (Specification (gnat_node)));
6942 if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type))
6943 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
6946 gnu_result = alloc_stmt_list ();
6947 break;
6949 case N_Defining_Program_Unit_Name:
6950 /* For a child unit identifier go up a level to get the specification.
6951 We get this when we try to find the spec of a child unit package
6952 that is the compilation unit being compiled. */
6953 gnu_result = gnat_to_gnu (Parent (gnat_node));
6954 break;
6956 case N_Subprogram_Body:
6957 Subprogram_Body_to_gnu (gnat_node);
6958 gnu_result = alloc_stmt_list ();
6959 break;
6961 case N_Function_Call:
6962 case N_Procedure_Call_Statement:
6963 gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE,
6964 false, false, false);
6965 break;
6967 /************************/
6968 /* Chapter 7: Packages */
6969 /************************/
6971 case N_Package_Declaration:
6972 gnu_result = gnat_to_gnu (Specification (gnat_node));
6973 break;
6975 case N_Package_Specification:
6977 start_stmt_group ();
6978 process_decls (Visible_Declarations (gnat_node),
6979 Private_Declarations (gnat_node), Empty, true, true);
6980 gnu_result = end_stmt_group ();
6981 break;
6983 case N_Package_Body:
6985 /* If this is the body of a generic package - do nothing. */
6986 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
6988 gnu_result = alloc_stmt_list ();
6989 break;
6992 start_stmt_group ();
6993 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
6995 if (Present (Handled_Statement_Sequence (gnat_node)))
6996 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
6998 gnu_result = end_stmt_group ();
6999 break;
7001 /********************************/
7002 /* Chapter 8: Visibility Rules */
7003 /********************************/
7005 case N_Use_Package_Clause:
7006 case N_Use_Type_Clause:
7007 /* Nothing to do here - but these may appear in list of declarations. */
7008 gnu_result = alloc_stmt_list ();
7009 break;
7011 /*********************/
7012 /* Chapter 9: Tasks */
7013 /*********************/
7015 case N_Protected_Type_Declaration:
7016 gnu_result = alloc_stmt_list ();
7017 break;
7019 case N_Single_Task_Declaration:
7020 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
7021 gnu_result = alloc_stmt_list ();
7022 break;
7024 /*********************************************************/
7025 /* Chapter 10: Program Structure and Compilation Issues */
7026 /*********************************************************/
7028 case N_Compilation_Unit:
7029 /* This is not called for the main unit on which gigi is invoked. */
7030 Compilation_Unit_to_gnu (gnat_node);
7031 gnu_result = alloc_stmt_list ();
7032 break;
7034 case N_Subprogram_Body_Stub:
7035 case N_Package_Body_Stub:
7036 case N_Protected_Body_Stub:
7037 case N_Task_Body_Stub:
7038 /* Simply process whatever unit is being inserted. */
7039 if (Present (Library_Unit (gnat_node)))
7040 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
7041 else
7043 gcc_assert (type_annotate_only);
7044 gnu_result = alloc_stmt_list ();
7046 break;
7048 case N_Subunit:
7049 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
7050 break;
7052 /***************************/
7053 /* Chapter 11: Exceptions */
7054 /***************************/
7056 case N_Handled_Sequence_Of_Statements:
7057 /* If there is an At_End procedure attached to this node, and the EH
7058 mechanism is SJLJ, we must have at least a corresponding At_End
7059 handler, unless the No_Exception_Handlers restriction is set. */
7060 gcc_assert (type_annotate_only
7061 || Exception_Mechanism != Setjmp_Longjmp
7062 || No (At_End_Proc (gnat_node))
7063 || Present (Exception_Handlers (gnat_node))
7064 || No_Exception_Handlers_Set ());
7066 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
7067 break;
7069 case N_Exception_Handler:
7070 if (Exception_Mechanism == Setjmp_Longjmp)
7071 gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
7072 else if (Exception_Mechanism == Back_End_Exceptions)
7073 gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
7074 else
7075 gcc_unreachable ();
7076 break;
7078 case N_Raise_Statement:
7079 /* Only for reraise in back-end exceptions mode. */
7080 gcc_assert (No (Name (gnat_node))
7081 && Exception_Mechanism == Back_End_Exceptions);
7083 start_stmt_group ();
7084 gnat_pushlevel ();
7086 /* Clear the current exception pointer so that the occurrence won't be
7087 deallocated. */
7088 gnu_expr = create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE,
7089 ptr_type_node, gnu_incoming_exc_ptr,
7090 false, false, false, false, NULL, gnat_node);
7092 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_incoming_exc_ptr,
7093 convert (ptr_type_node, integer_zero_node)));
7094 add_stmt (build_call_n_expr (reraise_zcx_decl, 1, gnu_expr));
7095 gnat_poplevel ();
7096 gnu_result = end_stmt_group ();
7097 break;
7099 case N_Push_Constraint_Error_Label:
7100 push_exception_label_stack (&gnu_constraint_error_label_stack,
7101 Exception_Label (gnat_node));
7102 break;
7104 case N_Push_Storage_Error_Label:
7105 push_exception_label_stack (&gnu_storage_error_label_stack,
7106 Exception_Label (gnat_node));
7107 break;
7109 case N_Push_Program_Error_Label:
7110 push_exception_label_stack (&gnu_program_error_label_stack,
7111 Exception_Label (gnat_node));
7112 break;
7114 case N_Pop_Constraint_Error_Label:
7115 gnu_constraint_error_label_stack->pop ();
7116 break;
7118 case N_Pop_Storage_Error_Label:
7119 gnu_storage_error_label_stack->pop ();
7120 break;
7122 case N_Pop_Program_Error_Label:
7123 gnu_program_error_label_stack->pop ();
7124 break;
7126 /******************************/
7127 /* Chapter 12: Generic Units */
7128 /******************************/
7130 case N_Generic_Function_Renaming_Declaration:
7131 case N_Generic_Package_Renaming_Declaration:
7132 case N_Generic_Procedure_Renaming_Declaration:
7133 case N_Generic_Package_Declaration:
7134 case N_Generic_Subprogram_Declaration:
7135 case N_Package_Instantiation:
7136 case N_Procedure_Instantiation:
7137 case N_Function_Instantiation:
7138 /* These nodes can appear on a declaration list but there is nothing to
7139 to be done with them. */
7140 gnu_result = alloc_stmt_list ();
7141 break;
7143 /**************************************************/
7144 /* Chapter 13: Representation Clauses and */
7145 /* Implementation-Dependent Features */
7146 /**************************************************/
7148 case N_Attribute_Definition_Clause:
7149 gnu_result = alloc_stmt_list ();
7151 /* The only one we need to deal with is 'Address since, for the others,
7152 the front-end puts the information elsewhere. */
7153 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
7154 break;
7156 /* And we only deal with 'Address if the object has a Freeze node. */
7157 gnat_temp = Entity (Name (gnat_node));
7158 if (No (Freeze_Node (gnat_temp)))
7159 break;
7161 /* Get the value to use as the address and save it as the equivalent
7162 for the object. When it is frozen, gnat_to_gnu_entity will do the
7163 right thing. */
7164 save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
7165 break;
7167 case N_Enumeration_Representation_Clause:
7168 case N_Record_Representation_Clause:
7169 case N_At_Clause:
7170 /* We do nothing with these. SEM puts the information elsewhere. */
7171 gnu_result = alloc_stmt_list ();
7172 break;
7174 case N_Code_Statement:
7175 if (!type_annotate_only)
7177 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
7178 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
7179 tree gnu_clobbers = NULL_TREE, tail;
7180 bool allows_mem, allows_reg, fake;
7181 int ninputs, noutputs, i;
7182 const char **oconstraints;
7183 const char *constraint;
7184 char *clobber;
7186 /* First retrieve the 3 operand lists built by the front-end. */
7187 Setup_Asm_Outputs (gnat_node);
7188 while (Present (gnat_temp = Asm_Output_Variable ()))
7190 tree gnu_value = gnat_to_gnu (gnat_temp);
7191 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7192 (Asm_Output_Constraint ()));
7194 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
7195 Next_Asm_Output ();
7198 Setup_Asm_Inputs (gnat_node);
7199 while (Present (gnat_temp = Asm_Input_Value ()))
7201 tree gnu_value = gnat_to_gnu (gnat_temp);
7202 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7203 (Asm_Input_Constraint ()));
7205 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
7206 Next_Asm_Input ();
7209 Clobber_Setup (gnat_node);
7210 while ((clobber = Clobber_Get_Next ()))
7211 gnu_clobbers
7212 = tree_cons (NULL_TREE,
7213 build_string (strlen (clobber) + 1, clobber),
7214 gnu_clobbers);
7216 /* Then perform some standard checking and processing on the
7217 operands. In particular, mark them addressable if needed. */
7218 gnu_outputs = nreverse (gnu_outputs);
7219 noutputs = list_length (gnu_outputs);
7220 gnu_inputs = nreverse (gnu_inputs);
7221 ninputs = list_length (gnu_inputs);
7222 oconstraints = XALLOCAVEC (const char *, noutputs);
7224 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
7226 tree output = TREE_VALUE (tail);
7227 constraint
7228 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7229 oconstraints[i] = constraint;
7231 if (parse_output_constraint (&constraint, i, ninputs, noutputs,
7232 &allows_mem, &allows_reg, &fake))
7234 /* If the operand is going to end up in memory,
7235 mark it addressable. Note that we don't test
7236 allows_mem like in the input case below; this
7237 is modelled on the C front-end. */
7238 if (!allows_reg)
7240 output = remove_conversions (output, false);
7241 if (TREE_CODE (output) == CONST_DECL
7242 && DECL_CONST_CORRESPONDING_VAR (output))
7243 output = DECL_CONST_CORRESPONDING_VAR (output);
7244 if (!gnat_mark_addressable (output))
7245 output = error_mark_node;
7248 else
7249 output = error_mark_node;
7251 TREE_VALUE (tail) = output;
7254 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
7256 tree input = TREE_VALUE (tail);
7257 constraint
7258 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7260 if (parse_input_constraint (&constraint, i, ninputs, noutputs,
7261 0, oconstraints,
7262 &allows_mem, &allows_reg))
7264 /* If the operand is going to end up in memory,
7265 mark it addressable. */
7266 if (!allows_reg && allows_mem)
7268 input = remove_conversions (input, false);
7269 if (TREE_CODE (input) == CONST_DECL
7270 && DECL_CONST_CORRESPONDING_VAR (input))
7271 input = DECL_CONST_CORRESPONDING_VAR (input);
7272 if (!gnat_mark_addressable (input))
7273 input = error_mark_node;
7276 else
7277 input = error_mark_node;
7279 TREE_VALUE (tail) = input;
7282 gnu_result = build5 (ASM_EXPR, void_type_node,
7283 gnu_template, gnu_outputs,
7284 gnu_inputs, gnu_clobbers, NULL_TREE);
7285 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
7287 else
7288 gnu_result = alloc_stmt_list ();
7290 break;
7292 /****************/
7293 /* Added Nodes */
7294 /****************/
7296 case N_Expression_With_Actions:
7297 /* This construct doesn't define a scope so we don't push a binding
7298 level around the statement list, but we wrap it in a SAVE_EXPR to
7299 protect it from unsharing. Elaborate the expression as part of the
7300 same statement group as the actions so that the type declaration
7301 gets inserted there as well. This ensures that the type elaboration
7302 code is issued past the actions computing values on which it might
7303 depend. */
7304 start_stmt_group ();
7305 add_stmt_list (Actions (gnat_node));
7306 gnu_expr = gnat_to_gnu (Expression (gnat_node));
7307 gnu_result = end_stmt_group ();
7309 gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
7310 TREE_SIDE_EFFECTS (gnu_result) = 1;
7312 gnu_result
7313 = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
7314 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7315 break;
7317 case N_Freeze_Entity:
7318 start_stmt_group ();
7319 process_freeze_entity (gnat_node);
7320 process_decls (Actions (gnat_node), Empty, Empty, true, true);
7321 gnu_result = end_stmt_group ();
7322 break;
7324 case N_Freeze_Generic_Entity:
7325 gnu_result = alloc_stmt_list ();
7326 break;
7328 case N_Itype_Reference:
7329 if (!present_gnu_tree (Itype (gnat_node)))
7330 process_type (Itype (gnat_node));
7332 gnu_result = alloc_stmt_list ();
7333 break;
7335 case N_Free_Statement:
7336 if (!type_annotate_only)
7338 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
7339 tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
7340 tree gnu_obj_type, gnu_actual_obj_type;
7342 /* If this is a thin pointer, we must first dereference it to create
7343 a fat pointer, then go back below to a thin pointer. The reason
7344 for this is that we need to have a fat pointer someplace in order
7345 to properly compute the size. */
7346 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
7347 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
7348 build_unary_op (INDIRECT_REF, NULL_TREE,
7349 gnu_ptr));
7351 /* If this is a fat pointer, the object must have been allocated with
7352 the template in front of the array. So pass the template address,
7353 and get the total size; do it by converting to a thin pointer. */
7354 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
7355 gnu_ptr
7356 = convert (build_pointer_type
7357 (TYPE_OBJECT_RECORD_TYPE
7358 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
7359 gnu_ptr);
7361 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
7363 /* If this is a thin pointer, the object must have been allocated with
7364 the template in front of the array. So pass the template address,
7365 and get the total size. */
7366 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
7367 gnu_ptr
7368 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
7369 gnu_ptr,
7370 fold_build1 (NEGATE_EXPR, sizetype,
7371 byte_position
7372 (DECL_CHAIN
7373 TYPE_FIELDS ((gnu_obj_type)))));
7375 /* If we have a special dynamic constrained subtype on the node, use
7376 it to compute the size; otherwise, use the designated subtype. */
7377 if (Present (Actual_Designated_Subtype (gnat_node)))
7379 gnu_actual_obj_type
7380 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
7382 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
7383 gnu_actual_obj_type
7384 = build_unc_object_type_from_ptr (gnu_ptr_type,
7385 gnu_actual_obj_type,
7386 get_identifier ("DEALLOC"),
7387 false);
7389 else
7390 gnu_actual_obj_type = gnu_obj_type;
7392 gnu_result
7393 = build_call_alloc_dealloc (gnu_ptr,
7394 TYPE_SIZE_UNIT (gnu_actual_obj_type),
7395 gnu_obj_type,
7396 Procedure_To_Call (gnat_node),
7397 Storage_Pool (gnat_node),
7398 gnat_node);
7400 break;
7402 case N_Raise_Constraint_Error:
7403 case N_Raise_Program_Error:
7404 case N_Raise_Storage_Error:
7405 if (type_annotate_only)
7406 gnu_result = alloc_stmt_list ();
7407 else
7408 gnu_result = Raise_Error_to_gnu (gnat_node, &gnu_result_type);
7409 break;
7411 case N_Validate_Unchecked_Conversion:
7412 /* The only validation we currently do on an unchecked conversion is
7413 that of aliasing assumptions. */
7414 if (flag_strict_aliasing)
7415 gnat_validate_uc_list.safe_push (gnat_node);
7416 gnu_result = alloc_stmt_list ();
7417 break;
7419 case N_Function_Specification:
7420 case N_Procedure_Specification:
7421 case N_Op_Concat:
7422 case N_Component_Association:
7423 case N_Protected_Body:
7424 case N_Task_Body:
7425 /* These nodes should only be present when annotating types. */
7426 gcc_assert (type_annotate_only);
7427 gnu_result = alloc_stmt_list ();
7428 break;
7430 default:
7431 /* Other nodes are not supposed to reach here. */
7432 gcc_unreachable ();
7435 /* If we pushed the processing of the elaboration routine, pop it back. */
7436 if (went_into_elab_proc)
7437 current_function_decl = NULL_TREE;
7439 /* When not optimizing, turn boolean rvalues B into B != false tests
7440 so that the code just below can put the location information of the
7441 reference to B on the inequality operator for better debug info. */
7442 if (!optimize
7443 && TREE_CODE (gnu_result) != INTEGER_CST
7444 && (kind == N_Identifier
7445 || kind == N_Expanded_Name
7446 || kind == N_Explicit_Dereference
7447 || kind == N_Function_Call
7448 || kind == N_Indexed_Component
7449 || kind == N_Selected_Component)
7450 && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
7451 && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
7452 gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
7453 convert (gnu_result_type, gnu_result),
7454 convert (gnu_result_type,
7455 boolean_false_node));
7457 /* Set the location information on the result. Note that we may have
7458 no result if we tried to build a CALL_EXPR node to a procedure with
7459 no side-effects and optimization is enabled. */
7460 if (gnu_result && EXPR_P (gnu_result))
7461 set_gnu_expr_location_from_node (gnu_result, gnat_node);
7463 /* If we're supposed to return something of void_type, it means we have
7464 something we're elaborating for effect, so just return. */
7465 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
7466 return gnu_result;
7468 /* If the result is a constant that overflowed, raise Constraint_Error. */
7469 if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
7471 post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
7472 gnu_result
7473 = build1 (NULL_EXPR, gnu_result_type,
7474 build_call_raise (CE_Overflow_Check_Failed, gnat_node,
7475 N_Raise_Constraint_Error));
7478 /* If the result has side-effects and is of an unconstrained type, make a
7479 SAVE_EXPR so that we can be sure it will only be referenced once. But
7480 this is useless for a call to a function that returns an unconstrained
7481 type with default discriminant, as we cannot compute the size of the
7482 actual returned object. We must do this before any conversions. */
7483 if (TREE_SIDE_EFFECTS (gnu_result)
7484 && !(TREE_CODE (gnu_result) == CALL_EXPR
7485 && type_is_padding_self_referential (TREE_TYPE (gnu_result)))
7486 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
7487 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
7488 gnu_result = gnat_protect_expr (gnu_result);
7490 /* Now convert the result to the result type, unless we are in one of the
7491 following cases:
7493 1. If this is the LHS of an assignment or an actual parameter of a
7494 call, return the result almost unmodified since the RHS will have
7495 to be converted to our type in that case, unless the result type
7496 has a simpler size. Likewise if there is just a no-op unchecked
7497 conversion in-between. Similarly, don't convert integral types
7498 that are the operands of an unchecked conversion since we need
7499 to ignore those conversions (for 'Valid).
7501 2. If we have a label (which doesn't have any well-defined type), a
7502 field or an error, return the result almost unmodified. Similarly,
7503 if the two types are record types with the same name, don't convert.
7504 This will be the case when we are converting from a packable version
7505 of a type to its original type and we need those conversions to be
7506 NOPs in order for assignments into these types to work properly.
7508 3. If the type is void or if we have no result, return error_mark_node
7509 to show we have no result.
7511 4. If this is a call to a function that returns with variable size and
7512 the call is used as the expression in either an object or a renaming
7513 declaration, return the result unmodified because we want to use the
7514 return slot optimization in this case.
7516 5. Finally, if the type of the result is already correct. */
7518 if (Present (Parent (gnat_node))
7519 && (lhs_or_actual_p (gnat_node)
7520 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
7521 && unchecked_conversion_nop (Parent (gnat_node)))
7522 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
7523 && !AGGREGATE_TYPE_P (gnu_result_type)
7524 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
7525 && !(TYPE_SIZE (gnu_result_type)
7526 && TYPE_SIZE (TREE_TYPE (gnu_result))
7527 && (AGGREGATE_TYPE_P (gnu_result_type)
7528 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
7529 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
7530 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
7531 != INTEGER_CST))
7532 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
7533 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
7534 && (CONTAINS_PLACEHOLDER_P
7535 (TYPE_SIZE (TREE_TYPE (gnu_result))))))
7536 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
7537 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
7539 /* Remove padding only if the inner object is of self-referential
7540 size: in that case it must be an object of unconstrained type
7541 with a default discriminant and we want to avoid copying too
7542 much data. */
7543 if (type_is_padding_self_referential (TREE_TYPE (gnu_result)))
7544 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
7545 gnu_result);
7548 else if (TREE_CODE (gnu_result) == LABEL_DECL
7549 || TREE_CODE (gnu_result) == FIELD_DECL
7550 || TREE_CODE (gnu_result) == ERROR_MARK
7551 || (TYPE_NAME (gnu_result_type)
7552 == TYPE_NAME (TREE_TYPE (gnu_result))
7553 && TREE_CODE (gnu_result_type) == RECORD_TYPE
7554 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
7556 /* Remove any padding. */
7557 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
7558 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
7559 gnu_result);
7562 else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
7563 gnu_result = error_mark_node;
7565 else if (Present (Parent (gnat_node))
7566 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
7567 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration)
7568 && TREE_CODE (gnu_result) == CALL_EXPR
7569 && return_type_with_variable_size_p (TREE_TYPE (gnu_result)))
7572 else if (TREE_TYPE (gnu_result) != gnu_result_type)
7573 gnu_result = convert (gnu_result_type, gnu_result);
7575 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
7576 while ((TREE_CODE (gnu_result) == NOP_EXPR
7577 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
7578 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
7579 gnu_result = TREE_OPERAND (gnu_result, 0);
7581 return gnu_result;
7584 /* Subroutine of above to push the exception label stack. GNU_STACK is
7585 a pointer to the stack to update and GNAT_LABEL, if present, is the
7586 label to push onto the stack. */
7588 static void
7589 push_exception_label_stack (vec<tree, va_gc> **gnu_stack, Entity_Id gnat_label)
7591 tree gnu_label = (Present (gnat_label)
7592 ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
7593 : NULL_TREE);
7595 vec_safe_push (*gnu_stack, gnu_label);
7598 /* Record the current code position in GNAT_NODE. */
7600 static void
7601 record_code_position (Node_Id gnat_node)
7603 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
7605 add_stmt_with_node (stmt_stmt, gnat_node);
7606 save_gnu_tree (gnat_node, stmt_stmt, true);
7609 /* Insert the code for GNAT_NODE at the position saved for that node. */
7611 static void
7612 insert_code_for (Node_Id gnat_node)
7614 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
7615 save_gnu_tree (gnat_node, NULL_TREE, true);
7618 /* Start a new statement group chained to the previous group. */
7620 void
7621 start_stmt_group (void)
7623 struct stmt_group *group = stmt_group_free_list;
7625 /* First see if we can get one from the free list. */
7626 if (group)
7627 stmt_group_free_list = group->previous;
7628 else
7629 group = ggc_alloc<stmt_group> ();
7631 group->previous = current_stmt_group;
7632 group->stmt_list = group->block = group->cleanups = NULL_TREE;
7633 current_stmt_group = group;
7636 /* Add GNU_STMT to the current statement group. If it is an expression with
7637 no effects, it is ignored. */
7639 void
7640 add_stmt (tree gnu_stmt)
7642 append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
7645 /* Similar, but the statement is always added, regardless of side-effects. */
7647 void
7648 add_stmt_force (tree gnu_stmt)
7650 append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
7653 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
7655 void
7656 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
7658 /* Do not emit a location for renamings that come from generic instantiation,
7659 they are likely to disturb debugging. */
7660 if (Present (gnat_node)
7661 && !renaming_from_generic_instantiation_p (gnat_node))
7662 set_expr_location_from_node (gnu_stmt, gnat_node);
7663 add_stmt (gnu_stmt);
7666 /* Similar, but the statement is always added, regardless of side-effects. */
7668 void
7669 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
7671 if (Present (gnat_node))
7672 set_expr_location_from_node (gnu_stmt, gnat_node);
7673 add_stmt_force (gnu_stmt);
7676 /* Add a declaration statement for GNU_DECL to the current statement group.
7677 Get SLOC from Entity_Id. */
7679 void
7680 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
7682 tree type = TREE_TYPE (gnu_decl);
7683 tree gnu_stmt, gnu_init, t;
7685 /* If this is a variable that Gigi is to ignore, we may have been given
7686 an ERROR_MARK. So test for it. We also might have been given a
7687 reference for a renaming. So only do something for a decl. Also
7688 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
7689 if (!DECL_P (gnu_decl)
7690 || (TREE_CODE (gnu_decl) == TYPE_DECL
7691 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
7692 return;
7694 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
7696 /* If we are external or global, we don't want to output the DECL_EXPR for
7697 this DECL node since we already have evaluated the expressions in the
7698 sizes and positions as globals and doing it again would be wrong. */
7699 if (DECL_EXTERNAL (gnu_decl) || global_bindings_p ())
7701 /* Mark everything as used to prevent node sharing with subprograms.
7702 Note that walk_tree knows how to deal with TYPE_DECL, but neither
7703 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
7704 MARK_VISITED (gnu_stmt);
7705 if (TREE_CODE (gnu_decl) == VAR_DECL
7706 || TREE_CODE (gnu_decl) == CONST_DECL)
7708 MARK_VISITED (DECL_SIZE (gnu_decl));
7709 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
7710 MARK_VISITED (DECL_INITIAL (gnu_decl));
7712 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
7713 else if (TREE_CODE (gnu_decl) == TYPE_DECL
7714 && RECORD_OR_UNION_TYPE_P (type)
7715 && !TYPE_FAT_POINTER_P (type))
7716 MARK_VISITED (TYPE_ADA_SIZE (type));
7718 else
7719 add_stmt_with_node (gnu_stmt, gnat_entity);
7721 /* If this is a variable and an initializer is attached to it, it must be
7722 valid for the context. Similar to init_const in create_var_decl_1. */
7723 if (TREE_CODE (gnu_decl) == VAR_DECL
7724 && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
7725 && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
7726 || (TREE_STATIC (gnu_decl)
7727 && !initializer_constant_valid_p (gnu_init,
7728 TREE_TYPE (gnu_init)))))
7730 /* If GNU_DECL has a padded type, convert it to the unpadded
7731 type so the assignment is done properly. */
7732 if (TYPE_IS_PADDING_P (type))
7733 t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
7734 else
7735 t = gnu_decl;
7737 gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
7739 DECL_INITIAL (gnu_decl) = NULL_TREE;
7740 if (TREE_READONLY (gnu_decl))
7742 TREE_READONLY (gnu_decl) = 0;
7743 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
7746 add_stmt_with_node (gnu_stmt, gnat_entity);
7750 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
7752 static tree
7753 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
7755 tree t = *tp;
7757 if (TREE_VISITED (t))
7758 *walk_subtrees = 0;
7760 /* Don't mark a dummy type as visited because we want to mark its sizes
7761 and fields once it's filled in. */
7762 else if (!TYPE_IS_DUMMY_P (t))
7763 TREE_VISITED (t) = 1;
7765 if (TYPE_P (t))
7766 TYPE_SIZES_GIMPLIFIED (t) = 1;
7768 return NULL_TREE;
7771 /* Mark nodes rooted at T with TREE_VISITED and types as having their
7772 sized gimplified. We use this to indicate all variable sizes and
7773 positions in global types may not be shared by any subprogram. */
7775 void
7776 mark_visited (tree t)
7778 walk_tree (&t, mark_visited_r, NULL, NULL);
7781 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
7782 set its location to that of GNAT_NODE if present, but with column info
7783 cleared so that conditional branches generated as part of the cleanup
7784 code do not interfere with coverage analysis tools. */
7786 static void
7787 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
7789 if (Present (gnat_node))
7790 set_expr_location_from_node1 (gnu_cleanup, gnat_node, true);
7791 append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
7794 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
7796 void
7797 set_block_for_group (tree gnu_block)
7799 gcc_assert (!current_stmt_group->block);
7800 current_stmt_group->block = gnu_block;
7803 /* Return code corresponding to the current code group. It is normally
7804 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
7805 BLOCK or cleanups were set. */
7807 tree
7808 end_stmt_group (void)
7810 struct stmt_group *group = current_stmt_group;
7811 tree gnu_retval = group->stmt_list;
7813 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
7814 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
7815 make a BIND_EXPR. Note that we nest in that because the cleanup may
7816 reference variables in the block. */
7817 if (gnu_retval == NULL_TREE)
7818 gnu_retval = alloc_stmt_list ();
7820 if (group->cleanups)
7821 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
7822 group->cleanups);
7824 if (current_stmt_group->block)
7825 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
7826 gnu_retval, group->block);
7828 /* Remove this group from the stack and add it to the free list. */
7829 current_stmt_group = group->previous;
7830 group->previous = stmt_group_free_list;
7831 stmt_group_free_list = group;
7833 return gnu_retval;
7836 /* Return whether the current statement group may fall through. */
7838 static inline bool
7839 stmt_group_may_fallthru (void)
7841 if (current_stmt_group->stmt_list)
7842 return block_may_fallthru (current_stmt_group->stmt_list);
7843 else
7844 return true;
7847 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
7848 statements.*/
7850 static void
7851 add_stmt_list (List_Id gnat_list)
7853 Node_Id gnat_node;
7855 if (Present (gnat_list))
7856 for (gnat_node = First (gnat_list); Present (gnat_node);
7857 gnat_node = Next (gnat_node))
7858 add_stmt (gnat_to_gnu (gnat_node));
7861 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
7862 If BINDING_P is true, push and pop a binding level around the list. */
7864 static tree
7865 build_stmt_group (List_Id gnat_list, bool binding_p)
7867 start_stmt_group ();
7868 if (binding_p)
7869 gnat_pushlevel ();
7871 add_stmt_list (gnat_list);
7872 if (binding_p)
7873 gnat_poplevel ();
7875 return end_stmt_group ();
7878 /* Generate GIMPLE in place for the expression at *EXPR_P. */
7881 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
7882 gimple_seq *post_p ATTRIBUTE_UNUSED)
7884 tree expr = *expr_p;
7885 tree type = TREE_TYPE (expr);
7886 tree op;
7888 if (IS_ADA_STMT (expr))
7889 return gnat_gimplify_stmt (expr_p);
7891 switch (TREE_CODE (expr))
7893 case NULL_EXPR:
7894 /* If this is an aggregate type, build a null pointer of the appropriate
7895 type and dereference it. */
7896 if (AGGREGATE_TYPE_P (type)
7897 || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
7898 *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE,
7899 convert (build_pointer_type (type),
7900 integer_zero_node));
7901 /* Otherwise, just make a VAR_DECL. */
7902 else
7904 *expr_p = create_tmp_var (type, NULL);
7905 TREE_NO_WARNING (*expr_p) = 1;
7908 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
7909 return GS_OK;
7911 case UNCONSTRAINED_ARRAY_REF:
7912 /* We should only do this if we are just elaborating for side-effects,
7913 but we can't know that yet. */
7914 *expr_p = TREE_OPERAND (*expr_p, 0);
7915 return GS_OK;
7917 case ADDR_EXPR:
7918 op = TREE_OPERAND (expr, 0);
7920 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
7921 is put into static memory. We know that it's going to be read-only
7922 given the semantics we have and it must be in static memory when the
7923 reference is in an elaboration procedure. */
7924 if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
7926 tree addr = build_fold_addr_expr (tree_output_constant_def (op));
7927 *expr_p = fold_convert (type, addr);
7928 return GS_ALL_DONE;
7931 /* Replace atomic loads with their first argument. That's necessary
7932 because the gimplifier would create a temporary otherwise. */
7933 if (TREE_SIDE_EFFECTS (op))
7934 while (handled_component_p (op) || CONVERT_EXPR_P (op))
7936 tree inner = TREE_OPERAND (op, 0);
7937 if (TREE_CODE (inner) == CALL_EXPR && call_is_atomic_load (inner))
7939 tree t = CALL_EXPR_ARG (inner, 0);
7940 if (TREE_CODE (t) == NOP_EXPR)
7941 t = TREE_OPERAND (t, 0);
7942 if (TREE_CODE (t) == ADDR_EXPR)
7943 TREE_OPERAND (op, 0) = TREE_OPERAND (t, 0);
7944 else
7945 TREE_OPERAND (op, 0) = build_fold_indirect_ref (t);
7947 else
7948 op = inner;
7951 return GS_UNHANDLED;
7953 case VIEW_CONVERT_EXPR:
7954 op = TREE_OPERAND (expr, 0);
7956 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
7957 type to a scalar one, explicitly create the local temporary. That's
7958 required if the type is passed by reference. */
7959 if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
7960 && AGGREGATE_TYPE_P (TREE_TYPE (op))
7961 && !AGGREGATE_TYPE_P (type))
7963 tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
7964 gimple_add_tmp_var (new_var);
7966 mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
7967 gimplify_and_add (mod, pre_p);
7969 TREE_OPERAND (expr, 0) = new_var;
7970 return GS_OK;
7973 return GS_UNHANDLED;
7975 case DECL_EXPR:
7976 op = DECL_EXPR_DECL (expr);
7978 /* The expressions for the RM bounds must be gimplified to ensure that
7979 they are properly elaborated. See gimplify_decl_expr. */
7980 if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
7981 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
7982 switch (TREE_CODE (TREE_TYPE (op)))
7984 case INTEGER_TYPE:
7985 case ENUMERAL_TYPE:
7986 case BOOLEAN_TYPE:
7987 case REAL_TYPE:
7989 tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
7991 val = TYPE_RM_MIN_VALUE (type);
7992 if (val)
7994 gimplify_one_sizepos (&val, pre_p);
7995 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
7996 SET_TYPE_RM_MIN_VALUE (t, val);
7999 val = TYPE_RM_MAX_VALUE (type);
8000 if (val)
8002 gimplify_one_sizepos (&val, pre_p);
8003 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8004 SET_TYPE_RM_MAX_VALUE (t, val);
8008 break;
8010 default:
8011 break;
8014 /* ... fall through ... */
8016 default:
8017 return GS_UNHANDLED;
8021 /* Generate GIMPLE in place for the statement at *STMT_P. */
8023 static enum gimplify_status
8024 gnat_gimplify_stmt (tree *stmt_p)
8026 tree stmt = *stmt_p;
8028 switch (TREE_CODE (stmt))
8030 case STMT_STMT:
8031 *stmt_p = STMT_STMT_STMT (stmt);
8032 return GS_OK;
8034 case LOOP_STMT:
8036 tree gnu_start_label = create_artificial_label (input_location);
8037 tree gnu_cond = LOOP_STMT_COND (stmt);
8038 tree gnu_update = LOOP_STMT_UPDATE (stmt);
8039 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
8041 /* Build the condition expression from the test, if any. */
8042 if (gnu_cond)
8044 /* Deal with the optimization hints. */
8045 if (LOOP_STMT_IVDEP (stmt))
8046 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8047 build_int_cst (integer_type_node,
8048 annot_expr_ivdep_kind));
8049 if (LOOP_STMT_NO_VECTOR (stmt))
8050 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8051 build_int_cst (integer_type_node,
8052 annot_expr_no_vector_kind));
8053 if (LOOP_STMT_VECTOR (stmt))
8054 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8055 build_int_cst (integer_type_node,
8056 annot_expr_vector_kind));
8058 gnu_cond
8059 = build3 (COND_EXPR, void_type_node, gnu_cond, NULL_TREE,
8060 build1 (GOTO_EXPR, void_type_node, gnu_end_label));
8063 /* Set to emit the statements of the loop. */
8064 *stmt_p = NULL_TREE;
8066 /* We first emit the start label and then a conditional jump to the
8067 end label if there's a top condition, then the update if it's at
8068 the top, then the body of the loop, then a conditional jump to
8069 the end label if there's a bottom condition, then the update if
8070 it's at the bottom, and finally a jump to the start label and the
8071 definition of the end label. */
8072 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
8073 gnu_start_label),
8074 stmt_p);
8076 if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
8077 append_to_statement_list (gnu_cond, stmt_p);
8079 if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
8080 append_to_statement_list (gnu_update, stmt_p);
8082 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
8084 if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
8085 append_to_statement_list (gnu_cond, stmt_p);
8087 if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
8088 append_to_statement_list (gnu_update, stmt_p);
8090 tree t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
8091 SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
8092 append_to_statement_list (t, stmt_p);
8094 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
8095 gnu_end_label),
8096 stmt_p);
8097 return GS_OK;
8100 case EXIT_STMT:
8101 /* Build a statement to jump to the corresponding end label, then
8102 see if it needs to be conditional. */
8103 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
8104 if (EXIT_STMT_COND (stmt))
8105 *stmt_p = build3 (COND_EXPR, void_type_node,
8106 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
8107 return GS_OK;
8109 default:
8110 gcc_unreachable ();
8114 /* Force references to each of the entities in packages withed by GNAT_NODE.
8115 Operate recursively but check that we aren't elaborating something more
8116 than once.
8118 This routine is exclusively called in type_annotate mode, to compute DDA
8119 information for types in withed units, for ASIS use. */
8121 static void
8122 elaborate_all_entities (Node_Id gnat_node)
8124 Entity_Id gnat_with_clause, gnat_entity;
8126 /* Process each unit only once. As we trace the context of all relevant
8127 units transitively, including generic bodies, we may encounter the
8128 same generic unit repeatedly. */
8129 if (!present_gnu_tree (gnat_node))
8130 save_gnu_tree (gnat_node, integer_zero_node, true);
8132 /* Save entities in all context units. A body may have an implicit_with
8133 on its own spec, if the context includes a child unit, so don't save
8134 the spec twice. */
8135 for (gnat_with_clause = First (Context_Items (gnat_node));
8136 Present (gnat_with_clause);
8137 gnat_with_clause = Next (gnat_with_clause))
8138 if (Nkind (gnat_with_clause) == N_With_Clause
8139 && !present_gnu_tree (Library_Unit (gnat_with_clause))
8140 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
8142 elaborate_all_entities (Library_Unit (gnat_with_clause));
8144 if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
8146 for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
8147 Present (gnat_entity);
8148 gnat_entity = Next_Entity (gnat_entity))
8149 if (Is_Public (gnat_entity)
8150 && Convention (gnat_entity) != Convention_Intrinsic
8151 && Ekind (gnat_entity) != E_Package
8152 && Ekind (gnat_entity) != E_Package_Body
8153 && Ekind (gnat_entity) != E_Operator
8154 && !(IN (Ekind (gnat_entity), Type_Kind)
8155 && !Is_Frozen (gnat_entity))
8156 && !(IN (Ekind (gnat_entity), Incomplete_Kind)
8157 && From_Limited_With (gnat_entity)
8158 && In_Extended_Main_Code_Unit
8159 (Non_Limited_View (gnat_entity)))
8160 && !((Ekind (gnat_entity) == E_Procedure
8161 || Ekind (gnat_entity) == E_Function)
8162 && Is_Intrinsic_Subprogram (gnat_entity))
8163 && !IN (Ekind (gnat_entity), Named_Kind)
8164 && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
8165 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
8167 else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
8169 Node_Id gnat_body
8170 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
8172 /* Retrieve compilation unit node of generic body. */
8173 while (Present (gnat_body)
8174 && Nkind (gnat_body) != N_Compilation_Unit)
8175 gnat_body = Parent (gnat_body);
8177 /* If body is available, elaborate its context. */
8178 if (Present (gnat_body))
8179 elaborate_all_entities (gnat_body);
8183 if (Nkind (Unit (gnat_node)) == N_Package_Body)
8184 elaborate_all_entities (Library_Unit (gnat_node));
8187 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
8189 static void
8190 process_freeze_entity (Node_Id gnat_node)
8192 const Entity_Id gnat_entity = Entity (gnat_node);
8193 const Entity_Kind kind = Ekind (gnat_entity);
8194 tree gnu_old, gnu_new;
8196 /* If this is a package, we need to generate code for the package. */
8197 if (kind == E_Package)
8199 insert_code_for
8200 (Parent (Corresponding_Body
8201 (Parent (Declaration_Node (gnat_entity)))));
8202 return;
8205 /* Don't do anything for class-wide types as they are always transformed
8206 into their root type. */
8207 if (kind == E_Class_Wide_Type)
8208 return;
8210 /* Check for an old definition. This freeze node might be for an Itype. */
8211 gnu_old
8212 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
8214 /* If this entity has an address representation clause, GNU_OLD is the
8215 address, so discard it here. */
8216 if (Present (Address_Clause (gnat_entity)))
8217 gnu_old = NULL_TREE;
8219 /* Don't do anything for subprograms that may have been elaborated before
8220 their freeze nodes. This can happen, for example, because of an inner
8221 call in an instance body or because of previous compilation of a spec
8222 for inlining purposes. */
8223 if (gnu_old
8224 && ((TREE_CODE (gnu_old) == FUNCTION_DECL
8225 && (kind == E_Function || kind == E_Procedure))
8226 || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
8227 && kind == E_Subprogram_Type)))
8228 return;
8230 /* If we have a non-dummy type old tree, we have nothing to do, except
8231 aborting if this is the public view of a private type whose full view was
8232 not delayed, as this node was never delayed as it should have been. We
8233 let this happen for concurrent types and their Corresponding_Record_Type,
8234 however, because each might legitimately be elaborated before its own
8235 freeze node, e.g. while processing the other. */
8236 if (gnu_old
8237 && !(TREE_CODE (gnu_old) == TYPE_DECL
8238 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
8240 gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
8241 && Present (Full_View (gnat_entity))
8242 && No (Freeze_Node (Full_View (gnat_entity))))
8243 || Is_Concurrent_Type (gnat_entity)
8244 || (IN (kind, Record_Kind)
8245 && Is_Concurrent_Record_Type (gnat_entity)));
8246 return;
8249 /* Reset the saved tree, if any, and elaborate the object or type for real.
8250 If there is a full view, elaborate it and use the result. And, if this
8251 is the root type of a class-wide type, reuse it for the latter. */
8252 if (gnu_old)
8254 save_gnu_tree (gnat_entity, NULL_TREE, false);
8256 if (IN (kind, Incomplete_Or_Private_Kind)
8257 && Present (Full_View (gnat_entity)))
8259 Entity_Id full_view = Full_View (gnat_entity);
8261 save_gnu_tree (full_view, NULL_TREE, false);
8263 if (IN (Ekind (full_view), Private_Kind)
8264 && Present (Underlying_Full_View (full_view)))
8266 full_view = Underlying_Full_View (full_view);
8267 save_gnu_tree (full_view, NULL_TREE, false);
8271 if (IN (kind, Type_Kind)
8272 && Present (Class_Wide_Type (gnat_entity))
8273 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
8274 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
8277 if (IN (kind, Incomplete_Or_Private_Kind)
8278 && Present (Full_View (gnat_entity)))
8280 Entity_Id full_view = Full_View (gnat_entity);
8282 if (IN (Ekind (full_view), Private_Kind)
8283 && Present (Underlying_Full_View (full_view)))
8284 full_view = Underlying_Full_View (full_view);
8286 gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, 1);
8288 /* Propagate back-annotations from full view to partial view. */
8289 if (Unknown_Alignment (gnat_entity))
8290 Set_Alignment (gnat_entity, Alignment (full_view));
8292 if (Unknown_Esize (gnat_entity))
8293 Set_Esize (gnat_entity, Esize (full_view));
8295 if (Unknown_RM_Size (gnat_entity))
8296 Set_RM_Size (gnat_entity, RM_Size (full_view));
8298 /* The above call may have defined this entity (the simplest example
8299 of this is when we have a private enumeral type since the bounds
8300 will have the public view). */
8301 if (!present_gnu_tree (gnat_entity))
8302 save_gnu_tree (gnat_entity, gnu_new, false);
8304 else
8306 tree gnu_init
8307 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
8308 && present_gnu_tree (Declaration_Node (gnat_entity)))
8309 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
8311 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
8314 if (IN (kind, Type_Kind)
8315 && Present (Class_Wide_Type (gnat_entity))
8316 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
8317 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
8319 /* If we have an old type and we've made pointers to this type, update those
8320 pointers. If this is a Taft amendment type in the main unit, we need to
8321 mark the type as used since other units referencing it don't see the full
8322 declaration and, therefore, cannot mark it as used themselves. */
8323 if (gnu_old)
8325 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
8326 TREE_TYPE (gnu_new));
8327 if (DECL_TAFT_TYPE_P (gnu_old))
8328 used_types_insert (TREE_TYPE (gnu_new));
8332 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
8333 We make two passes, one to elaborate anything other than bodies (but
8334 we declare a function if there was no spec). The second pass
8335 elaborates the bodies.
8337 GNAT_END_LIST gives the element in the list past the end. Normally,
8338 this is Empty, but can be First_Real_Statement for a
8339 Handled_Sequence_Of_Statements.
8341 We make a complete pass through both lists if PASS1P is true, then make
8342 the second pass over both lists if PASS2P is true. The lists usually
8343 correspond to the public and private parts of a package. */
8345 static void
8346 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
8347 Node_Id gnat_end_list, bool pass1p, bool pass2p)
8349 List_Id gnat_decl_array[2];
8350 Node_Id gnat_decl;
8351 int i;
8353 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
8355 if (pass1p)
8356 for (i = 0; i <= 1; i++)
8357 if (Present (gnat_decl_array[i]))
8358 for (gnat_decl = First (gnat_decl_array[i]);
8359 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
8361 /* For package specs, we recurse inside the declarations,
8362 thus taking the two pass approach inside the boundary. */
8363 if (Nkind (gnat_decl) == N_Package_Declaration
8364 && (Nkind (Specification (gnat_decl)
8365 == N_Package_Specification)))
8366 process_decls (Visible_Declarations (Specification (gnat_decl)),
8367 Private_Declarations (Specification (gnat_decl)),
8368 Empty, true, false);
8370 /* Similarly for any declarations in the actions of a
8371 freeze node. */
8372 else if (Nkind (gnat_decl) == N_Freeze_Entity)
8374 process_freeze_entity (gnat_decl);
8375 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
8378 /* Package bodies with freeze nodes get their elaboration deferred
8379 until the freeze node, but the code must be placed in the right
8380 place, so record the code position now. */
8381 else if (Nkind (gnat_decl) == N_Package_Body
8382 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
8383 record_code_position (gnat_decl);
8385 else if (Nkind (gnat_decl) == N_Package_Body_Stub
8386 && Present (Library_Unit (gnat_decl))
8387 && Present (Freeze_Node
8388 (Corresponding_Spec
8389 (Proper_Body (Unit
8390 (Library_Unit (gnat_decl)))))))
8391 record_code_position
8392 (Proper_Body (Unit (Library_Unit (gnat_decl))));
8394 /* We defer most subprogram bodies to the second pass. */
8395 else if (Nkind (gnat_decl) == N_Subprogram_Body)
8397 if (Acts_As_Spec (gnat_decl))
8399 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
8401 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
8402 && Ekind (gnat_subprog_id) != E_Generic_Function)
8403 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
8407 /* For bodies and stubs that act as their own specs, the entity
8408 itself must be elaborated in the first pass, because it may
8409 be used in other declarations. */
8410 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
8412 Node_Id gnat_subprog_id
8413 = Defining_Entity (Specification (gnat_decl));
8415 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
8416 && Ekind (gnat_subprog_id) != E_Generic_Procedure
8417 && Ekind (gnat_subprog_id) != E_Generic_Function)
8418 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
8421 /* Concurrent stubs stand for the corresponding subprogram bodies,
8422 which are deferred like other bodies. */
8423 else if (Nkind (gnat_decl) == N_Task_Body_Stub
8424 || Nkind (gnat_decl) == N_Protected_Body_Stub)
8427 else
8428 add_stmt (gnat_to_gnu (gnat_decl));
8431 /* Here we elaborate everything we deferred above except for package bodies,
8432 which are elaborated at their freeze nodes. Note that we must also
8433 go inside things (package specs and freeze nodes) the first pass did. */
8434 if (pass2p)
8435 for (i = 0; i <= 1; i++)
8436 if (Present (gnat_decl_array[i]))
8437 for (gnat_decl = First (gnat_decl_array[i]);
8438 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
8440 if (Nkind (gnat_decl) == N_Subprogram_Body
8441 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
8442 || Nkind (gnat_decl) == N_Task_Body_Stub
8443 || Nkind (gnat_decl) == N_Protected_Body_Stub)
8444 add_stmt (gnat_to_gnu (gnat_decl));
8446 else if (Nkind (gnat_decl) == N_Package_Declaration
8447 && (Nkind (Specification (gnat_decl)
8448 == N_Package_Specification)))
8449 process_decls (Visible_Declarations (Specification (gnat_decl)),
8450 Private_Declarations (Specification (gnat_decl)),
8451 Empty, false, true);
8453 else if (Nkind (gnat_decl) == N_Freeze_Entity)
8454 process_decls (Actions (gnat_decl), Empty, Empty, false, true);
8458 /* Make a unary operation of kind CODE using build_unary_op, but guard
8459 the operation by an overflow check. CODE can be one of NEGATE_EXPR
8460 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
8461 the operation is to be performed in that type. GNAT_NODE is the gnat
8462 node conveying the source location for which the error should be
8463 signaled. */
8465 static tree
8466 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
8467 Node_Id gnat_node)
8469 gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
8471 operand = gnat_protect_expr (operand);
8473 return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
8474 operand, TYPE_MIN_VALUE (gnu_type)),
8475 build_unary_op (code, gnu_type, operand),
8476 CE_Overflow_Check_Failed, gnat_node);
8479 /* Make a binary operation of kind CODE using build_binary_op, but guard
8480 the operation by an overflow check. CODE can be one of PLUS_EXPR,
8481 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
8482 Usually the operation is to be performed in that type. GNAT_NODE is
8483 the GNAT node conveying the source location for which the error should
8484 be signaled. */
8486 static tree
8487 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
8488 tree right, Node_Id gnat_node)
8490 const unsigned int precision = TYPE_PRECISION (gnu_type);
8491 tree lhs = gnat_protect_expr (left);
8492 tree rhs = gnat_protect_expr (right);
8493 tree type_max = TYPE_MAX_VALUE (gnu_type);
8494 tree type_min = TYPE_MIN_VALUE (gnu_type);
8495 tree zero = convert (gnu_type, integer_zero_node);
8496 tree gnu_expr, rhs_lt_zero, tmp1, tmp2;
8497 tree check_pos, check_neg, check;
8499 /* Assert that the precision is a power of 2. */
8500 gcc_assert ((precision & (precision - 1)) == 0);
8502 /* Prefer a constant or known-positive rhs to simplify checks. */
8503 if (!TREE_CONSTANT (rhs)
8504 && commutative_tree_code (code)
8505 && (TREE_CONSTANT (lhs)
8506 || (!tree_expr_nonnegative_p (rhs)
8507 && tree_expr_nonnegative_p (lhs))))
8509 tree tmp = lhs;
8510 lhs = rhs;
8511 rhs = tmp;
8514 gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
8516 /* If we can fold the expression to a constant, just return it.
8517 The caller will deal with overflow, no need to generate a check. */
8518 if (TREE_CONSTANT (gnu_expr))
8519 return gnu_expr;
8521 rhs_lt_zero = tree_expr_nonnegative_p (rhs)
8522 ? boolean_false_node
8523 : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
8525 /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
8527 /* Try a few strategies that may be cheaper than the general
8528 code at the end of the function, if the rhs is not known.
8529 The strategies are:
8530 - Call library function for 64-bit multiplication (complex)
8531 - Widen, if input arguments are sufficiently small
8532 - Determine overflow using wrapped result for addition/subtraction. */
8534 if (!TREE_CONSTANT (rhs))
8536 /* Even for add/subtract double size to get another base type. */
8537 const unsigned int needed_precision = precision * 2;
8539 if (code == MULT_EXPR && precision == 64)
8541 tree int_64 = gnat_type_for_size (64, 0);
8543 return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
8544 convert (int_64, lhs),
8545 convert (int_64, rhs)));
8548 if (needed_precision <= BITS_PER_WORD
8549 || (code == MULT_EXPR && needed_precision <= LONG_LONG_TYPE_SIZE))
8551 tree wide_type = gnat_type_for_size (needed_precision, 0);
8552 tree wide_result = build_binary_op (code, wide_type,
8553 convert (wide_type, lhs),
8554 convert (wide_type, rhs));
8556 check = build_binary_op
8557 (TRUTH_ORIF_EXPR, boolean_type_node,
8558 build_binary_op (LT_EXPR, boolean_type_node, wide_result,
8559 convert (wide_type, type_min)),
8560 build_binary_op (GT_EXPR, boolean_type_node, wide_result,
8561 convert (wide_type, type_max)));
8563 return
8564 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
8567 if (code == PLUS_EXPR || code == MINUS_EXPR)
8569 tree unsigned_type = gnat_type_for_size (precision, 1);
8570 tree wrapped_expr
8571 = convert (gnu_type,
8572 build_binary_op (code, unsigned_type,
8573 convert (unsigned_type, lhs),
8574 convert (unsigned_type, rhs)));
8576 /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
8577 or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */
8578 check
8579 = build_binary_op (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
8580 build_binary_op (code == PLUS_EXPR
8581 ? LT_EXPR : GT_EXPR,
8582 boolean_type_node,
8583 wrapped_expr, lhs));
8585 return
8586 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
8590 switch (code)
8592 case PLUS_EXPR:
8593 /* When rhs >= 0, overflow when lhs > type_max - rhs. */
8594 check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
8595 build_binary_op (MINUS_EXPR, gnu_type,
8596 type_max, rhs)),
8598 /* When rhs < 0, overflow when lhs < type_min - rhs. */
8599 check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
8600 build_binary_op (MINUS_EXPR, gnu_type,
8601 type_min, rhs));
8602 break;
8604 case MINUS_EXPR:
8605 /* When rhs >= 0, overflow when lhs < type_min + rhs. */
8606 check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
8607 build_binary_op (PLUS_EXPR, gnu_type,
8608 type_min, rhs)),
8610 /* When rhs < 0, overflow when lhs > type_max + rhs. */
8611 check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
8612 build_binary_op (PLUS_EXPR, gnu_type,
8613 type_max, rhs));
8614 break;
8616 case MULT_EXPR:
8617 /* The check here is designed to be efficient if the rhs is constant,
8618 but it will work for any rhs by using integer division.
8619 Four different check expressions determine whether X * C overflows,
8620 depending on C.
8621 C == 0 => false
8622 C > 0 => X > type_max / C || X < type_min / C
8623 C == -1 => X == type_min
8624 C < -1 => X > type_min / C || X < type_max / C */
8626 tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
8627 tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
8629 check_pos
8630 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
8631 build_binary_op (NE_EXPR, boolean_type_node, zero,
8632 rhs),
8633 build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8634 build_binary_op (GT_EXPR,
8635 boolean_type_node,
8636 lhs, tmp1),
8637 build_binary_op (LT_EXPR,
8638 boolean_type_node,
8639 lhs, tmp2)));
8641 check_neg
8642 = fold_build3 (COND_EXPR, boolean_type_node,
8643 build_binary_op (EQ_EXPR, boolean_type_node, rhs,
8644 build_int_cst (gnu_type, -1)),
8645 build_binary_op (EQ_EXPR, boolean_type_node, lhs,
8646 type_min),
8647 build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8648 build_binary_op (GT_EXPR,
8649 boolean_type_node,
8650 lhs, tmp2),
8651 build_binary_op (LT_EXPR,
8652 boolean_type_node,
8653 lhs, tmp1)));
8654 break;
8656 default:
8657 gcc_unreachable();
8660 check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
8661 check_pos);
8663 return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
8666 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
8667 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
8668 which we have to check. GNAT_NODE is the GNAT node conveying the source
8669 location for which the error should be signaled. */
8671 static tree
8672 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
8674 tree gnu_range_type = get_unpadded_type (gnat_range_type);
8675 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
8677 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
8678 This can for example happen when translating 'Val or 'Value. */
8679 if (gnu_compare_type == gnu_range_type)
8680 return gnu_expr;
8682 /* Range checks can only be applied to types with ranges. */
8683 gcc_assert (INTEGRAL_TYPE_P (gnu_range_type)
8684 || SCALAR_FLOAT_TYPE_P (gnu_range_type));
8686 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
8687 we can't do anything since we might be truncating the bounds. No
8688 check is needed in this case. */
8689 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
8690 && (TYPE_PRECISION (gnu_compare_type)
8691 < TYPE_PRECISION (get_base_type (gnu_range_type))))
8692 return gnu_expr;
8694 /* Checked expressions must be evaluated only once. */
8695 gnu_expr = gnat_protect_expr (gnu_expr);
8697 /* Note that the form of the check is
8698 (not (expr >= lo)) or (not (expr <= hi))
8699 the reason for this slightly convoluted form is that NaNs
8700 are not considered to be in range in the float case. */
8701 return emit_check
8702 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8703 invert_truthvalue
8704 (build_binary_op (GE_EXPR, boolean_type_node,
8705 convert (gnu_compare_type, gnu_expr),
8706 convert (gnu_compare_type,
8707 TYPE_MIN_VALUE
8708 (gnu_range_type)))),
8709 invert_truthvalue
8710 (build_binary_op (LE_EXPR, boolean_type_node,
8711 convert (gnu_compare_type, gnu_expr),
8712 convert (gnu_compare_type,
8713 TYPE_MAX_VALUE
8714 (gnu_range_type))))),
8715 gnu_expr, CE_Range_Check_Failed, gnat_node);
8718 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which
8719 we are about to index, GNU_EXPR is the index expression to be checked,
8720 GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
8721 has to be checked. Note that for index checking we cannot simply use the
8722 emit_range_check function (although very similar code needs to be generated
8723 in both cases) since for index checking the array type against which we are
8724 checking the indices may be unconstrained and consequently we need to get
8725 the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
8726 The place where we need to do that is in subprograms having unconstrained
8727 array formal parameters. GNAT_NODE is the GNAT node conveying the source
8728 location for which the error should be signaled. */
8730 static tree
8731 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
8732 tree gnu_high, Node_Id gnat_node)
8734 tree gnu_expr_check;
8736 /* Checked expressions must be evaluated only once. */
8737 gnu_expr = gnat_protect_expr (gnu_expr);
8739 /* Must do this computation in the base type in case the expression's
8740 type is an unsigned subtypes. */
8741 gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
8743 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
8744 the object we are handling. */
8745 gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
8746 gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
8748 return emit_check
8749 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8750 build_binary_op (LT_EXPR, boolean_type_node,
8751 gnu_expr_check,
8752 convert (TREE_TYPE (gnu_expr_check),
8753 gnu_low)),
8754 build_binary_op (GT_EXPR, boolean_type_node,
8755 gnu_expr_check,
8756 convert (TREE_TYPE (gnu_expr_check),
8757 gnu_high))),
8758 gnu_expr, CE_Index_Check_Failed, gnat_node);
8761 /* GNU_COND contains the condition corresponding to an access, discriminant or
8762 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
8763 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
8764 REASON is the code that says why the exception was raised. GNAT_NODE is
8765 the GNAT node conveying the source location for which the error should be
8766 signaled. */
8768 static tree
8769 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
8771 tree gnu_call
8772 = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
8773 tree gnu_result
8774 = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
8775 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
8776 convert (TREE_TYPE (gnu_expr), integer_zero_node)),
8777 gnu_expr);
8779 /* GNU_RESULT has side effects if and only if GNU_EXPR has:
8780 we don't need to evaluate it just for the check. */
8781 TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr);
8783 return gnu_result;
8786 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
8787 checks if OVERFLOW_P is true and range checks if RANGE_P is true.
8788 GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
8789 float to integer conversion with truncation; otherwise round.
8790 GNAT_NODE is the GNAT node conveying the source location for which the
8791 error should be signaled. */
8793 static tree
8794 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
8795 bool rangep, bool truncatep, Node_Id gnat_node)
8797 tree gnu_type = get_unpadded_type (gnat_type);
8798 tree gnu_in_type = TREE_TYPE (gnu_expr);
8799 tree gnu_in_basetype = get_base_type (gnu_in_type);
8800 tree gnu_base_type = get_base_type (gnu_type);
8801 tree gnu_result = gnu_expr;
8803 /* If we are not doing any checks, the output is an integral type and the
8804 input is not a floating-point type, just do the conversion. This is
8805 required for packed array types and is simpler in all cases anyway. */
8806 if (!rangep
8807 && !overflowp
8808 && INTEGRAL_TYPE_P (gnu_base_type)
8809 && !FLOAT_TYPE_P (gnu_in_type))
8810 return convert (gnu_type, gnu_expr);
8812 /* First convert the expression to its base type. This
8813 will never generate code, but makes the tests below much simpler.
8814 But don't do this if converting from an integer type to an unconstrained
8815 array type since then we need to get the bounds from the original
8816 (unpacked) type. */
8817 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
8818 gnu_result = convert (gnu_in_basetype, gnu_result);
8820 /* If overflow checks are requested, we need to be sure the result will
8821 fit in the output base type. But don't do this if the input
8822 is integer and the output floating-point. */
8823 if (overflowp
8824 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
8826 /* Ensure GNU_EXPR only gets evaluated once. */
8827 tree gnu_input = gnat_protect_expr (gnu_result);
8828 tree gnu_cond = boolean_false_node;
8829 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
8830 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
8831 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
8832 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
8834 /* Convert the lower bounds to signed types, so we're sure we're
8835 comparing them properly. Likewise, convert the upper bounds
8836 to unsigned types. */
8837 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
8838 gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
8840 if (INTEGRAL_TYPE_P (gnu_in_basetype)
8841 && !TYPE_UNSIGNED (gnu_in_basetype))
8842 gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
8844 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
8845 gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
8847 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
8848 gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
8850 /* Check each bound separately and only if the result bound
8851 is tighter than the bound on the input type. Note that all the
8852 types are base types, so the bounds must be constant. Also,
8853 the comparison is done in the base type of the input, which
8854 always has the proper signedness. First check for input
8855 integer (which means output integer), output float (which means
8856 both float), or mixed, in which case we always compare.
8857 Note that we have to do the comparison which would *fail* in the
8858 case of an error since if it's an FP comparison and one of the
8859 values is a NaN or Inf, the comparison will fail. */
8860 if (INTEGRAL_TYPE_P (gnu_in_basetype)
8861 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
8862 : (FLOAT_TYPE_P (gnu_base_type)
8863 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
8864 TREE_REAL_CST (gnu_out_lb))
8865 : 1))
8866 gnu_cond
8867 = invert_truthvalue
8868 (build_binary_op (GE_EXPR, boolean_type_node,
8869 gnu_input, convert (gnu_in_basetype,
8870 gnu_out_lb)));
8872 if (INTEGRAL_TYPE_P (gnu_in_basetype)
8873 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
8874 : (FLOAT_TYPE_P (gnu_base_type)
8875 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
8876 TREE_REAL_CST (gnu_in_lb))
8877 : 1))
8878 gnu_cond
8879 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
8880 invert_truthvalue
8881 (build_binary_op (LE_EXPR, boolean_type_node,
8882 gnu_input,
8883 convert (gnu_in_basetype,
8884 gnu_out_ub))));
8886 if (!integer_zerop (gnu_cond))
8887 gnu_result = emit_check (gnu_cond, gnu_input,
8888 CE_Overflow_Check_Failed, gnat_node);
8891 /* Now convert to the result base type. If this is a non-truncating
8892 float-to-integer conversion, round. */
8893 if (INTEGRAL_TYPE_P (gnu_base_type)
8894 && FLOAT_TYPE_P (gnu_in_basetype)
8895 && !truncatep)
8897 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
8898 tree gnu_conv, gnu_zero, gnu_comp, calc_type;
8899 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
8900 const struct real_format *fmt;
8902 /* The following calculations depend on proper rounding to even
8903 of each arithmetic operation. In order to prevent excess
8904 precision from spoiling this property, use the widest hardware
8905 floating-point type if FP_ARITH_MAY_WIDEN is true. */
8906 calc_type
8907 = fp_arith_may_widen ? longest_float_type_node : gnu_in_basetype;
8909 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
8910 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
8911 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
8912 REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
8913 half_minus_pred_half);
8914 gnu_pred_half = build_real (calc_type, pred_half);
8916 /* If the input is strictly negative, subtract this value
8917 and otherwise add it from the input. For 0.5, the result
8918 is exactly between 1.0 and the machine number preceding 1.0
8919 (for calc_type). Since the last bit of 1.0 is even, this 0.5
8920 will round to 1.0, while all other number with an absolute
8921 value less than 0.5 round to 0.0. For larger numbers exactly
8922 halfway between integers, rounding will always be correct as
8923 the true mathematical result will be closer to the higher
8924 integer compared to the lower one. So, this constant works
8925 for all floating-point numbers.
8927 The reason to use the same constant with subtract/add instead
8928 of a positive and negative constant is to allow the comparison
8929 to be scheduled in parallel with retrieval of the constant and
8930 conversion of the input to the calc_type (if necessary). */
8932 gnu_zero = convert (gnu_in_basetype, integer_zero_node);
8933 gnu_result = gnat_protect_expr (gnu_result);
8934 gnu_conv = convert (calc_type, gnu_result);
8935 gnu_comp
8936 = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
8937 gnu_add_pred_half
8938 = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
8939 gnu_subtract_pred_half
8940 = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
8941 gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
8942 gnu_add_pred_half, gnu_subtract_pred_half);
8945 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
8946 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
8947 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
8948 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
8949 else
8950 gnu_result = convert (gnu_base_type, gnu_result);
8952 /* Finally, do the range check if requested. Note that if the result type
8953 is a modular type, the range check is actually an overflow check. */
8954 if (rangep
8955 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
8956 && TYPE_MODULAR_P (gnu_base_type) && overflowp))
8957 gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
8959 return convert (gnu_type, gnu_result);
8962 /* Return true if GNU_EXPR can be directly addressed. This is the case
8963 unless it is an expression involving computation or if it involves a
8964 reference to a bitfield or to an object not sufficiently aligned for
8965 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
8966 be directly addressed as an object of this type.
8968 *** Notes on addressability issues in the Ada compiler ***
8970 This predicate is necessary in order to bridge the gap between Gigi
8971 and the middle-end about addressability of GENERIC trees. A tree
8972 is said to be addressable if it can be directly addressed, i.e. if
8973 its address can be taken, is a multiple of the type's alignment on
8974 strict-alignment architectures and returns the first storage unit
8975 assigned to the object represented by the tree.
8977 In the C family of languages, everything is in practice addressable
8978 at the language level, except for bit-fields. This means that these
8979 compilers will take the address of any tree that doesn't represent
8980 a bit-field reference and expect the result to be the first storage
8981 unit assigned to the object. Even in cases where this will result
8982 in unaligned accesses at run time, nothing is supposed to be done
8983 and the program is considered as erroneous instead (see PR c/18287).
8985 The implicit assumptions made in the middle-end are in keeping with
8986 the C viewpoint described above:
8987 - the address of a bit-field reference is supposed to be never
8988 taken; the compiler (generally) will stop on such a construct,
8989 - any other tree is addressable if it is formally addressable,
8990 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
8992 In Ada, the viewpoint is the opposite one: nothing is addressable
8993 at the language level unless explicitly declared so. This means
8994 that the compiler will both make sure that the trees representing
8995 references to addressable ("aliased" in Ada parlance) objects are
8996 addressable and make no real attempts at ensuring that the trees
8997 representing references to non-addressable objects are addressable.
8999 In the first case, Ada is effectively equivalent to C and handing
9000 down the direct result of applying ADDR_EXPR to these trees to the
9001 middle-end works flawlessly. In the second case, Ada cannot afford
9002 to consider the program as erroneous if the address of trees that
9003 are not addressable is requested for technical reasons, unlike C;
9004 as a consequence, the Ada compiler must arrange for either making
9005 sure that this address is not requested in the middle-end or for
9006 compensating by inserting temporaries if it is requested in Gigi.
9008 The first goal can be achieved because the middle-end should not
9009 request the address of non-addressable trees on its own; the only
9010 exception is for the invocation of low-level block operations like
9011 memcpy, for which the addressability requirements are lower since
9012 the type's alignment can be disregarded. In practice, this means
9013 that Gigi must make sure that such operations cannot be applied to
9014 non-BLKmode bit-fields.
9016 The second goal is achieved by means of the addressable_p predicate,
9017 which computes whether a temporary must be inserted by Gigi when the
9018 address of a tree is requested; if so, the address of the temporary
9019 will be used in lieu of that of the original tree and some glue code
9020 generated to connect everything together. */
9022 static bool
9023 addressable_p (tree gnu_expr, tree gnu_type)
9025 /* For an integral type, the size of the actual type of the object may not
9026 be greater than that of the expected type, otherwise an indirect access
9027 in the latter type wouldn't correctly set all the bits of the object. */
9028 if (gnu_type
9029 && INTEGRAL_TYPE_P (gnu_type)
9030 && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
9031 return false;
9033 /* The size of the actual type of the object may not be smaller than that
9034 of the expected type, otherwise an indirect access in the latter type
9035 would be larger than the object. But only record types need to be
9036 considered in practice for this case. */
9037 if (gnu_type
9038 && TREE_CODE (gnu_type) == RECORD_TYPE
9039 && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
9040 return false;
9042 switch (TREE_CODE (gnu_expr))
9044 case VAR_DECL:
9045 case PARM_DECL:
9046 case FUNCTION_DECL:
9047 case RESULT_DECL:
9048 /* All DECLs are addressable: if they are in a register, we can force
9049 them to memory. */
9050 return true;
9052 case UNCONSTRAINED_ARRAY_REF:
9053 case INDIRECT_REF:
9054 /* Taking the address of a dereference yields the original pointer. */
9055 return true;
9057 case STRING_CST:
9058 case INTEGER_CST:
9059 /* Taking the address yields a pointer to the constant pool. */
9060 return true;
9062 case CONSTRUCTOR:
9063 /* Taking the address of a static constructor yields a pointer to the
9064 tree constant pool. */
9065 return TREE_STATIC (gnu_expr) ? true : false;
9067 case NULL_EXPR:
9068 case SAVE_EXPR:
9069 case CALL_EXPR:
9070 case PLUS_EXPR:
9071 case MINUS_EXPR:
9072 case BIT_IOR_EXPR:
9073 case BIT_XOR_EXPR:
9074 case BIT_AND_EXPR:
9075 case BIT_NOT_EXPR:
9076 /* All rvalues are deemed addressable since taking their address will
9077 force a temporary to be created by the middle-end. */
9078 return true;
9080 case COMPOUND_EXPR:
9081 /* The address of a compound expression is that of its 2nd operand. */
9082 return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
9084 case COND_EXPR:
9085 /* We accept &COND_EXPR as soon as both operands are addressable and
9086 expect the outcome to be the address of the selected operand. */
9087 return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
9088 && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
9090 case COMPONENT_REF:
9091 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
9092 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
9093 the field is sufficiently aligned, in case it is subject
9094 to a pragma Component_Alignment. But we don't need to
9095 check the alignment of the containing record, as it is
9096 guaranteed to be not smaller than that of its most
9097 aligned field that is not a bit-field. */
9098 && (!STRICT_ALIGNMENT
9099 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
9100 >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
9101 /* The field of a padding record is always addressable. */
9102 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
9103 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9105 case ARRAY_REF: case ARRAY_RANGE_REF:
9106 case REALPART_EXPR: case IMAGPART_EXPR:
9107 case NOP_EXPR:
9108 return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
9110 case CONVERT_EXPR:
9111 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
9112 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9114 case VIEW_CONVERT_EXPR:
9116 /* This is addressable if we can avoid a copy. */
9117 tree type = TREE_TYPE (gnu_expr);
9118 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
9119 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
9120 && (!STRICT_ALIGNMENT
9121 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
9122 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
9123 || ((TYPE_MODE (type) == BLKmode
9124 || TYPE_MODE (inner_type) == BLKmode)
9125 && (!STRICT_ALIGNMENT
9126 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
9127 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
9128 || TYPE_ALIGN_OK (type)
9129 || TYPE_ALIGN_OK (inner_type))))
9130 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
9133 default:
9134 return false;
9138 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
9139 a separate Freeze node exists, delay the bulk of the processing. Otherwise
9140 make a GCC type for GNAT_ENTITY and set up the correspondence. */
9142 void
9143 process_type (Entity_Id gnat_entity)
9145 tree gnu_old
9146 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
9147 tree gnu_new;
9149 /* If we are to delay elaboration of this type, just do any
9150 elaborations needed for expressions within the declaration and
9151 make a dummy type entry for this node and its Full_View (if
9152 any) in case something points to it. Don't do this if it
9153 has already been done (the only way that can happen is if
9154 the private completion is also delayed). */
9155 if (Present (Freeze_Node (gnat_entity))
9156 || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
9157 && Present (Full_View (gnat_entity))
9158 && Present (Freeze_Node (Full_View (gnat_entity)))
9159 && !present_gnu_tree (Full_View (gnat_entity))))
9161 elaborate_entity (gnat_entity);
9163 if (!gnu_old)
9165 tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
9166 save_gnu_tree (gnat_entity, gnu_decl, false);
9167 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
9168 && Present (Full_View (gnat_entity)))
9170 if (Has_Completion_In_Body (gnat_entity))
9171 DECL_TAFT_TYPE_P (gnu_decl) = 1;
9172 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
9176 return;
9179 /* If we saved away a dummy type for this node it means that this
9180 made the type that corresponds to the full type of an incomplete
9181 type. Clear that type for now and then update the type in the
9182 pointers. */
9183 if (gnu_old)
9185 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
9186 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
9188 save_gnu_tree (gnat_entity, NULL_TREE, false);
9191 /* Now fully elaborate the type. */
9192 gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
9193 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
9195 /* If we have an old type and we've made pointers to this type, update those
9196 pointers. If this is a Taft amendment type in the main unit, we need to
9197 mark the type as used since other units referencing it don't see the full
9198 declaration and, therefore, cannot mark it as used themselves. */
9199 if (gnu_old)
9201 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
9202 TREE_TYPE (gnu_new));
9203 if (DECL_TAFT_TYPE_P (gnu_old))
9204 used_types_insert (TREE_TYPE (gnu_new));
9207 /* If this is a record type corresponding to a task or protected type
9208 that is a completion of an incomplete type, perform a similar update
9209 on the type. ??? Including protected types here is a guess. */
9210 if (IN (Ekind (gnat_entity), Record_Kind)
9211 && Is_Concurrent_Record_Type (gnat_entity)
9212 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
9214 tree gnu_task_old
9215 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
9217 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
9218 NULL_TREE, false);
9219 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
9220 gnu_new, false);
9222 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
9223 TREE_TYPE (gnu_new));
9227 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
9228 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
9229 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
9231 static tree
9232 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
9234 tree gnu_list = NULL_TREE, gnu_result;
9236 /* We test for GNU_FIELD being empty in the case where a variant
9237 was the last thing since we don't take things off GNAT_ASSOC in
9238 that case. We check GNAT_ASSOC in case we have a variant, but it
9239 has no fields. */
9241 for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc))
9243 Node_Id gnat_field = First (Choices (gnat_assoc));
9244 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
9245 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
9247 /* The expander is supposed to put a single component selector name
9248 in every record component association. */
9249 gcc_assert (No (Next (gnat_field)));
9251 /* Ignore fields that have Corresponding_Discriminants since we'll
9252 be setting that field in the parent. */
9253 if (Present (Corresponding_Discriminant (Entity (gnat_field)))
9254 && Is_Tagged_Type (Scope (Entity (gnat_field))))
9255 continue;
9257 /* Also ignore discriminants of Unchecked_Unions. */
9258 if (Is_Unchecked_Union (gnat_entity)
9259 && Ekind (Entity (gnat_field)) == E_Discriminant)
9260 continue;
9262 /* Before assigning a value in an aggregate make sure range checks
9263 are done if required. Then convert to the type of the field. */
9264 if (Do_Range_Check (Expression (gnat_assoc)))
9265 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
9267 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
9269 /* Add the field and expression to the list. */
9270 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
9273 gnu_result = extract_values (gnu_list, gnu_type);
9275 #ifdef ENABLE_CHECKING
9276 /* Verify that every entry in GNU_LIST was used. */
9277 for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list))
9278 gcc_assert (TREE_ADDRESSABLE (gnu_list));
9279 #endif
9281 return gnu_result;
9284 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
9285 the first element of an array aggregate. It may itself be an aggregate.
9286 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
9287 GNAT_COMPONENT_TYPE is the type of the array component; it is needed
9288 for range checking. */
9290 static tree
9291 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
9292 Entity_Id gnat_component_type)
9294 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
9295 tree gnu_expr;
9296 vec<constructor_elt, va_gc> *gnu_expr_vec = NULL;
9298 for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
9300 /* If the expression is itself an array aggregate then first build the
9301 innermost constructor if it is part of our array (multi-dimensional
9302 case). */
9303 if (Nkind (gnat_expr) == N_Aggregate
9304 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
9305 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
9306 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
9307 TREE_TYPE (gnu_array_type),
9308 gnat_component_type);
9309 else
9311 gnu_expr = gnat_to_gnu (gnat_expr);
9313 /* Before assigning the element to the array, make sure it is
9314 in range. */
9315 if (Do_Range_Check (gnat_expr))
9316 gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
9319 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
9320 convert (TREE_TYPE (gnu_array_type), gnu_expr));
9322 gnu_index = int_const_binop (PLUS_EXPR, gnu_index,
9323 convert (TREE_TYPE (gnu_index),
9324 integer_one_node));
9327 return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
9330 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
9331 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
9332 associations that are from RECORD_TYPE. If we see an internal record, make
9333 a recursive call to fill it in as well. */
9335 static tree
9336 extract_values (tree values, tree record_type)
9338 tree field, tem;
9339 vec<constructor_elt, va_gc> *v = NULL;
9341 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
9343 tree value = 0;
9345 /* _Parent is an internal field, but may have values in the aggregate,
9346 so check for values first. */
9347 if ((tem = purpose_member (field, values)))
9349 value = TREE_VALUE (tem);
9350 TREE_ADDRESSABLE (tem) = 1;
9353 else if (DECL_INTERNAL_P (field))
9355 value = extract_values (values, TREE_TYPE (field));
9356 if (TREE_CODE (value) == CONSTRUCTOR
9357 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value)))
9358 value = 0;
9360 else
9361 /* If we have a record subtype, the names will match, but not the
9362 actual FIELD_DECLs. */
9363 for (tem = values; tem; tem = TREE_CHAIN (tem))
9364 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
9366 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
9367 TREE_ADDRESSABLE (tem) = 1;
9370 if (!value)
9371 continue;
9373 CONSTRUCTOR_APPEND_ELT (v, field, value);
9376 return gnat_build_constructor (record_type, v);
9379 /* Process a N_Validate_Unchecked_Conversion node. */
9381 static void
9382 validate_unchecked_conversion (Node_Id gnat_node)
9384 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
9385 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
9387 /* If the target is a pointer type, see if we are either converting from a
9388 non-pointer or from a pointer to a type with a different alias set and
9389 warn if so, unless the pointer has been marked to alias everything. */
9390 if (POINTER_TYPE_P (gnu_target_type)
9391 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type))
9393 tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
9394 ? TREE_TYPE (gnu_source_type)
9395 : NULL_TREE;
9396 tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
9397 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
9399 if (target_alias_set != 0
9400 && (!POINTER_TYPE_P (gnu_source_type)
9401 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
9402 target_alias_set)))
9404 post_error_ne ("?possible aliasing problem for type&",
9405 gnat_node, Target_Type (gnat_node));
9406 post_error ("\\?use -fno-strict-aliasing switch for references",
9407 gnat_node);
9408 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
9409 gnat_node, Target_Type (gnat_node));
9413 /* Likewise if the target is a fat pointer type, but we have no mechanism to
9414 mitigate the problem in this case, so we unconditionally warn. */
9415 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
9417 tree gnu_source_desig_type
9418 = TYPE_IS_FAT_POINTER_P (gnu_source_type)
9419 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
9420 : NULL_TREE;
9421 tree gnu_target_desig_type
9422 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
9423 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
9425 if (target_alias_set != 0
9426 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
9427 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
9428 target_alias_set)))
9430 post_error_ne ("?possible aliasing problem for type&",
9431 gnat_node, Target_Type (gnat_node));
9432 post_error ("\\?use -fno-strict-aliasing switch for references",
9433 gnat_node);
9438 /* EXP is to be treated as an array or record. Handle the cases when it is
9439 an access object and perform the required dereferences. */
9441 static tree
9442 maybe_implicit_deref (tree exp)
9444 /* If the type is a pointer, dereference it. */
9445 if (POINTER_TYPE_P (TREE_TYPE (exp))
9446 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
9447 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
9449 /* If we got a padded type, remove it too. */
9450 if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
9451 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
9453 return exp;
9456 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
9457 location and false if it doesn't. In the former case, set the Gigi global
9458 variable REF_FILENAME to the simple debug file name as given by sinput.
9459 If clear_column is true, set column information to 0. */
9461 static bool
9462 Sloc_to_locus1 (Source_Ptr Sloc, location_t *locus, bool clear_column)
9464 if (Sloc == No_Location)
9465 return false;
9467 if (Sloc <= Standard_Location)
9469 *locus = BUILTINS_LOCATION;
9470 return false;
9472 else
9474 Source_File_Index file = Get_Source_File_Index (Sloc);
9475 Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
9476 Column_Number column = (clear_column ? 0 : Get_Column_Number (Sloc));
9477 line_map_ordinary *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1);
9479 /* We can have zero if pragma Source_Reference is in effect. */
9480 if (line < 1)
9481 line = 1;
9483 /* Translate the location. */
9484 *locus = linemap_position_for_line_and_column (map, line, column);
9487 ref_filename
9488 = IDENTIFIER_POINTER
9489 (get_identifier
9490 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
9492 return true;
9495 /* Similar to the above, not clearing the column information. */
9497 bool
9498 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
9500 return Sloc_to_locus1 (Sloc, locus, false);
9503 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
9504 don't do anything if it doesn't correspond to a source location. */
9506 static void
9507 set_expr_location_from_node1 (tree node, Node_Id gnat_node, bool clear_column)
9509 location_t locus;
9511 if (!Sloc_to_locus1 (Sloc (gnat_node), &locus, clear_column))
9512 return;
9514 SET_EXPR_LOCATION (node, locus);
9517 /* Similar to the above, not clearing the column information. */
9519 static void
9520 set_expr_location_from_node (tree node, Node_Id gnat_node)
9522 set_expr_location_from_node1 (node, gnat_node, false);
9525 /* More elaborate version of set_expr_location_from_node to be used in more
9526 general contexts, for example the result of the translation of a generic
9527 GNAT node. */
9529 static void
9530 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
9532 /* Set the location information on the node if it is a real expression.
9533 References can be reused for multiple GNAT nodes and they would get
9534 the location information of their last use. Also make sure not to
9535 overwrite an existing location as it is probably more precise. */
9537 switch (TREE_CODE (node))
9539 CASE_CONVERT:
9540 case NON_LVALUE_EXPR:
9541 case SAVE_EXPR:
9542 break;
9544 case COMPOUND_EXPR:
9545 if (EXPR_P (TREE_OPERAND (node, 1)))
9546 set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
9548 /* ... fall through ... */
9550 default:
9551 if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
9553 set_expr_location_from_node (node, gnat_node);
9554 set_end_locus_from_node (node, gnat_node);
9556 break;
9560 /* Return a colon-separated list of encodings contained in encoded Ada
9561 name. */
9563 static const char *
9564 extract_encoding (const char *name)
9566 char *encoding = (char *) ggc_alloc_atomic (strlen (name));
9567 get_encoding (name, encoding);
9568 return encoding;
9571 /* Extract the Ada name from an encoded name. */
9573 static const char *
9574 decode_name (const char *name)
9576 char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
9577 __gnat_decode (name, decoded, 0);
9578 return decoded;
9581 /* Post an error message. MSG is the error message, properly annotated.
9582 NODE is the node at which to post the error and the node to use for the
9583 '&' substitution. */
9585 void
9586 post_error (const char *msg, Node_Id node)
9588 String_Template temp;
9589 String_Pointer sp;
9591 if (No (node))
9592 return;
9594 temp.Low_Bound = 1;
9595 temp.High_Bound = strlen (msg);
9596 sp.Bounds = &temp;
9597 sp.Array = msg;
9598 Error_Msg_N (sp, node);
9601 /* Similar to post_error, but NODE is the node at which to post the error and
9602 ENT is the node to use for the '&' substitution. */
9604 void
9605 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
9607 String_Template temp;
9608 String_Pointer sp;
9610 if (No (node))
9611 return;
9613 temp.Low_Bound = 1;
9614 temp.High_Bound = strlen (msg);
9615 sp.Bounds = &temp;
9616 sp.Array = msg;
9617 Error_Msg_NE (sp, node, ent);
9620 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
9622 void
9623 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
9625 Error_Msg_Uint_1 = UI_From_Int (num);
9626 post_error_ne (msg, node, ent);
9629 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
9630 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
9631 most sense. Return true if a sensible assignment was performed. */
9633 static bool
9634 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
9636 Node_Id gnat_end_label = Empty;
9637 location_t end_locus;
9639 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
9640 end_locus when there is one. We consider only GNAT nodes with a possible
9641 End_Label attached. If the End_Label actually was unassigned, fallback
9642 on the original node. We'd better assign an explicit sloc associated with
9643 the outer construct in any case. */
9645 switch (Nkind (gnat_node))
9647 case N_Package_Body:
9648 case N_Subprogram_Body:
9649 case N_Block_Statement:
9650 gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
9651 break;
9653 case N_Package_Declaration:
9654 gnat_end_label = End_Label (Specification (gnat_node));
9655 break;
9657 default:
9658 return false;
9661 gnat_node = Present (gnat_end_label) ? gnat_end_label : gnat_node;
9663 /* Some expanded subprograms have neither an End_Label nor a Sloc
9664 attached. Notify that to callers. For a block statement with no
9665 End_Label, clear column information, so that the tree for a
9666 transient block does not receive the sloc of a source condition. */
9668 if (!Sloc_to_locus1 (Sloc (gnat_node), &end_locus,
9669 No (gnat_end_label) &&
9670 (Nkind (gnat_node) == N_Block_Statement)))
9671 return false;
9673 switch (TREE_CODE (gnu_node))
9675 case BIND_EXPR:
9676 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
9677 return true;
9679 case FUNCTION_DECL:
9680 DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
9681 return true;
9683 default:
9684 return false;
9688 /* Similar to post_error_ne, but T is a GCC tree representing the number to
9689 write. If T represents a constant, the text inside curly brackets in
9690 MSG will be output (presumably including a '^'). Otherwise it will not
9691 be output and the text inside square brackets will be output instead. */
9693 void
9694 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
9696 char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
9697 char start_yes, end_yes, start_no, end_no;
9698 const char *p;
9699 char *q;
9701 if (TREE_CODE (t) == INTEGER_CST)
9703 Error_Msg_Uint_1 = UI_From_gnu (t);
9704 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
9706 else
9707 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
9709 for (p = msg, q = new_msg; *p; p++)
9711 if (*p == start_yes)
9712 for (p++; *p != end_yes; p++)
9713 *q++ = *p;
9714 else if (*p == start_no)
9715 for (p++; *p != end_no; p++)
9717 else
9718 *q++ = *p;
9721 *q = 0;
9723 post_error_ne (new_msg, node, ent);
9726 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
9728 void
9729 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
9730 int num)
9732 Error_Msg_Uint_2 = UI_From_Int (num);
9733 post_error_ne_tree (msg, node, ent, t);
9736 /* Initialize the table that maps GNAT codes to GCC codes for simple
9737 binary and unary operations. */
9739 static void
9740 init_code_table (void)
9742 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
9743 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
9745 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
9746 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
9747 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
9748 gnu_codes[N_Op_Eq] = EQ_EXPR;
9749 gnu_codes[N_Op_Ne] = NE_EXPR;
9750 gnu_codes[N_Op_Lt] = LT_EXPR;
9751 gnu_codes[N_Op_Le] = LE_EXPR;
9752 gnu_codes[N_Op_Gt] = GT_EXPR;
9753 gnu_codes[N_Op_Ge] = GE_EXPR;
9754 gnu_codes[N_Op_Add] = PLUS_EXPR;
9755 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
9756 gnu_codes[N_Op_Multiply] = MULT_EXPR;
9757 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
9758 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
9759 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
9760 gnu_codes[N_Op_Abs] = ABS_EXPR;
9761 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
9762 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
9763 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
9764 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
9765 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
9766 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
9769 /* Return a label to branch to for the exception type in KIND or NULL_TREE
9770 if none. */
9772 tree
9773 get_exception_label (char kind)
9775 if (kind == N_Raise_Constraint_Error)
9776 return gnu_constraint_error_label_stack->last ();
9777 else if (kind == N_Raise_Storage_Error)
9778 return gnu_storage_error_label_stack->last ();
9779 else if (kind == N_Raise_Program_Error)
9780 return gnu_program_error_label_stack->last ();
9781 else
9782 return NULL_TREE;
9785 /* Return the decl for the current elaboration procedure. */
9787 tree
9788 get_elaboration_procedure (void)
9790 return gnu_elab_proc_stack->last ();
9793 #include "gt-ada-trans.h"