1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2019, Free Software Foundation, Inc. *
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/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
33 #include "gimple-expr.h"
34 #include "stringpool.h"
37 #include "diagnostic.h"
39 #include "fold-const.h"
40 #include "stor-layout.h"
45 #include "libfuncs.h" /* For set_stack_check_libfunc. */
46 #include "tree-iterator.h"
49 #include "common/common-target.h"
50 #include "gomp-constants.h"
51 #include "stringpool.h"
55 #include "adadecode.h"
71 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
72 for fear of running out of stack space. If we need more, we use xmalloc
74 #define ALLOCA_THRESHOLD 1000
76 /* Pointers to front-end tables accessed through macros. */
77 struct Node
*Nodes_Ptr
;
78 struct Flags
*Flags_Ptr
;
79 Node_Id
*Next_Node_Ptr
;
80 Node_Id
*Prev_Node_Ptr
;
81 struct Elist_Header
*Elists_Ptr
;
82 struct Elmt_Item
*Elmts_Ptr
;
83 struct String_Entry
*Strings_Ptr
;
84 Char_Code
*String_Chars_Ptr
;
85 struct List_Header
*List_Headers_Ptr
;
87 /* Highest number in the front-end node table. */
90 /* True when gigi is being called on an analyzed but unexpanded
91 tree, and the only purpose of the call is to properly annotate
92 types with representation information. */
93 bool type_annotate_only
;
95 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
96 static vec
<Node_Id
> gnat_validate_uc_list
;
98 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
99 of unconstrained array IN parameters to avoid emitting a great deal of
100 redundant instructions to recompute them each time. */
101 struct GTY (()) parm_attr_d
{
102 int id
; /* GTY doesn't like Entity_Id. */
109 typedef struct parm_attr_d
*parm_attr
;
112 struct GTY(()) language_function
{
113 vec
<parm_attr
, va_gc
> *parm_attr_cache
;
114 bitmap named_ret_val
;
115 vec
<tree
, va_gc
> *other_ret_val
;
119 #define f_parm_attr_cache \
120 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
122 #define f_named_ret_val \
123 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
125 #define f_other_ret_val \
126 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
129 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
131 /* A structure used to gather together information about a statement group.
132 We use this to gather related statements, for example the "then" part
133 of a IF. In the case where it represents a lexical scope, we may also
134 have a BLOCK node corresponding to it and/or cleanups. */
136 struct GTY((chain_next ("%h.previous"))) stmt_group
{
137 struct stmt_group
*previous
; /* Previous code group. */
138 tree stmt_list
; /* List of statements for this code group. */
139 tree block
; /* BLOCK for this code group, if any. */
140 tree cleanups
; /* Cleanups for this code group, if any. */
143 static GTY(()) struct stmt_group
*current_stmt_group
;
145 /* List of unused struct stmt_group nodes. */
146 static GTY((deletable
)) struct stmt_group
*stmt_group_free_list
;
148 /* A structure used to record information on elaboration procedures
149 we've made and need to process.
151 ??? gnat_node should be Node_Id, but gengtype gets confused. */
153 struct GTY((chain_next ("%h.next"))) elab_info
{
154 struct elab_info
*next
; /* Pointer to next in chain. */
155 tree elab_proc
; /* Elaboration procedure. */
156 int gnat_node
; /* The N_Compilation_Unit. */
159 static GTY(()) struct elab_info
*elab_info_list
;
161 /* Stack of exception pointer variables. Each entry is the VAR_DECL
162 that stores the address of the raised exception. Nonzero means we
163 are in an exception handler. Not used in the zero-cost case. */
164 static GTY(()) vec
<tree
, va_gc
> *gnu_except_ptr_stack
;
166 /* In ZCX case, current exception pointer. Used to re-raise it. */
167 static GTY(()) tree gnu_incoming_exc_ptr
;
169 /* Stack for storing the current elaboration procedure decl. */
170 static GTY(()) vec
<tree
, va_gc
> *gnu_elab_proc_stack
;
172 /* Stack of labels to be used as a goto target instead of a return in
173 some functions. See processing for N_Subprogram_Body. */
174 static GTY(()) vec
<tree
, va_gc
> *gnu_return_label_stack
;
176 /* Stack of variable for the return value of a function with copy-in/copy-out
177 parameters. See processing for N_Subprogram_Body. */
178 static GTY(()) vec
<tree
, va_gc
> *gnu_return_var_stack
;
180 /* Structure used to record information for a range check. */
181 struct GTY(()) range_check_info_d
{
191 typedef struct range_check_info_d
*range_check_info
;
194 /* Structure used to record information for a loop. */
195 struct GTY(()) loop_info_d
{
200 tree omp_loop_clauses
;
201 tree omp_construct_clauses
;
202 enum tree_code omp_code
;
203 vec
<range_check_info
, va_gc
> *checks
;
206 typedef struct loop_info_d
*loop_info
;
209 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
210 static GTY(()) vec
<loop_info
, va_gc
> *gnu_loop_stack
;
212 /* The stacks for N_{Push,Pop}_*_Label. */
213 static vec
<Entity_Id
> gnu_constraint_error_label_stack
;
214 static vec
<Entity_Id
> gnu_storage_error_label_stack
;
215 static vec
<Entity_Id
> gnu_program_error_label_stack
;
217 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
218 static enum tree_code gnu_codes
[Number_Node_Kinds
];
220 static void init_code_table (void);
221 static tree
get_elaboration_procedure (void);
222 static void Compilation_Unit_to_gnu (Node_Id
);
223 static bool empty_stmt_list_p (tree
);
224 static void record_code_position (Node_Id
);
225 static void insert_code_for (Node_Id
);
226 static void add_cleanup (tree
, Node_Id
);
227 static void add_stmt_list (List_Id
);
228 static tree
build_stmt_group (List_Id
, bool);
229 static inline bool stmt_group_may_fallthru (void);
230 static enum gimplify_status
gnat_gimplify_stmt (tree
*);
231 static void elaborate_all_entities (Node_Id
);
232 static void process_freeze_entity (Node_Id
);
233 static void process_decls (List_Id
, List_Id
, Node_Id
, bool, bool);
234 static tree
emit_range_check (tree
, Node_Id
, Node_Id
);
235 static tree
emit_check (tree
, tree
, int, Node_Id
);
236 static tree
build_unary_op_trapv (enum tree_code
, tree
, tree
, Node_Id
);
237 static tree
build_binary_op_trapv (enum tree_code
, tree
, tree
, tree
, Node_Id
);
238 static tree
convert_with_check (Entity_Id
, tree
, bool, bool, bool, Node_Id
);
239 static bool addressable_p (tree
, tree
);
240 static tree
assoc_to_constructor (Entity_Id
, Node_Id
, tree
);
241 static tree
pos_to_constructor (Node_Id
, tree
, Entity_Id
);
242 static void validate_unchecked_conversion (Node_Id
);
243 static Node_Id
adjust_for_implicit_deref (Node_Id
);
244 static tree
maybe_implicit_deref (tree
);
245 static void set_expr_location_from_node (tree
, Node_Id
, bool = false);
246 static void set_gnu_expr_location_from_node (tree
, Node_Id
);
247 static bool set_end_locus_from_node (tree
, Node_Id
);
248 static int lvalue_required_p (Node_Id
, tree
, bool, bool);
249 static tree
build_raise_check (int, enum exception_info_kind
);
250 static tree
create_init_temporary (const char *, tree
, tree
*, Node_Id
);
251 static bool maybe_make_gnu_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
);
253 /* Hooks for debug info back-ends, only supported and used in a restricted set
254 of configurations. */
255 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED
;
256 static const char *decode_name (const char *) ATTRIBUTE_UNUSED
;
258 /* This makes gigi's file_info_ptr visible in this translation unit,
259 so that Sloc_to_locus can look it up when deciding whether to map
260 decls to instances. */
262 static struct File_Info_Type
*file_map
;
264 /* This is the main program of the back-end. It sets up all the table
265 structures and then generates code. */
268 gigi (Node_Id gnat_root
,
270 int number_name ATTRIBUTE_UNUSED
,
271 struct Node
*nodes_ptr
,
272 struct Flags
*flags_ptr
,
273 Node_Id
*next_node_ptr
,
274 Node_Id
*prev_node_ptr
,
275 struct Elist_Header
*elists_ptr
,
276 struct Elmt_Item
*elmts_ptr
,
277 struct String_Entry
*strings_ptr
,
278 Char_Code
*string_chars_ptr
,
279 struct List_Header
*list_headers_ptr
,
281 struct File_Info_Type
*file_info_ptr
,
282 Entity_Id standard_boolean
,
283 Entity_Id standard_integer
,
284 Entity_Id standard_character
,
285 Entity_Id standard_long_long_float
,
286 Entity_Id standard_exception_type
,
287 Int gigi_operating_mode
)
290 Entity_Id gnat_literal
;
291 tree t
, ftype
, int64_type
;
292 struct elab_info
*info
;
295 max_gnat_nodes
= max_gnat_node
;
297 Nodes_Ptr
= nodes_ptr
;
298 Flags_Ptr
= flags_ptr
;
299 Next_Node_Ptr
= next_node_ptr
;
300 Prev_Node_Ptr
= prev_node_ptr
;
301 Elists_Ptr
= elists_ptr
;
302 Elmts_Ptr
= elmts_ptr
;
303 Strings_Ptr
= strings_ptr
;
304 String_Chars_Ptr
= string_chars_ptr
;
305 List_Headers_Ptr
= list_headers_ptr
;
307 type_annotate_only
= (gigi_operating_mode
== 1);
309 if (Generate_SCO_Instance_Table
!= 0)
311 file_map
= file_info_ptr
;
312 maybe_create_decl_to_instance_map (number_file
);
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. */
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. */
351 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
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", 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
),
379 /* Likewise for character as the type for Standard.Character. */
380 finish_character_type (char_type_node
);
381 save_gnu_tree (Base_Type (standard_character
),
382 TYPE_NAME (char_type_node
),
385 /* Likewise for boolean as the type for Standard.Boolean. */
386 save_gnu_tree (Base_Type (standard_boolean
),
387 TYPE_NAME (boolean_type_node
),
389 gnat_literal
= First_Literal (Base_Type (standard_boolean
));
390 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
391 gcc_assert (t
== boolean_false_node
);
392 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
393 boolean_type_node
, t
, true, false, false, false, false,
394 true, false, NULL
, gnat_literal
);
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, false,
401 true, false, NULL
, gnat_literal
);
402 save_gnu_tree (gnat_literal
, t
, false);
404 /* Declare the building blocks of function nodes. */
405 void_list_node
= build_tree_list (NULL_TREE
, void_type_node
);
406 void_ftype
= build_function_type_list (void_type_node
, NULL_TREE
);
407 ptr_void_ftype
= build_pointer_type (void_ftype
);
409 /* Now declare run-time functions. */
411 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE
,
412 build_function_type_list (ptr_type_node
, sizetype
,
414 NULL_TREE
, is_default
, true, true, true, false,
416 DECL_IS_MALLOC (malloc_decl
) = 1;
419 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
420 build_function_type_list (void_type_node
,
421 ptr_type_node
, NULL_TREE
),
422 NULL_TREE
, is_default
, true, true, true, false,
426 = create_subprog_decl (get_identifier ("__gnat_realloc"), NULL_TREE
,
427 build_function_type_list (ptr_type_node
,
428 ptr_type_node
, sizetype
,
430 NULL_TREE
, is_default
, true, true, true, false,
433 /* This is used for 64-bit multiplication with overflow checking. */
434 int64_type
= gnat_type_for_size (64, 0);
436 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE
,
437 build_function_type_list (int64_type
, int64_type
,
438 int64_type
, NULL_TREE
),
439 NULL_TREE
, is_default
, true, true, true, false,
442 /* Name of the _Parent field in tagged record types. */
443 parent_name_id
= get_identifier (Get_Name_String (Name_uParent
));
445 /* Name of the Exception_Data type defined in System.Standard_Library. */
446 exception_data_name_id
447 = get_identifier ("system__standard_library__exception_data");
449 /* Make the types and functions used for exception processing. */
450 except_type_node
= gnat_to_gnu_type (Base_Type (standard_exception_type
));
453 = build_array_type (gnat_type_for_mode (Pmode
, 0),
454 build_index_type (size_int (5)));
455 record_builtin_type ("JMPBUF_T", jmpbuf_type
, true);
456 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
458 /* Functions to get and set the jumpbuf pointer for the current thread. */
460 = create_subprog_decl
461 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
462 NULL_TREE
, build_function_type_list (jmpbuf_ptr_type
, NULL_TREE
),
463 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
466 = create_subprog_decl
467 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
468 NULL_TREE
, build_function_type_list (void_type_node
, jmpbuf_ptr_type
,
470 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
473 = create_subprog_decl
474 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE
,
475 build_function_type_list (build_pointer_type (except_type_node
),
477 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
479 not_handled_by_others_decl
= get_identifier ("not_handled_by_others");
480 for (t
= TYPE_FIELDS (except_type_node
); t
; t
= DECL_CHAIN (t
))
481 if (DECL_NAME (t
) == not_handled_by_others_decl
)
483 not_handled_by_others_decl
= t
;
486 gcc_assert (DECL_P (not_handled_by_others_decl
));
488 /* setjmp returns an integer and has one operand, which is a pointer to
491 = create_subprog_decl
492 (get_identifier ("__builtin_setjmp"), NULL_TREE
,
493 build_function_type_list (integer_type_node
, jmpbuf_ptr_type
,
495 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
496 DECL_BUILT_IN_CLASS (setjmp_decl
) = BUILT_IN_NORMAL
;
497 DECL_FUNCTION_CODE (setjmp_decl
) = BUILT_IN_SETJMP
;
499 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
501 update_setjmp_buf_decl
502 = create_subprog_decl
503 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE
,
504 build_function_type_list (void_type_node
, jmpbuf_ptr_type
, NULL_TREE
),
505 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
506 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl
) = BUILT_IN_NORMAL
;
507 DECL_FUNCTION_CODE (update_setjmp_buf_decl
) = BUILT_IN_UPDATE_SETJMP_BUF
;
509 /* Indicate that it never returns. */
510 ftype
= build_function_type_list (void_type_node
,
511 build_pointer_type (except_type_node
),
513 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
515 = create_subprog_decl
516 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
, ftype
,
517 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
519 set_exception_parameter_decl
520 = create_subprog_decl
521 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE
,
522 build_function_type_list (void_type_node
, ptr_type_node
, ptr_type_node
,
524 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
526 /* Hooks to call when entering/leaving an exception handler. */
527 ftype
= build_function_type_list (void_type_node
, ptr_type_node
, NULL_TREE
);
530 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE
,
532 is_default
, true, true, true, false, false, NULL
,
534 /* __gnat_begin_handler is a dummy procedure. */
535 TREE_NOTHROW (begin_handler_decl
) = 1;
538 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE
,
540 is_default
, true, true, true, false, false, NULL
,
543 unhandled_except_decl
544 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
545 NULL_TREE
, ftype
, NULL_TREE
,
546 is_default
, true, true, true, false, false, NULL
,
549 /* Indicate that it never returns. */
550 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
552 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE
,
554 is_default
, true, true, true, false, false, NULL
,
557 /* Dummy objects to materialize "others" and "all others" in the exception
558 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
561 = create_var_decl (get_identifier ("OTHERS"),
562 get_identifier ("__gnat_others_value"),
563 char_type_node
, NULL_TREE
,
564 true, false, true, false, false, true, false,
568 = create_var_decl (get_identifier ("ALL_OTHERS"),
569 get_identifier ("__gnat_all_others_value"),
570 char_type_node
, NULL_TREE
,
571 true, false, true, false, false, true, false,
574 unhandled_others_decl
575 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
576 get_identifier ("__gnat_unhandled_others_value"),
577 char_type_node
, NULL_TREE
,
578 true, false, true, false, false, true, false,
581 /* If in no exception handlers mode, all raise statements are redirected to
582 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
583 this procedure will never be called in this mode. */
584 if (No_Exception_Handlers_Set ())
586 /* Indicate that it never returns. */
587 ftype
= build_function_type_list (void_type_node
,
588 build_pointer_type (char_type_node
),
589 integer_type_node
, NULL_TREE
);
590 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
592 = create_subprog_decl
593 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
, ftype
,
594 NULL_TREE
, is_default
, true, true, true, false, false, NULL
,
596 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
597 gnat_raise_decls
[i
] = decl
;
601 /* Otherwise, make one decl for each exception reason. */
602 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
603 gnat_raise_decls
[i
] = build_raise_check (i
, exception_simple
);
604 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls_ext
); i
++)
605 gnat_raise_decls_ext
[i
]
606 = build_raise_check (i
,
607 i
== CE_Index_Check_Failed
608 || i
== CE_Range_Check_Failed
609 || i
== CE_Invalid_Data
610 ? exception_range
: exception_column
);
613 /* Build the special descriptor type and its null node if needed. */
614 if (TARGET_VTABLE_USES_DESCRIPTORS
)
616 tree null_node
= fold_convert (ptr_void_ftype
, null_pointer_node
);
617 tree field_list
= NULL_TREE
;
619 vec
<constructor_elt
, va_gc
> *null_vec
= NULL
;
620 constructor_elt
*elt
;
622 fdesc_type_node
= make_node (RECORD_TYPE
);
623 vec_safe_grow (null_vec
, TARGET_VTABLE_USES_DESCRIPTORS
);
624 elt
= (null_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
626 for (j
= 0; j
< TARGET_VTABLE_USES_DESCRIPTORS
; j
++)
629 = create_field_decl (NULL_TREE
, ptr_void_ftype
, fdesc_type_node
,
630 NULL_TREE
, NULL_TREE
, 0, 1);
631 DECL_CHAIN (field
) = field_list
;
634 elt
->value
= null_node
;
638 finish_record_type (fdesc_type_node
, nreverse (field_list
), 0, false);
639 record_builtin_type ("descriptor", fdesc_type_node
, true);
640 null_fdesc_node
= gnat_build_constructor (fdesc_type_node
, null_vec
);
643 longest_float_type_node
644 = get_unpadded_type (Base_Type (standard_long_long_float
));
646 main_identifier_node
= get_identifier ("main");
648 /* If we are using the GCC exception mechanism, let GCC know. */
649 if (Back_End_Exceptions ())
652 /* Initialize the GCC support for FP operations. */
655 /* Install the builtins we might need, either internally or as user-available
656 facilities for Intrinsic imports. Note that this must be done after the
657 GCC exception mechanism is initialized. */
658 gnat_install_builtins ();
660 vec_safe_push (gnu_except_ptr_stack
, NULL_TREE
);
662 gnu_constraint_error_label_stack
.safe_push (Empty
);
663 gnu_storage_error_label_stack
.safe_push (Empty
);
664 gnu_program_error_label_stack
.safe_push (Empty
);
666 /* Process any Pragma Ident for the main unit. */
667 if (Present (Ident_String (Main_Unit
)))
668 targetm
.asm_out
.output_ident
669 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
671 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
672 if (No_Strict_Aliasing_CP
)
673 flag_strict_aliasing
= 0;
675 /* Save the current optimization options again after the above possible
676 global_options changes. */
677 optimization_default_node
= build_optimization_node (&global_options
);
678 optimization_current_node
= optimization_default_node
;
680 /* Now translate the compilation unit proper. */
681 Compilation_Unit_to_gnu (gnat_root
);
683 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
684 the very end to avoid having to second-guess the front-end when we run
685 into dummy nodes during the regular processing. */
686 for (i
= 0; gnat_validate_uc_list
.iterate (i
, &gnat_iter
); i
++)
687 validate_unchecked_conversion (gnat_iter
);
688 gnat_validate_uc_list
.release ();
690 /* Finally see if we have any elaboration procedures to deal with. */
691 for (info
= elab_info_list
; info
; info
= info
->next
)
693 tree gnu_body
= DECL_SAVED_TREE (info
->elab_proc
);
695 /* We should have a BIND_EXPR but it may not have any statements in it.
696 If it doesn't have any, we have nothing to do except for setting the
697 flag on the GNAT node. Otherwise, process the function as others. */
698 tree gnu_stmts
= gnu_body
;
699 if (TREE_CODE (gnu_stmts
) == BIND_EXPR
)
700 gnu_stmts
= BIND_EXPR_BODY (gnu_stmts
);
701 if (!gnu_stmts
|| empty_stmt_list_p (gnu_stmts
))
702 Set_Has_No_Elaboration_Code (info
->gnat_node
, 1);
705 begin_subprog_body (info
->elab_proc
);
706 end_subprog_body (gnu_body
);
707 rest_of_subprog_body_compilation (info
->elab_proc
);
711 /* Destroy ourselves. */
713 destroy_gnat_decl ();
714 destroy_gnat_utils ();
716 /* We cannot track the location of errors past this point. */
717 Current_Error_Node
= Empty
;
720 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
721 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
724 build_raise_check (int check
, enum exception_info_kind kind
)
727 const char pfx
[] = "__gnat_rcheck_";
729 strcpy (Name_Buffer
, pfx
);
730 Name_Len
= sizeof (pfx
) - 1;
731 Get_RT_Exception_Name (check
);
733 if (kind
== exception_simple
)
735 Name_Buffer
[Name_Len
] = 0;
737 = build_function_type_list (void_type_node
,
738 build_pointer_type (char_type_node
),
739 integer_type_node
, NULL_TREE
);
743 tree t
= (kind
== exception_column
? NULL_TREE
: integer_type_node
);
745 strcpy (Name_Buffer
+ Name_Len
, "_ext");
746 Name_Buffer
[Name_Len
+ 4] = 0;
748 = build_function_type_list (void_type_node
,
749 build_pointer_type (char_type_node
),
750 integer_type_node
, integer_type_node
,
754 /* Indicate that it never returns. */
755 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
757 = create_subprog_decl (get_identifier (Name_Buffer
), NULL_TREE
, ftype
,
758 NULL_TREE
, is_default
, true, true, true, false,
764 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
765 an N_Attribute_Reference. */
768 lvalue_required_for_attribute_p (Node_Id gnat_node
)
770 switch (Get_Attribute_Id (Attribute_Name (gnat_node
)))
778 case Attr_Range_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
:
787 case Attr_Null_Parameter
:
788 case Attr_Passed_By_Reference
:
789 case Attr_Mechanism_Code
:
796 case Attr_Unchecked_Access
:
797 case Attr_Unrestricted_Access
:
798 case Attr_Code_Address
:
799 case Attr_Pool_Address
:
802 case Attr_Bit_Position
:
808 case Attr_Asm_Output
:
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 another constant. If it isn't, then
819 ADDRESS_OF_CONSTANT is 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
827 lvalue_required_p (Node_Id gnat_node
, tree gnu_type
, bool constant
,
828 bool address_of_constant
)
830 Node_Id gnat_parent
= Parent (gnat_node
), gnat_temp
;
832 switch (Nkind (gnat_parent
))
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. */
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
)
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
));
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
))
866 /* ... fall through ... */
869 /* Only the array expression can require an lvalue. */
870 if (Prefix (gnat_parent
) != gnat_node
)
873 return lvalue_required_p (gnat_parent
, gnu_type
, constant
,
874 address_of_constant
);
876 case N_Selected_Component
:
877 return lvalue_required_p (gnat_parent
, gnu_type
, constant
,
878 address_of_constant
);
880 case N_Object_Renaming_Declaration
:
881 /* We need to preserve addresses through a renaming. */
884 case N_Object_Declaration
:
885 /* We cannot use a constructor if this is an atomic object because
886 the actual assignment might end up being done component-wise. */
888 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
889 && Is_Atomic_Or_VFA (Defining_Entity (gnat_parent
)))
890 /* We don't use a constructor if this is a class-wide object
891 because the effective type of the object is the equivalent
892 type of the class-wide subtype and it smashes most of the
893 data into an array of bytes to which we cannot convert. */
894 || Ekind ((Etype (Defining_Entity (gnat_parent
))))
895 == E_Class_Wide_Subtype
);
897 case N_Assignment_Statement
:
898 /* We cannot use a constructor if the LHS is an atomic object because
899 the actual assignment might end up being done component-wise. */
901 || Name (gnat_parent
) == gnat_node
902 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
903 && Is_Entity_Name (Name (gnat_parent
))
904 && Is_Atomic_Or_VFA (Entity (Name (gnat_parent
)))));
906 case N_Unchecked_Type_Conversion
:
910 /* ... fall through ... */
912 case N_Type_Conversion
:
913 case N_Qualified_Expression
:
914 /* We must look through all conversions because we may need to bypass
915 an intermediate conversion that is meant to be purely formal. */
916 return lvalue_required_p (gnat_parent
,
917 get_unpadded_type (Etype (gnat_parent
)),
918 constant
, address_of_constant
);
921 /* We should only reach here through the N_Qualified_Expression case.
922 Force an lvalue for composite types since a block-copy to the newly
923 allocated area of memory is made. */
924 return Is_Composite_Type (Underlying_Type (Etype (gnat_node
)));
926 case N_Explicit_Dereference
:
927 /* We look through dereferences for address of constant because we need
928 to handle the special cases listed above. */
929 if (constant
&& address_of_constant
)
930 return lvalue_required_p (gnat_parent
,
931 get_unpadded_type (Etype (gnat_parent
)),
934 /* ... fall through ... */
943 /* Return true if T is a constant DECL node that can be safely replaced
944 by its initializer. */
947 constant_decl_with_initializer_p (tree t
)
949 if (!TREE_CONSTANT (t
) || !DECL_P (t
) || !DECL_INITIAL (t
))
952 /* Return false for aggregate types that contain a placeholder since
953 their initializers cannot be manipulated easily. */
954 if (AGGREGATE_TYPE_P (TREE_TYPE (t
))
955 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t
))
956 && type_contains_placeholder_p (TREE_TYPE (t
)))
962 /* Return an expression equivalent to EXP but where constant DECL nodes
963 have been replaced by their initializer. */
966 fold_constant_decl_in_expr (tree exp
)
968 enum tree_code code
= TREE_CODE (exp
);
975 if (!constant_decl_with_initializer_p (exp
))
978 return DECL_INITIAL (exp
);
981 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
982 if (op0
== TREE_OPERAND (exp
, 0))
985 return fold_build3 (COMPONENT_REF
, TREE_TYPE (exp
), op0
,
986 TREE_OPERAND (exp
, 1), NULL_TREE
);
989 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
990 if (op0
== TREE_OPERAND (exp
, 0))
993 return fold_build3 (BIT_FIELD_REF
, TREE_TYPE (exp
), op0
,
994 TREE_OPERAND (exp
, 1), TREE_OPERAND (exp
, 2));
997 case ARRAY_RANGE_REF
:
998 /* If the index is not itself constant, then nothing can be folded. */
999 if (!TREE_CONSTANT (TREE_OPERAND (exp
, 1)))
1001 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1002 if (op0
== TREE_OPERAND (exp
, 0))
1005 return fold (build4 (code
, TREE_TYPE (exp
), op0
, TREE_OPERAND (exp
, 1),
1006 TREE_OPERAND (exp
, 2), NULL_TREE
));
1010 case VIEW_CONVERT_EXPR
:
1011 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1012 if (op0
== TREE_OPERAND (exp
, 0))
1015 return fold_build1 (code
, TREE_TYPE (exp
), op0
);
1024 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
1025 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
1026 to where we should place the result type. */
1029 Identifier_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
1031 Node_Id gnat_temp
, gnat_temp_type
;
1032 tree gnu_result
, gnu_result_type
;
1034 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1035 specific circumstances only, so evaluated lazily. < 0 means
1036 unknown, > 0 means known true, 0 means known false. */
1037 int require_lvalue
= -1;
1039 /* If GNAT_NODE is a constant, whether we should use the initialization
1040 value instead of the constant entity, typically for scalars with an
1041 address clause when the parent doesn't require an lvalue. */
1042 bool use_constant_initializer
= false;
1044 /* If the Etype of this node is not the same as that of the Entity, then
1045 something went wrong, probably in generic instantiation. However, this
1046 does not apply to types. Since we sometime have strange Ekind's, just
1047 do this test for objects. Moreover, if the Etype of the Entity is private
1048 or incomplete coming from a limited context, the Etype of the N_Identifier
1049 is allowed to be the full/non-limited view and we also consider a packed
1050 array type to be the same as the original type. Similarly, a CW type is
1051 equivalent to a subtype of itself. Finally, if the types are Itypes, one
1052 may be a copy of the other, which is also legal. */
1053 gnat_temp
= ((Nkind (gnat_node
) == N_Defining_Identifier
1054 || Nkind (gnat_node
) == N_Defining_Operator_Symbol
)
1055 ? gnat_node
: Entity (gnat_node
));
1056 gnat_temp_type
= Etype (gnat_temp
);
1058 gcc_assert (Etype (gnat_node
) == gnat_temp_type
1059 || (Is_Packed (gnat_temp_type
)
1060 && (Etype (gnat_node
)
1061 == Packed_Array_Impl_Type (gnat_temp_type
)))
1062 || (Is_Class_Wide_Type (Etype (gnat_node
)))
1063 || (Is_Incomplete_Or_Private_Type (gnat_temp_type
)
1064 && Present (Full_View (gnat_temp_type
))
1065 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
1066 || (Is_Packed (Full_View (gnat_temp_type
))
1067 && (Etype (gnat_node
)
1068 == Packed_Array_Impl_Type
1069 (Full_View (gnat_temp_type
))))))
1070 || (Is_Incomplete_Type (gnat_temp_type
)
1071 && From_Limited_With (gnat_temp_type
)
1072 && Present (Non_Limited_View (gnat_temp_type
))
1073 && Etype (gnat_node
) == Non_Limited_View (gnat_temp_type
))
1074 || (Is_Itype (Etype (gnat_node
)) && Is_Itype (gnat_temp_type
))
1075 || !(Ekind (gnat_temp
) == E_Variable
1076 || Ekind (gnat_temp
) == E_Component
1077 || Ekind (gnat_temp
) == E_Constant
1078 || Ekind (gnat_temp
) == E_Loop_Parameter
1079 || Is_Formal (gnat_temp
)));
1081 /* If this is a reference to a deferred constant whose partial view is an
1082 unconstrained private type, the proper type is on the full view of the
1083 constant, not on the full view of the type, which may be unconstrained.
1085 This may be a reference to a type, for example in the prefix of the
1086 attribute Position, generated for dispatching code (see Make_DT in
1087 exp_disp,adb). In that case we need the type itself, not is parent,
1088 in particular if it is a derived type */
1089 if (Ekind (gnat_temp
) == E_Constant
1090 && Is_Private_Type (gnat_temp_type
)
1091 && (Has_Unknown_Discriminants (gnat_temp_type
)
1092 || (Present (Full_View (gnat_temp_type
))
1093 && Has_Discriminants (Full_View (gnat_temp_type
))))
1094 && Present (Full_View (gnat_temp
)))
1096 gnat_temp
= Full_View (gnat_temp
);
1097 gnat_temp_type
= Etype (gnat_temp
);
1101 /* We want to use the Actual_Subtype if it has already been elaborated,
1102 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
1104 if ((Ekind (gnat_temp
) == E_Constant
1105 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
1106 && !(Is_Array_Type (Etype (gnat_temp
))
1107 && Present (Packed_Array_Impl_Type (Etype (gnat_temp
))))
1108 && Present (Actual_Subtype (gnat_temp
))
1109 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
1110 gnat_temp_type
= Actual_Subtype (gnat_temp
);
1112 gnat_temp_type
= Etype (gnat_node
);
1115 /* Expand the type of this identifier first, in case it is an enumeral
1116 literal, which only get made when the type is expanded. There is no
1117 order-of-elaboration issue here. */
1118 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
1120 /* If this is a non-imported elementary constant with an address clause,
1121 retrieve the value instead of a pointer to be dereferenced unless
1122 an lvalue is required. This is generally more efficient and actually
1123 required if this is a static expression because it might be used
1124 in a context where a dereference is inappropriate, such as a case
1125 statement alternative or a record discriminant. There is no possible
1126 volatile-ness short-circuit here since Volatile constants must be
1127 imported per C.6. */
1128 if (Ekind (gnat_temp
) == E_Constant
1129 && Is_Elementary_Type (gnat_temp_type
)
1130 && !Is_Imported (gnat_temp
)
1131 && Present (Address_Clause (gnat_temp
)))
1134 = lvalue_required_p (gnat_node
, gnu_result_type
, true, false);
1135 use_constant_initializer
= !require_lvalue
;
1138 if (use_constant_initializer
)
1140 /* If this is a deferred constant, the initializer is attached to
1142 if (Present (Full_View (gnat_temp
)))
1143 gnat_temp
= Full_View (gnat_temp
);
1145 gnu_result
= gnat_to_gnu (Expression (Declaration_Node (gnat_temp
)));
1148 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false);
1150 /* Some objects (such as parameters passed by reference, globals of
1151 variable size, and renamed objects) actually represent the address
1152 of the object. In that case, we must do the dereference. Likewise,
1153 deal with parameters to foreign convention subprograms. */
1154 if (DECL_P (gnu_result
)
1155 && (DECL_BY_REF_P (gnu_result
)
1156 || (TREE_CODE (gnu_result
) == PARM_DECL
1157 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
1159 const bool read_only
= DECL_POINTS_TO_READONLY_P (gnu_result
);
1161 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1162 if (TREE_CODE (gnu_result
) == PARM_DECL
1163 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
1165 = convert (build_pointer_type (gnu_result_type
), gnu_result
);
1167 /* If it's a CONST_DECL, return the underlying constant like below. */
1168 else if (TREE_CODE (gnu_result
) == CONST_DECL
1169 && !(DECL_CONST_ADDRESS_P (gnu_result
)
1170 && lvalue_required_p (gnat_node
, gnu_result_type
, true,
1172 gnu_result
= DECL_INITIAL (gnu_result
);
1174 /* If it's a renaming pointer, get to the renamed object. */
1175 if (TREE_CODE (gnu_result
) == VAR_DECL
1176 && !DECL_LOOP_PARM_P (gnu_result
)
1177 && DECL_RENAMED_OBJECT (gnu_result
))
1178 gnu_result
= DECL_RENAMED_OBJECT (gnu_result
);
1180 /* Otherwise, do the final dereference. */
1183 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
1185 if ((TREE_CODE (gnu_result
) == INDIRECT_REF
1186 || TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
1187 && No (Address_Clause (gnat_temp
)))
1188 TREE_THIS_NOTRAP (gnu_result
) = 1;
1191 TREE_READONLY (gnu_result
) = 1;
1195 /* If we have a constant declaration and its initializer, try to return the
1196 latter to avoid the need to call fold in lots of places and the need for
1197 elaboration code if this identifier is used as an initializer itself. */
1198 if (constant_decl_with_initializer_p (gnu_result
))
1200 bool constant_only
= (TREE_CODE (gnu_result
) == CONST_DECL
1201 && !DECL_CONST_CORRESPONDING_VAR (gnu_result
));
1202 bool address_of_constant
= (TREE_CODE (gnu_result
) == CONST_DECL
1203 && DECL_CONST_ADDRESS_P (gnu_result
));
1205 /* If there is a (corresponding) variable or this is the address of a
1206 constant, we only want to return the initializer if an lvalue isn't
1207 required. Evaluate this now if we have not already done so. */
1208 if ((!constant_only
|| address_of_constant
) && require_lvalue
< 0)
1210 = lvalue_required_p (gnat_node
, gnu_result_type
, true,
1211 address_of_constant
);
1213 /* Finally retrieve the initializer if this is deemed valid. */
1214 if ((constant_only
&& !address_of_constant
) || !require_lvalue
)
1215 gnu_result
= DECL_INITIAL (gnu_result
);
1218 /* But for a constant renaming we couldn't do that incrementally for its
1219 definition because of the need to return an lvalue so, if the present
1220 context doesn't itself require an lvalue, we try again here. */
1221 else if (Ekind (gnat_temp
) == E_Constant
1222 && Is_Elementary_Type (gnat_temp_type
)
1223 && Present (Renamed_Object (gnat_temp
)))
1225 if (require_lvalue
< 0)
1227 = lvalue_required_p (gnat_node
, gnu_result_type
, true, false);
1228 if (!require_lvalue
)
1229 gnu_result
= fold_constant_decl_in_expr (gnu_result
);
1232 /* The GNAT tree has the type of a function set to its result type, so we
1233 adjust here. Also use the type of the result if the Etype is a subtype
1234 that is nominally unconstrained. Likewise if this is a deferred constant
1235 of a discriminated type whose full view can be elaborated statically, to
1236 avoid problematic conversions to the nominal subtype. But remove any
1237 padding from the resulting type. */
1238 if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_result
))
1239 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
)
1240 || (Ekind (gnat_temp
) == E_Constant
1241 && Present (Full_View (gnat_temp
))
1242 && Has_Discriminants (gnat_temp_type
)
1243 && TREE_CODE (gnu_result
) == CONSTRUCTOR
))
1245 gnu_result_type
= TREE_TYPE (gnu_result
);
1246 if (TYPE_IS_PADDING_P (gnu_result_type
))
1247 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
1250 *gnu_result_type_p
= gnu_result_type
;
1255 /* If GNAT_EXPR is an N_Identifier, N_Integer_Literal or N_Operator_Symbol,
1256 call FN on it. If GNAT_EXPR is an aggregate, call FN on each of its
1257 elements. In both cases, pass GNU_EXPR and DATA as additional arguments.
1259 This function is used everywhere OpenAcc pragmas are processed if these
1260 pragmas can accept aggregates. */
1263 Iterate_Acc_Clause_Arg (Node_Id gnat_expr
, tree gnu_expr
,
1264 tree (*fn
)(Node_Id
, tree
, void*),
1267 switch (Nkind (gnat_expr
))
1270 if (Present (Expressions (gnat_expr
)))
1272 for (Node_Id gnat_list_expr
= First (Expressions (gnat_expr
));
1273 Present (gnat_list_expr
);
1274 gnat_list_expr
= Next (gnat_list_expr
))
1275 gnu_expr
= fn (gnat_list_expr
, gnu_expr
, data
);
1277 else if (Present (Component_Associations (gnat_expr
)))
1279 for (Node_Id gnat_list_expr
= First (Component_Associations
1281 Present (gnat_list_expr
);
1282 gnat_list_expr
= Next (gnat_list_expr
))
1283 gnu_expr
= fn (Expression (gnat_list_expr
), gnu_expr
, data
);
1290 case N_Integer_Literal
:
1291 case N_Operator_Symbol
:
1292 gnu_expr
= fn (gnat_expr
, gnu_expr
, data
);
1302 /* Same as gnat_to_gnu for a GNAT_NODE referenced within an OpenAcc directive,
1303 undoing transformations that are inappropriate for such context. */
1306 Acc_gnat_to_gnu (Node_Id gnat_node
)
1308 tree gnu_result
= gnat_to_gnu (gnat_node
);
1310 /* If gnat_node is an identifier for a boolean, gnat_to_gnu might have
1311 turned it into `identifier != 0`. Since arguments to OpenAcc pragmas
1312 need to be writable, we need to return the identifier residing in such
1313 expressions rather than the expression itself. */
1314 if (Nkind (gnat_node
) == N_Identifier
1315 && TREE_CODE (gnu_result
) == NE_EXPR
1316 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_result
, 0))) == BOOLEAN_TYPE
1317 && integer_zerop (TREE_OPERAND (gnu_result
, 1)))
1318 gnu_result
= TREE_OPERAND (gnu_result
, 0);
1323 /* Turn GNAT_EXPR into a tree node representing an OMP data clause and chain
1324 it to GNU_CLAUSES, a list of pre-existing OMP clauses. GNAT_EXPR should be
1325 a N_Identifier, this is enforced by the frontend.
1327 This function is called every time translation of an argument for an OpenAcc
1328 clause (e.g. Acc_Parallel(Copy => My_Identifier)) is needed. */
1331 Acc_Data_to_gnu (Node_Id gnat_expr
, tree gnu_clauses
, void* data
)
1333 const enum gomp_map_kind kind
= *((enum gomp_map_kind
*) data
);
1335 = build_omp_clause (EXPR_LOCATION(gnu_loop_stack
->last ()->stmt
),
1338 gcc_assert (Nkind (gnat_expr
) == N_Identifier
);
1339 OMP_CLAUSE_DECL (gnu_clause
)
1340 = gnat_to_gnu_entity (Entity (gnat_expr
), NULL_TREE
, false);
1342 TREE_ADDRESSABLE (OMP_CLAUSE_DECL (gnu_clause
)) = 1;
1343 OMP_CLAUSE_SET_MAP_KIND (gnu_clause
, kind
);
1344 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1349 /* Turn GNAT_EXPR into a tree node representing an OMP clause and chain it to
1350 GNU_CLAUSES, a list of existing OMP clauses.
1352 This function is used for parsing arguments of non-data clauses (e.g.
1353 Acc_Parallel(Wait => gnatexpr)). */
1356 Acc_Var_to_gnu (Node_Id gnat_expr
, tree gnu_clauses
, void* data
)
1358 const enum omp_clause_code kind
= *((enum omp_clause_code
*) data
);
1360 = build_omp_clause (EXPR_LOCATION (gnu_loop_stack
->last ()->stmt
), kind
);
1362 OMP_CLAUSE_DECL (gnu_clause
) = Acc_gnat_to_gnu (gnat_expr
);
1363 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1368 /* Turn GNAT_EXPR into a tree OMP clause representing a reduction clause.
1369 GNAT_EXPR has to be a N_Identifier, this is enforced by the frontend.
1371 For example, GNAT_EXPR could be My_Identifier in the following pragma:
1372 Acc_Parallel(Reduction => ("+" => My_Identifier)). */
1375 Acc_Reduc_Var_to_gnu (Node_Id gnat_expr
, tree gnu_clauses
, void* data
)
1377 const tree_code code
= *((tree_code
*) data
);
1379 = build_omp_clause (EXPR_LOCATION (gnu_loop_stack
->last ()->stmt
),
1380 OMP_CLAUSE_REDUCTION
);
1382 OMP_CLAUSE_DECL (gnu_clause
) = Acc_gnat_to_gnu (gnat_expr
);
1383 OMP_CLAUSE_REDUCTION_CODE (gnu_clause
) = code
;
1384 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1389 /* Turn GNAT_EXPR into a list of OMP reduction clauses. GNAT_EXPR has to
1390 follow the structure of a reduction clause, e.g. ("+" => Identifier). */
1393 Acc_Reduc_to_gnu (Node_Id gnat_expr
)
1395 tree gnu_clauses
= NULL_TREE
;
1397 for (Node_Id gnat_op
= First (Component_Associations (gnat_expr
));
1399 gnat_op
= Next (gnat_op
))
1401 tree_code code
= ERROR_MARK
;
1402 String_Id str
= Strval (First (Choices (gnat_op
)));
1403 switch (Get_String_Char (str
, 1))
1412 if (Get_String_Char (str
, 2) == 'i'
1413 && Get_String_Char (str
, 3) == 'n')
1415 else if (Get_String_Char (str
, 2) == 'a'
1416 && Get_String_Char (str
, 3) == 'x')
1420 if (Get_String_Char (str
, 2) == 'n'
1421 && Get_String_Char (str
, 3) == 'd')
1422 code
= TRUTH_ANDIF_EXPR
;
1425 if (Get_String_Char (str
, 2) == 'r')
1426 code
= TRUTH_ORIF_EXPR
;
1432 /* Unsupported reduction operation. This should have been
1433 caught in sem_prag.adb. */
1434 gcc_assert (code
!= ERROR_MARK
);
1436 gnu_clauses
= Iterate_Acc_Clause_Arg (Expression (gnat_op
),
1438 Acc_Reduc_Var_to_gnu
,
1445 /* Turn GNAT_EXPR, either '*' or an integer literal, into a tree_cons. This is
1446 only used by Acc_Size_List_to_gnu. */
1449 Acc_Size_Expr_to_gnu (Node_Id gnat_expr
, tree gnu_clauses
, void *)
1453 if (Nkind (gnat_expr
) == N_Operator_Symbol
1454 && Get_String_Char (Strval (gnat_expr
), 1) == '*')
1455 gnu_expr
= integer_zero_node
;
1457 gnu_expr
= Acc_gnat_to_gnu (gnat_expr
);
1459 return tree_cons (NULL_TREE
, gnu_expr
, gnu_clauses
);
1462 /* Turn GNAT_EXPR, an aggregate of either '*' or integer literals, into an OMP
1465 This function is used for the Tile clause of the Loop directive. This is
1466 what GNAT_EXPR might look like: (1, 1, '*'). */
1469 Acc_Size_List_to_gnu (Node_Id gnat_expr
)
1472 = build_omp_clause (EXPR_LOCATION (gnu_loop_stack
->last ()->stmt
),
1474 tree gnu_list
= Iterate_Acc_Clause_Arg (gnat_expr
, NULL_TREE
,
1475 Acc_Size_Expr_to_gnu
,
1478 OMP_CLAUSE_TILE_LIST (gnu_clause
) = nreverse (gnu_list
);
1483 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1484 any statements we generate. */
1487 Pragma_to_gnu (Node_Id gnat_node
)
1489 tree gnu_result
= alloc_stmt_list ();
1490 unsigned char pragma_id
;
1493 /* Do nothing if we are just annotating types and check for (and ignore)
1494 unrecognized pragmas. */
1495 if (type_annotate_only
1496 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node
))))
1499 pragma_id
= Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)));
1502 case Pragma_Inspection_Point
:
1503 /* Do nothing at top level: all such variables are already viewable. */
1504 if (global_bindings_p ())
1507 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1508 Present (gnat_temp
);
1509 gnat_temp
= Next (gnat_temp
))
1511 Node_Id gnat_expr
= Expression (gnat_temp
);
1512 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1513 tree asm_constraint
= NULL_TREE
;
1514 #ifdef ASM_COMMENT_START
1517 gnu_expr
= maybe_unconstrained_array (gnu_expr
);
1518 gnat_mark_addressable (gnu_expr
);
1520 #ifdef ASM_COMMENT_START
1521 comment
= concat (ASM_COMMENT_START
,
1522 " inspection point: ",
1523 Get_Name_String (Chars (gnat_expr
)),
1526 asm_constraint
= build_string (strlen (comment
), comment
);
1529 gnu_expr
= build5 (ASM_EXPR
, void_type_node
,
1533 (build_tree_list (NULL_TREE
,
1534 build_string (1, "m")),
1535 gnu_expr
, NULL_TREE
),
1536 NULL_TREE
, NULL_TREE
);
1537 ASM_VOLATILE_P (gnu_expr
) = 1;
1538 set_expr_location_from_node (gnu_expr
, gnat_node
);
1539 append_to_statement_list (gnu_expr
, &gnu_result
);
1543 case Pragma_Acc_Loop
:
1548 tree gnu_clauses
= gnu_loop_stack
->last ()->omp_loop_clauses
;
1550 if (!Present (Pragma_Argument_Associations (gnat_node
)))
1553 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1554 Present (gnat_temp
);
1555 gnat_temp
= Next (gnat_temp
))
1557 Node_Id gnat_expr
= Expression (gnat_temp
);
1558 tree gnu_clause
= NULL_TREE
;
1559 enum omp_clause_code kind
;
1561 if (Chars (gnat_temp
) == No_Name
)
1563 /* The clause is an identifier without a parameter. */
1564 switch (Chars (gnat_expr
))
1567 kind
= OMP_CLAUSE_AUTO
;
1570 kind
= OMP_CLAUSE_GANG
;
1572 case Name_Independent
:
1573 kind
= OMP_CLAUSE_INDEPENDENT
;
1576 kind
= OMP_CLAUSE_SEQ
;
1579 kind
= OMP_CLAUSE_VECTOR
;
1582 kind
= OMP_CLAUSE_WORKER
;
1587 gnu_clause
= build_omp_clause (EXPR_LOCATION
1588 (gnu_loop_stack
->last ()->stmt
),
1593 /* The clause is an identifier parameter(s). */
1594 switch (Chars (gnat_temp
))
1597 gnu_clause
= build_omp_clause
1598 (EXPR_LOCATION (gnu_loop_stack
->last ()->stmt
),
1599 OMP_CLAUSE_COLLAPSE
);
1600 OMP_CLAUSE_COLLAPSE_EXPR (gnu_clause
) =
1601 Acc_gnat_to_gnu (gnat_expr
);
1603 case Name_Device_Type
:
1604 /* Unimplemented by GCC yet. */
1607 case Name_Independent
:
1608 gnu_clause
= build_omp_clause
1609 (EXPR_LOCATION (gnu_loop_stack
->last ()->stmt
),
1610 OMP_CLAUSE_INDEPENDENT
);
1612 case Name_Acc_Private
:
1613 kind
= OMP_CLAUSE_PRIVATE
;
1614 gnu_clause
= Iterate_Acc_Clause_Arg (gnat_expr
, 0,
1618 case Name_Reduction
:
1619 gnu_clause
= Acc_Reduc_to_gnu (gnat_expr
);
1622 gnu_clause
= Acc_Size_List_to_gnu (gnat_expr
);
1627 /* These are for the Loop+Kernel combination, which is
1628 unimplemented by the frontend for now. */
1633 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1634 gnu_clauses
= gnu_clause
;
1636 gnu_loop_stack
->last ()->omp_loop_clauses
= gnu_clauses
;
1640 /* Grouping the transformation of these pragmas together makes sense
1641 because they are mutually exclusive, share most of their clauses and
1642 the verification that each clause can legally appear for the pragma has
1643 been done in the frontend. */
1644 case Pragma_Acc_Data
:
1645 case Pragma_Acc_Kernels
:
1646 case Pragma_Acc_Parallel
:
1651 tree gnu_clauses
= gnu_loop_stack
->last ()->omp_construct_clauses
;
1652 if (pragma_id
== Pragma_Acc_Data
)
1653 gnu_loop_stack
->last ()->omp_code
= OACC_DATA
;
1654 else if (pragma_id
== Pragma_Acc_Kernels
)
1655 gnu_loop_stack
->last ()->omp_code
= OACC_KERNELS
;
1656 else if (pragma_id
== Pragma_Acc_Parallel
)
1657 gnu_loop_stack
->last ()->omp_code
= OACC_PARALLEL
;
1661 if (!Present (Pragma_Argument_Associations (gnat_node
)))
1664 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1665 Present (gnat_temp
);
1666 gnat_temp
= Next (gnat_temp
))
1668 Node_Id gnat_expr
= Expression (gnat_temp
);
1670 enum omp_clause_code clause_code
;
1671 enum gomp_map_kind map_kind
;
1673 switch (Chars (gnat_temp
))
1676 gnu_clause
= build_omp_clause
1677 (EXPR_LOCATION (gnu_loop_stack
->last ()->stmt
),
1679 OMP_CLAUSE_ASYNC_EXPR (gnu_clause
) =
1680 Acc_gnat_to_gnu (gnat_expr
);
1681 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1682 gnu_clauses
= gnu_clause
;
1685 case Name_Num_Gangs
:
1686 gnu_clause
= build_omp_clause
1687 (EXPR_LOCATION (gnu_loop_stack
->last ()->stmt
),
1688 OMP_CLAUSE_NUM_GANGS
);
1689 OMP_CLAUSE_NUM_GANGS_EXPR (gnu_clause
) =
1690 Acc_gnat_to_gnu (gnat_expr
);
1691 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1692 gnu_clauses
= gnu_clause
;
1695 case Name_Num_Workers
:
1696 gnu_clause
= build_omp_clause
1697 (EXPR_LOCATION (gnu_loop_stack
->last ()->stmt
),
1698 OMP_CLAUSE_NUM_WORKERS
);
1699 OMP_CLAUSE_NUM_WORKERS_EXPR (gnu_clause
) =
1700 Acc_gnat_to_gnu (gnat_expr
);
1701 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1702 gnu_clauses
= gnu_clause
;
1705 case Name_Vector_Length
:
1706 gnu_clause
= build_omp_clause
1707 (EXPR_LOCATION (gnu_loop_stack
->last ()->stmt
),
1708 OMP_CLAUSE_VECTOR_LENGTH
);
1709 OMP_CLAUSE_VECTOR_LENGTH_EXPR (gnu_clause
) =
1710 Acc_gnat_to_gnu (gnat_expr
);
1711 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1712 gnu_clauses
= gnu_clause
;
1716 clause_code
= OMP_CLAUSE_WAIT
;
1717 gnu_clauses
= Iterate_Acc_Clause_Arg (gnat_expr
, gnu_clauses
,
1723 gnu_clause
= build_omp_clause (EXPR_LOCATION
1724 (gnu_loop_stack
->last ()->stmt
),
1726 OMP_CLAUSE_IF_MODIFIER (gnu_clause
) = ERROR_MARK
;
1727 OMP_CLAUSE_IF_EXPR (gnu_clause
) = Acc_gnat_to_gnu (gnat_expr
);
1728 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1729 gnu_clauses
= gnu_clause
;
1733 map_kind
= GOMP_MAP_FORCE_TOFROM
;
1734 gnu_clauses
= Iterate_Acc_Clause_Arg (gnat_expr
, gnu_clauses
,
1740 map_kind
= GOMP_MAP_FORCE_TO
;
1741 gnu_clauses
= Iterate_Acc_Clause_Arg (gnat_expr
, gnu_clauses
,
1747 map_kind
= GOMP_MAP_FORCE_FROM
;
1748 gnu_clauses
= Iterate_Acc_Clause_Arg (gnat_expr
, gnu_clauses
,
1754 map_kind
= GOMP_MAP_FORCE_PRESENT
;
1755 gnu_clauses
= Iterate_Acc_Clause_Arg (gnat_expr
, gnu_clauses
,
1761 map_kind
= GOMP_MAP_FORCE_ALLOC
;
1762 gnu_clauses
= Iterate_Acc_Clause_Arg (gnat_expr
, gnu_clauses
,
1767 case Name_Device_Ptr
:
1768 map_kind
= GOMP_MAP_FORCE_DEVICEPTR
;
1769 gnu_clauses
= Iterate_Acc_Clause_Arg (gnat_expr
, gnu_clauses
,
1774 case Name_Acc_Private
:
1775 clause_code
= OMP_CLAUSE_PRIVATE
;
1776 gnu_clauses
= Iterate_Acc_Clause_Arg (gnat_expr
, gnu_clauses
,
1781 case Name_First_Private
:
1782 clause_code
= OMP_CLAUSE_FIRSTPRIVATE
;
1783 gnu_clauses
= Iterate_Acc_Clause_Arg (gnat_expr
, gnu_clauses
,
1789 gnu_clause
= build_omp_clause (EXPR_LOCATION
1790 (gnu_loop_stack
->last ()->stmt
),
1791 OMP_CLAUSE_DEFAULT
);
1792 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1793 /* The standard also accepts "present" but this isn't
1794 implemented in GCC yet. */
1795 OMP_CLAUSE_DEFAULT_KIND (gnu_clause
) = OMP_CLAUSE_DEFAULT_NONE
;
1796 OMP_CLAUSE_CHAIN (gnu_clause
) = gnu_clauses
;
1797 gnu_clauses
= gnu_clause
;
1800 case Name_Reduction
:
1801 gnu_clauses
= Acc_Reduc_to_gnu(gnat_expr
);
1806 case Name_Device_Type
:
1807 /* Unimplemented by GCC. */
1812 gnu_loop_stack
->last ()->omp_construct_clauses
= gnu_clauses
;
1816 case Pragma_Loop_Optimize
:
1817 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1818 Present (gnat_temp
);
1819 gnat_temp
= Next (gnat_temp
))
1821 tree gnu_loop_stmt
= gnu_loop_stack
->last ()->stmt
;
1823 switch (Chars (Expression (gnat_temp
)))
1826 LOOP_STMT_IVDEP (gnu_loop_stmt
) = 1;
1829 case Name_No_Unroll
:
1830 LOOP_STMT_NO_UNROLL (gnu_loop_stmt
) = 1;
1834 LOOP_STMT_UNROLL (gnu_loop_stmt
) = 1;
1837 case Name_No_Vector
:
1838 LOOP_STMT_NO_VECTOR (gnu_loop_stmt
) = 1;
1842 LOOP_STMT_VECTOR (gnu_loop_stmt
) = 1;
1851 case Pragma_Optimize
:
1852 switch (Chars (Expression
1853 (First (Pragma_Argument_Associations (gnat_node
)))))
1857 post_error ("must specify -O0?", gnat_node
);
1862 post_error ("must specify -Os?", gnat_node
);
1867 post_error ("insufficient -O value?", gnat_node
);
1875 case Pragma_Reviewable
:
1876 if (write_symbols
== NO_DEBUG
)
1877 post_error ("must specify -g?", gnat_node
);
1880 case Pragma_Warning_As_Error
:
1881 case Pragma_Warnings
:
1884 /* Preserve the location of the pragma. */
1885 const location_t location
= input_location
;
1886 struct cl_option_handlers handlers
;
1887 unsigned int option_index
;
1891 gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1893 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1894 if (Nkind (Expression (gnat_temp
)) == N_String_Literal
)
1898 case Pragma_Warning_As_Error
:
1903 case Pragma_Warnings
:
1912 gnat_expr
= Expression (gnat_temp
);
1915 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1916 else if (Nkind (Expression (gnat_temp
)) == N_Identifier
)
1918 switch (Chars (Expression (gnat_temp
)))
1932 /* Deal with optional pattern (but ignore Reason => "..."). */
1933 if (Present (Next (gnat_temp
))
1934 && Chars (Next (gnat_temp
)) != Name_Reason
)
1936 /* pragma Warnings (On | Off, Name) is handled differently. */
1937 if (Nkind (Expression (Next (gnat_temp
))) != N_String_Literal
)
1940 gnat_expr
= Expression (Next (gnat_temp
));
1951 /* This is the same implementation as in the C family of compilers. */
1952 const unsigned int lang_mask
= CL_Ada
| CL_COMMON
;
1953 const char *arg
= NULL
;
1954 if (Present (gnat_expr
))
1956 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1957 const char *option_string
= TREE_STRING_POINTER (gnu_expr
);
1958 const int len
= TREE_STRING_LENGTH (gnu_expr
);
1959 if (len
< 3 || option_string
[0] != '-' || option_string
[1] != 'W')
1961 option_index
= find_opt (option_string
+ 1, lang_mask
);
1962 if (option_index
== OPT_SPECIAL_unknown
)
1964 post_error ("?unknown -W switch", gnat_node
);
1967 else if (!(cl_options
[option_index
].flags
& CL_WARNING
))
1969 post_error ("?-W switch does not control warning", gnat_node
);
1972 else if (!(cl_options
[option_index
].flags
& lang_mask
))
1974 post_error ("?-W switch not valid for Ada", gnat_node
);
1977 if (cl_options
[option_index
].flags
& CL_JOINED
)
1978 arg
= option_string
+ 1 + cl_options
[option_index
].opt_len
;
1983 set_default_handlers (&handlers
, NULL
);
1984 control_warning_option (option_index
, (int) kind
, arg
, imply
, location
,
1985 lang_mask
, &handlers
, &global_options
,
1986 &global_options_set
, global_dc
);
1997 /* Check the inline status of nested function FNDECL wrt its parent function.
1999 If a non-inline nested function is referenced from an inline external
2000 function, we cannot honor both requests at the same time without cloning
2001 the nested function in the current unit since it is private to its unit.
2002 We could inline it as well but it's probably better to err on the side
2003 of too little inlining.
2005 This must be done only on nested functions present in the source code
2006 and not on nested functions generated by the compiler, e.g. finalizers,
2007 because they may be not marked inline and we don't want them to block
2008 the inlining of the parent function. */
2011 check_inlining_for_nested_subprog (tree fndecl
)
2013 if (DECL_IGNORED_P (current_function_decl
) || DECL_IGNORED_P (fndecl
))
2016 if (DECL_DECLARED_INLINE_P (fndecl
))
2019 tree parent_decl
= decl_function_context (fndecl
);
2020 if (DECL_EXTERNAL (parent_decl
) && DECL_DECLARED_INLINE_P (parent_decl
))
2022 const location_t loc1
= DECL_SOURCE_LOCATION (fndecl
);
2023 const location_t loc2
= DECL_SOURCE_LOCATION (parent_decl
);
2025 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl
)))
2027 error_at (loc1
, "subprogram %q+F not marked Inline_Always", fndecl
);
2028 error_at (loc2
, "parent subprogram cannot be inlined");
2032 warning_at (loc1
, OPT_Winline
, "subprogram %q+F not marked Inline",
2034 warning_at (loc2
, OPT_Winline
, "parent subprogram cannot be inlined");
2037 DECL_DECLARED_INLINE_P (parent_decl
) = 0;
2038 DECL_UNINLINABLE (parent_decl
) = 1;
2042 /* Return an expression for the length of TYPE, an integral type, computed in
2043 RESULT_TYPE, another integral type.
2045 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
2046 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
2047 which would only overflow in much rarer cases, for extremely large arrays
2048 we expect never to encounter in practice. Besides, the former computation
2049 required the use of potentially constraining signed arithmetics while the
2050 latter does not. Note that the comparison must be done in the original
2051 base index type in order to avoid any overflow during the conversion. */
2054 get_type_length (tree type
, tree result_type
)
2056 tree comp_type
= get_base_type (result_type
);
2057 tree base_type
= maybe_character_type (get_base_type (type
));
2058 tree lb
= convert (base_type
, TYPE_MIN_VALUE (type
));
2059 tree hb
= convert (base_type
, TYPE_MAX_VALUE (type
));
2061 = build_binary_op (PLUS_EXPR
, comp_type
,
2062 build_binary_op (MINUS_EXPR
, comp_type
,
2063 convert (comp_type
, hb
),
2064 convert (comp_type
, lb
)),
2065 build_int_cst (comp_type
, 1));
2067 = build_cond_expr (result_type
,
2068 build_binary_op (GE_EXPR
, boolean_type_node
, hb
, lb
),
2069 convert (result_type
, length
),
2070 build_int_cst (result_type
, 0));
2074 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
2075 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
2076 where we should place the result type. ATTRIBUTE is the attribute ID. */
2079 Attribute_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, int attribute
)
2081 const Node_Id gnat_prefix
= Prefix (gnat_node
);
2082 tree gnu_prefix
= gnat_to_gnu (gnat_prefix
);
2083 tree gnu_type
= TREE_TYPE (gnu_prefix
);
2084 tree gnu_expr
, gnu_result_type
, gnu_result
= error_mark_node
;
2085 bool prefix_unused
= false;
2087 /* If the input is a NULL_EXPR, make a new one. */
2088 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
2090 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2091 *gnu_result_type_p
= gnu_result_type
;
2092 return build1 (NULL_EXPR
, gnu_result_type
, TREE_OPERAND (gnu_prefix
, 0));
2099 /* These are just conversions since representation clauses for
2100 enumeration types are handled in the front-end. */
2101 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2102 if (attribute
== Attr_Pos
)
2103 gnu_expr
= maybe_character_value (gnu_expr
);
2104 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2105 gnu_result
= convert (gnu_result_type
, gnu_expr
);
2110 /* These just add or subtract the constant 1 since representation
2111 clauses for enumeration types are handled in the front-end. */
2112 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2113 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2114 gnu_type
= maybe_character_type (gnu_result_type
);
2115 if (TREE_TYPE (gnu_expr
) != gnu_type
)
2116 gnu_expr
= convert (gnu_type
, gnu_expr
);
2118 = build_binary_op (attribute
== Attr_Pred
? MINUS_EXPR
: PLUS_EXPR
,
2119 gnu_type
, gnu_expr
, build_int_cst (gnu_type
, 1));
2123 case Attr_Unrestricted_Access
:
2124 /* Conversions don't change the address of references but can cause
2125 build_unary_op to miss the references below, so strip them off.
2126 On the contrary, if the address-of operation causes a temporary
2127 to be created, then it must be created with the proper type. */
2128 gnu_expr
= remove_conversions (gnu_prefix
,
2129 !Must_Be_Byte_Aligned (gnat_node
));
2130 if (REFERENCE_CLASS_P (gnu_expr
))
2131 gnu_prefix
= gnu_expr
;
2133 /* If we are taking 'Address of an unconstrained object, this is the
2134 pointer to the underlying array. */
2135 if (attribute
== Attr_Address
)
2136 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
2138 /* If we are building a static dispatch table, we have to honor
2139 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
2140 with the C++ ABI. We do it in the non-static case as well,
2141 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
2142 else if (TARGET_VTABLE_USES_DESCRIPTORS
2143 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
2146 /* Descriptors can only be built here for top-level functions. */
2147 bool build_descriptor
= (global_bindings_p () != 0);
2149 vec
<constructor_elt
, va_gc
> *gnu_vec
= NULL
;
2150 constructor_elt
*elt
;
2152 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2154 /* If we're not going to build the descriptor, we have to retrieve
2155 the one which will be built by the linker (or by the compiler
2156 later if a static chain is requested). */
2157 if (!build_descriptor
)
2159 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_prefix
);
2160 gnu_result
= fold_convert (build_pointer_type (gnu_result_type
),
2162 gnu_result
= build1 (INDIRECT_REF
, gnu_result_type
, gnu_result
);
2165 vec_safe_grow (gnu_vec
, TARGET_VTABLE_USES_DESCRIPTORS
);
2166 elt
= (gnu_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
2167 for (gnu_field
= TYPE_FIELDS (gnu_result_type
), i
= 0;
2168 i
< TARGET_VTABLE_USES_DESCRIPTORS
;
2169 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
2171 if (build_descriptor
)
2173 t
= build2 (FDESC_EXPR
, TREE_TYPE (gnu_field
), gnu_prefix
,
2174 build_int_cst (NULL_TREE
, i
));
2175 TREE_CONSTANT (t
) = 1;
2178 t
= build3 (COMPONENT_REF
, ptr_void_ftype
, gnu_result
,
2179 gnu_field
, NULL_TREE
);
2181 elt
->index
= gnu_field
;
2186 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
2190 /* ... fall through ... */
2193 case Attr_Unchecked_Access
:
2194 case Attr_Code_Address
:
2195 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2197 = build_unary_op (((attribute
== Attr_Address
2198 || attribute
== Attr_Unrestricted_Access
)
2199 && !Must_Be_Byte_Aligned (gnat_node
))
2200 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
2201 gnu_result_type
, gnu_prefix
);
2203 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
2204 don't try to build a trampoline. */
2205 if (attribute
== Attr_Code_Address
)
2207 gnu_expr
= remove_conversions (gnu_result
, false);
2209 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
2210 TREE_NO_TRAMPOLINE (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
2212 /* On targets for which function symbols denote a descriptor, the
2213 code address is stored within the first slot of the descriptor
2214 so we do an additional dereference:
2215 result = *((result_type *) result)
2216 where we expect result to be of some pointer type already. */
2217 if (targetm
.calls
.custom_function_descriptors
== 0)
2219 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
2220 convert (build_pointer_type (gnu_result_type
),
2224 /* For 'Access, issue an error message if the prefix is a C++ method
2225 since it can use a special calling convention on some platforms,
2226 which cannot be propagated to the access type. */
2227 else if (attribute
== Attr_Access
2228 && TREE_CODE (TREE_TYPE (gnu_prefix
)) == METHOD_TYPE
)
2229 post_error ("access to C++ constructor or member function not allowed",
2232 /* For other address attributes applied to a nested function,
2233 find an inner ADDR_EXPR and annotate it so that we can issue
2234 a useful warning with -Wtrampolines. */
2235 else if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_prefix
)))
2237 gnu_expr
= remove_conversions (gnu_result
, false);
2239 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
2240 && decl_function_context (TREE_OPERAND (gnu_expr
, 0)))
2242 set_expr_location_from_node (gnu_expr
, gnat_node
);
2244 /* Also check the inlining status. */
2245 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr
, 0));
2247 /* Moreover, for 'Access or 'Unrestricted_Access with non-
2248 foreign-compatible representation, mark the ADDR_EXPR so
2249 that we can build a descriptor instead of a trampoline. */
2250 if ((attribute
== Attr_Access
2251 || attribute
== Attr_Unrestricted_Access
)
2252 && targetm
.calls
.custom_function_descriptors
> 0
2253 && Can_Use_Internal_Rep (Etype (gnat_node
)))
2254 FUNC_ADDR_BY_DESCRIPTOR (gnu_expr
) = 1;
2256 /* Otherwise, we need to check that we are not violating the
2257 No_Implicit_Dynamic_Code restriction. */
2258 else if (targetm
.calls
.custom_function_descriptors
!= 0)
2259 Check_Implicit_Dynamic_Code_Allowed (gnat_node
);
2264 case Attr_Pool_Address
:
2266 tree gnu_ptr
= gnu_prefix
;
2269 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2271 /* If this is fat pointer, the object must have been allocated with the
2272 template in front of the array. So compute the template address; do
2273 it by converting to a thin pointer. */
2274 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
2276 = convert (build_pointer_type
2277 (TYPE_OBJECT_RECORD_TYPE
2278 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
2281 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
2283 /* If this is a thin pointer, the object must have been allocated with
2284 the template in front of the array. So compute the template address
2286 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
2288 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
2290 fold_build1 (NEGATE_EXPR
, sizetype
,
2293 TYPE_FIELDS ((gnu_obj_type
)))));
2295 gnu_result
= convert (gnu_result_type
, gnu_ptr
);
2300 case Attr_Object_Size
:
2301 case Attr_Value_Size
:
2302 case Attr_Max_Size_In_Storage_Elements
:
2303 gnu_expr
= gnu_prefix
;
2305 /* Remove NOPs and conversions between original and packable version
2306 from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
2307 to see if a COMPONENT_REF was involved. */
2308 while (TREE_CODE (gnu_expr
) == NOP_EXPR
2309 || (TREE_CODE (gnu_expr
) == VIEW_CONVERT_EXPR
2310 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
2311 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
2313 && TYPE_NAME (TREE_TYPE (gnu_expr
))
2314 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))))
2315 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
2317 gnu_prefix
= remove_conversions (gnu_prefix
, true);
2318 prefix_unused
= true;
2319 gnu_type
= TREE_TYPE (gnu_prefix
);
2321 /* Replace an unconstrained array type with the type of the underlying
2322 array, except for 'Max_Size_In_Storage_Elements because we need to
2323 return the (maximum) size requested for an allocator. */
2324 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
2326 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
2327 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
2328 gnu_type
= TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
2331 /* If we're looking for the size of a field, return the field size. */
2332 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2333 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
2335 /* Otherwise, if the prefix is an object, or if we are looking for
2336 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
2337 GCC size of the type. We make an exception for padded objects,
2338 as we do not take into account alignment promotions for the size.
2339 This is in keeping with the object case of gnat_to_gnu_entity. */
2340 else if ((TREE_CODE (gnu_prefix
) != TYPE_DECL
2341 && !(TYPE_IS_PADDING_P (gnu_type
)
2342 && TREE_CODE (gnu_expr
) == COMPONENT_REF
2343 && pad_type_has_rm_size (gnu_type
)))
2344 || attribute
== Attr_Object_Size
2345 || attribute
== Attr_Max_Size_In_Storage_Elements
)
2347 /* If this is a dereference and we have a special dynamic constrained
2348 subtype on the prefix, use it to compute the size; otherwise, use
2349 the designated subtype. */
2350 if (Nkind (gnat_prefix
) == N_Explicit_Dereference
)
2352 Node_Id gnat_actual_subtype
2353 = Actual_Designated_Subtype (gnat_prefix
);
2355 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix
)));
2357 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
)
2358 && Present (gnat_actual_subtype
))
2360 tree gnu_actual_obj_type
2361 = gnat_to_gnu_type (gnat_actual_subtype
);
2363 = build_unc_object_type_from_ptr (gnu_ptr_type
,
2364 gnu_actual_obj_type
,
2365 get_identifier ("SIZE"),
2370 gnu_result
= TYPE_SIZE (gnu_type
);
2373 /* Otherwise, the result is the RM size of the type. */
2375 gnu_result
= rm_size (gnu_type
);
2377 /* Deal with a self-referential size by qualifying the size with the
2378 object or returning the maximum size for a type. */
2379 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
2380 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_expr
);
2381 else if (CONTAINS_PLACEHOLDER_P (gnu_result
))
2382 gnu_result
= max_size (gnu_result
, true);
2384 /* If the type contains a template, subtract the padded size of the
2385 template, except for 'Max_Size_In_Storage_Elements because we need
2386 to return the (maximum) size requested for an allocator. */
2387 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2388 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
2389 && attribute
!= Attr_Max_Size_In_Storage_Elements
)
2391 = size_binop (MINUS_EXPR
, gnu_result
,
2392 bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type
))));
2394 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
2395 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
2396 gnu_result
= size_binop (CEIL_DIV_EXPR
, gnu_result
, bitsize_unit_node
);
2398 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2401 case Attr_Alignment
:
2405 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2406 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
2407 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
2409 gnu_type
= TREE_TYPE (gnu_prefix
);
2410 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2411 prefix_unused
= true;
2413 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2414 align
= DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)) / BITS_PER_UNIT
;
2417 Entity_Id gnat_type
= Etype (gnat_prefix
);
2418 unsigned int double_align
;
2419 bool is_capped_double
, align_clause
;
2421 /* If the default alignment of "double" or larger scalar types is
2422 specifically capped and there is an alignment clause neither
2423 on the type nor on the prefix itself, return the cap. */
2424 if ((double_align
= double_float_alignment
) > 0)
2426 = is_double_float_or_array (gnat_type
, &align_clause
);
2427 else if ((double_align
= double_scalar_alignment
) > 0)
2429 = is_double_scalar_or_array (gnat_type
, &align_clause
);
2431 is_capped_double
= align_clause
= false;
2433 if (is_capped_double
2434 && Nkind (gnat_prefix
) == N_Identifier
2435 && Present (Alignment_Clause (Entity (gnat_prefix
))))
2436 align_clause
= true;
2438 if (is_capped_double
&& !align_clause
)
2439 align
= double_align
;
2441 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
2444 gnu_result
= size_int (align
);
2450 case Attr_Range_Length
:
2451 prefix_unused
= true;
2453 if (INTEGRAL_TYPE_P (gnu_type
) || TREE_CODE (gnu_type
) == REAL_TYPE
)
2455 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2457 if (attribute
== Attr_First
)
2458 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
2459 else if (attribute
== Attr_Last
)
2460 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
2462 gnu_result
= get_type_length (gnu_type
, gnu_result_type
);
2466 /* ... fall through ... */
2470 int Dimension
= (Present (Expressions (gnat_node
))
2471 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
2473 struct parm_attr_d
*pa
= NULL
;
2474 Entity_Id gnat_param
= Empty
;
2475 bool unconstrained_ptr_deref
= false;
2477 /* Make sure any implicit dereference gets done. */
2478 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
2479 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
2481 /* We treat unconstrained array In parameters specially. We also note
2482 whether we are dereferencing a pointer to unconstrained array. */
2483 if (!Is_Constrained (Etype (gnat_prefix
)))
2484 switch (Nkind (gnat_prefix
))
2487 /* This is the direct case. */
2488 if (Ekind (Entity (gnat_prefix
)) == E_In_Parameter
)
2489 gnat_param
= Entity (gnat_prefix
);
2492 case N_Explicit_Dereference
:
2493 /* This is the indirect case. Note that we need to be sure that
2494 the access value cannot be null as we'll hoist the load. */
2495 if (Nkind (Prefix (gnat_prefix
)) == N_Identifier
2496 && Ekind (Entity (Prefix (gnat_prefix
))) == E_In_Parameter
)
2498 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix
))))
2499 gnat_param
= Entity (Prefix (gnat_prefix
));
2502 unconstrained_ptr_deref
= true;
2509 /* If the prefix is the view conversion of a constrained array to an
2510 unconstrained form, we retrieve the constrained array because we
2511 might not be able to substitute the PLACEHOLDER_EXPR coming from
2512 the conversion. This can occur with the 'Old attribute applied
2513 to a parameter with an unconstrained type, which gets rewritten
2514 into a constrained local variable very late in the game. */
2515 if (TREE_CODE (gnu_prefix
) == VIEW_CONVERT_EXPR
2516 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix
)))
2517 && !CONTAINS_PLACEHOLDER_P
2518 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
2519 gnu_type
= TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0));
2521 gnu_type
= TREE_TYPE (gnu_prefix
);
2523 prefix_unused
= true;
2524 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2526 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
2531 for (ndim
= 1, gnu_type_temp
= gnu_type
;
2532 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
2533 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
2534 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
2537 Dimension
= ndim
+ 1 - Dimension
;
2540 for (i
= 1; i
< Dimension
; i
++)
2541 gnu_type
= TREE_TYPE (gnu_type
);
2543 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
2545 /* When not optimizing, look up the slot associated with the parameter
2546 and the dimension in the cache and create a new one on failure.
2547 Don't do this when the actual subtype needs debug info (this happens
2548 with -gnatD): in elaborate_expression_1, we create variables that
2549 hold the bounds, so caching attributes isn't very interesting and
2550 causes dependency issues between these variables and cached
2553 && Present (gnat_param
)
2554 && !(Present (Actual_Subtype (gnat_param
))
2555 && Needs_Debug_Info (Actual_Subtype (gnat_param
))))
2557 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache
, i
, pa
)
2558 if (pa
->id
== gnat_param
&& pa
->dim
== Dimension
)
2563 pa
= ggc_cleared_alloc
<parm_attr_d
> ();
2564 pa
->id
= gnat_param
;
2565 pa
->dim
= Dimension
;
2566 vec_safe_push (f_parm_attr_cache
, pa
);
2570 /* Return the cached expression or build a new one. */
2571 if (attribute
== Attr_First
)
2573 if (pa
&& pa
->first
)
2575 gnu_result
= pa
->first
;
2580 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
2583 else if (attribute
== Attr_Last
)
2587 gnu_result
= pa
->last
;
2592 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
2595 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2597 if (pa
&& pa
->length
)
2599 gnu_result
= pa
->length
;
2604 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)),
2608 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2609 handling. Note that these attributes could not have been used on
2610 an unconstrained array type. */
2611 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
2613 /* Cache the expression we have just computed. Since we want to do it
2614 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2615 create the temporary in the outermost binding level. We will make
2616 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2617 paths by forcing its evaluation on entry of the function. */
2621 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
2625 pa
->first
= gnu_result
;
2629 pa
->last
= gnu_result
;
2633 case Attr_Range_Length
:
2634 pa
->length
= gnu_result
;
2642 /* Otherwise, evaluate it each time it is referenced. */
2648 /* If we are dereferencing a pointer to unconstrained array, we
2649 need to capture the value because the pointed-to bounds may
2650 subsequently be released. */
2651 if (unconstrained_ptr_deref
)
2653 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
2657 case Attr_Range_Length
:
2658 /* Set the source location onto the predicate of the condition
2659 but not if the expression is cached to avoid messing up the
2661 if (TREE_CODE (gnu_result
) == COND_EXPR
2662 && EXPR_P (TREE_OPERAND (gnu_result
, 0)))
2663 set_expr_location_from_node (TREE_OPERAND (gnu_result
, 0),
2674 case Attr_Bit_Position
:
2676 case Attr_First_Bit
:
2683 tree gnu_field_bitpos
;
2684 tree gnu_field_offset
;
2687 int unsignedp
, reversep
, volatilep
;
2689 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2690 gnu_prefix
= remove_conversions (gnu_prefix
, true);
2691 prefix_unused
= true;
2693 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2694 the result is 0. Don't allow 'Bit on a bare component, though. */
2695 if (attribute
== Attr_Bit
2696 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
2697 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
2699 gnu_result
= integer_zero_node
;
2704 gcc_assert (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2705 || (attribute
== Attr_Bit_Position
2706 && TREE_CODE (gnu_prefix
) == FIELD_DECL
));
2708 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
2709 &mode
, &unsignedp
, &reversep
, &volatilep
);
2711 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2713 gnu_field_bitpos
= bit_position (TREE_OPERAND (gnu_prefix
, 1));
2714 gnu_field_offset
= byte_position (TREE_OPERAND (gnu_prefix
, 1));
2716 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
2717 TREE_CODE (gnu_inner
) == COMPONENT_REF
2718 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
2719 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
2722 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
2723 bit_position (TREE_OPERAND (gnu_inner
, 1)));
2725 = size_binop (PLUS_EXPR
, gnu_field_offset
,
2726 byte_position (TREE_OPERAND (gnu_inner
, 1)));
2729 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
2731 gnu_field_bitpos
= bit_position (gnu_prefix
);
2732 gnu_field_offset
= byte_position (gnu_prefix
);
2736 gnu_field_bitpos
= bitsize_zero_node
;
2737 gnu_field_offset
= size_zero_node
;
2743 gnu_result
= gnu_field_offset
;
2746 case Attr_First_Bit
:
2748 gnu_result
= size_int (num_trailing_bits (bitpos
));
2752 gnu_result
= bitsize_int (num_trailing_bits (bitpos
));
2753 gnu_result
= size_binop (PLUS_EXPR
, gnu_result
,
2754 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
2755 /* ??? Avoid a large unsigned result that will overflow when
2756 converted to the signed universal_integer. */
2757 if (integer_zerop (gnu_result
))
2758 gnu_result
= integer_minus_one_node
;
2761 = size_binop (MINUS_EXPR
, gnu_result
, bitsize_one_node
);
2764 case Attr_Bit_Position
:
2765 gnu_result
= gnu_field_bitpos
;
2769 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2771 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
2778 tree gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
2779 tree gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
2781 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2783 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2784 a NaN so we implement the semantics of C99 f{min,max} to make it
2785 predictable in this case: if either operand is a NaN, the other
2786 is returned; if both operands are NaN's, a NaN is returned. */
2787 if (SCALAR_FLOAT_TYPE_P (gnu_result_type
)
2788 && !Machine_Overflows_On_Target
)
2790 const bool lhs_side_effects_p
= TREE_SIDE_EFFECTS (gnu_lhs
);
2791 const bool rhs_side_effects_p
= TREE_SIDE_EFFECTS (gnu_rhs
);
2792 tree t
= builtin_decl_explicit (BUILT_IN_ISNAN
);
2793 tree lhs_is_nan
, rhs_is_nan
;
2795 /* If the operands have side-effects, they need to be evaluated
2796 only once in spite of the multiple references in the result. */
2797 if (lhs_side_effects_p
)
2798 gnu_lhs
= gnat_protect_expr (gnu_lhs
);
2799 if (rhs_side_effects_p
)
2800 gnu_rhs
= gnat_protect_expr (gnu_rhs
);
2802 lhs_is_nan
= fold_build2 (NE_EXPR
, boolean_type_node
,
2803 build_call_expr (t
, 1, gnu_lhs
),
2806 rhs_is_nan
= fold_build2 (NE_EXPR
, boolean_type_node
,
2807 build_call_expr (t
, 1, gnu_rhs
),
2810 gnu_result
= build_binary_op (attribute
== Attr_Min
2811 ? MIN_EXPR
: MAX_EXPR
,
2812 gnu_result_type
, gnu_lhs
, gnu_rhs
);
2813 gnu_result
= fold_build3 (COND_EXPR
, gnu_result_type
,
2814 rhs_is_nan
, gnu_lhs
, gnu_result
);
2815 gnu_result
= fold_build3 (COND_EXPR
, gnu_result_type
,
2816 lhs_is_nan
, gnu_rhs
, gnu_result
);
2818 /* If the operands have side-effects, they need to be evaluated
2819 before doing the tests above since the place they otherwise
2820 would end up being evaluated at run time could be wrong. */
2821 if (lhs_side_effects_p
)
2823 = build2 (COMPOUND_EXPR
, gnu_result_type
, gnu_lhs
, gnu_result
);
2825 if (rhs_side_effects_p
)
2827 = build2 (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs
, gnu_result
);
2830 gnu_result
= build_binary_op (attribute
== Attr_Min
2831 ? MIN_EXPR
: MAX_EXPR
,
2832 gnu_result_type
, gnu_lhs
, gnu_rhs
);
2836 case Attr_Passed_By_Reference
:
2837 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
2838 || must_pass_by_ref (gnu_type
));
2839 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2842 case Attr_Component_Size
:
2843 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2844 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
2845 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
2847 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
2848 gnu_type
= TREE_TYPE (gnu_prefix
);
2850 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
2851 gnu_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
2853 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
2854 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
2855 gnu_type
= TREE_TYPE (gnu_type
);
2857 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
2859 /* Note this size cannot be self-referential. */
2860 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
2861 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2862 prefix_unused
= true;
2865 case Attr_Descriptor_Size
:
2866 gnu_type
= TREE_TYPE (gnu_prefix
);
2867 gcc_assert (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
);
2869 /* Return the padded size of the template in the object record type. */
2870 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
2871 gnu_result
= bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
2872 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2873 prefix_unused
= true;
2876 case Attr_Null_Parameter
:
2877 /* This is just a zero cast to the pointer type for our prefix and
2879 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2881 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
2882 convert (build_pointer_type (gnu_result_type
),
2883 integer_zero_node
));
2884 TREE_PRIVATE (gnu_result
) = 1;
2887 case Attr_Mechanism_Code
:
2889 Entity_Id gnat_obj
= Entity (gnat_prefix
);
2892 prefix_unused
= true;
2893 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2894 if (Present (Expressions (gnat_node
)))
2896 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
2898 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
2899 i
--, gnat_obj
= Next_Formal (gnat_obj
))
2903 code
= Mechanism (gnat_obj
);
2904 if (code
== Default
)
2905 code
= ((present_gnu_tree (gnat_obj
)
2906 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
2907 || ((TREE_CODE (get_gnu_tree (gnat_obj
))
2909 && (DECL_BY_COMPONENT_PTR_P
2910 (get_gnu_tree (gnat_obj
))))))
2911 ? By_Reference
: By_Copy
);
2912 gnu_result
= convert (gnu_result_type
, size_int (- code
));
2917 /* We treat Model as identical to Machine. This is true for at least
2918 IEEE and some other nice floating-point systems. */
2920 /* ... fall through ... */
2923 /* The trick is to force the compiler to store the result in memory so
2924 that we do not have extra precision used. But do this only when this
2925 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2926 the type is lower than that of the longest floating-point type. */
2927 prefix_unused
= true;
2928 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2929 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2930 gnu_result
= convert (gnu_result_type
, gnu_expr
);
2932 if (TREE_CODE (gnu_result
) != REAL_CST
2933 && fp_arith_may_widen
2934 && TYPE_PRECISION (gnu_result_type
)
2935 < TYPE_PRECISION (longest_float_type_node
))
2937 tree rec_type
= make_node (RECORD_TYPE
);
2939 = create_field_decl (get_identifier ("OBJ"), gnu_result_type
,
2940 rec_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2941 tree rec_val
, asm_expr
;
2943 finish_record_type (rec_type
, field
, 0, false);
2945 rec_val
= build_constructor_single (rec_type
, field
, gnu_result
);
2946 rec_val
= build1 (SAVE_EXPR
, rec_type
, rec_val
);
2949 = build5 (ASM_EXPR
, void_type_node
,
2950 build_string (0, ""),
2951 tree_cons (build_tree_list (NULL_TREE
,
2952 build_string (2, "=m")),
2953 rec_val
, NULL_TREE
),
2954 tree_cons (build_tree_list (NULL_TREE
,
2955 build_string (1, "m")),
2956 rec_val
, NULL_TREE
),
2957 NULL_TREE
, NULL_TREE
);
2958 ASM_VOLATILE_P (asm_expr
) = 1;
2961 = build_compound_expr (gnu_result_type
, asm_expr
,
2962 build_component_ref (rec_val
, field
,
2968 prefix_unused
= true;
2969 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2970 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2971 /* This can be a random address so build an alias-all pointer type. */
2973 = convert (build_pointer_type_for_mode (gnu_result_type
, ptr_mode
,
2976 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_expr
);
2980 /* This abort means that we have an unimplemented attribute. */
2984 /* If this is an attribute where the prefix was unused, force a use of it if
2985 it has a side-effect. But don't do it if the prefix is just an entity
2986 name. However, if an access check is needed, we must do it. See second
2987 example in AARM 11.6(5.e). */
2989 && TREE_SIDE_EFFECTS (gnu_prefix
)
2990 && !Is_Entity_Name (gnat_prefix
))
2992 = build_compound_expr (TREE_TYPE (gnu_result
), gnu_prefix
, gnu_result
);
2994 *gnu_result_type_p
= gnu_result_type
;
2998 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2999 to a GCC tree, which is returned. */
3002 Case_Statement_to_gnu (Node_Id gnat_node
)
3004 tree gnu_result
, gnu_expr
, gnu_type
, gnu_label
;
3006 location_t end_locus
;
3007 bool may_fallthru
= false;
3009 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
3010 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
3011 gnu_expr
= maybe_character_value (gnu_expr
);
3012 gnu_type
= TREE_TYPE (gnu_expr
);
3014 /* We build a SWITCH_EXPR that contains the code with interspersed
3015 CASE_LABEL_EXPRs for each label. */
3016 if (!Sloc_to_locus (End_Location (gnat_node
), &end_locus
))
3017 end_locus
= input_location
;
3018 gnu_label
= create_artificial_label (end_locus
);
3019 start_stmt_group ();
3021 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
3022 Present (gnat_when
);
3023 gnat_when
= Next_Non_Pragma (gnat_when
))
3025 bool choices_added_p
= false;
3026 Node_Id gnat_choice
;
3028 /* First compile all the different case choices for the current WHEN
3030 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
3031 Present (gnat_choice
);
3032 gnat_choice
= Next (gnat_choice
))
3034 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
3035 tree label
= create_artificial_label (input_location
);
3037 switch (Nkind (gnat_choice
))
3040 gnu_low
= gnat_to_gnu (Low_Bound (gnat_choice
));
3041 gnu_high
= gnat_to_gnu (High_Bound (gnat_choice
));
3044 case N_Subtype_Indication
:
3045 gnu_low
= gnat_to_gnu (Low_Bound (Range_Expression
3046 (Constraint (gnat_choice
))));
3047 gnu_high
= gnat_to_gnu (High_Bound (Range_Expression
3048 (Constraint (gnat_choice
))));
3052 case N_Expanded_Name
:
3053 /* This represents either a subtype range or a static value of
3054 some kind; Ekind says which. */
3055 if (Is_Type (Entity (gnat_choice
)))
3057 tree gnu_type
= get_unpadded_type (Entity (gnat_choice
));
3059 gnu_low
= TYPE_MIN_VALUE (gnu_type
);
3060 gnu_high
= TYPE_MAX_VALUE (gnu_type
);
3064 /* ... fall through ... */
3066 case N_Character_Literal
:
3067 case N_Integer_Literal
:
3068 gnu_low
= gnat_to_gnu (gnat_choice
);
3071 case N_Others_Choice
:
3078 /* Everything should be folded into constants at this point. */
3079 gcc_assert (!gnu_low
|| TREE_CODE (gnu_low
) == INTEGER_CST
);
3080 gcc_assert (!gnu_high
|| TREE_CODE (gnu_high
) == INTEGER_CST
);
3082 if (gnu_low
&& TREE_TYPE (gnu_low
) != gnu_type
)
3083 gnu_low
= convert (gnu_type
, gnu_low
);
3084 if (gnu_high
&& TREE_TYPE (gnu_high
) != gnu_type
)
3085 gnu_high
= convert (gnu_type
, gnu_high
);
3087 add_stmt_with_node (build_case_label (gnu_low
, gnu_high
, label
),
3089 choices_added_p
= true;
3092 /* This construct doesn't define a scope so we shouldn't push a binding
3093 level around the statement list. Except that we have always done so
3094 historically and this makes it possible to reduce stack usage. As a
3095 compromise, we keep doing it for case statements, for which this has
3096 never been problematic, but not for case expressions in Ada 2012. */
3097 if (choices_added_p
)
3099 const bool is_case_expression
3100 = (Nkind (Parent (gnat_node
)) == N_Expression_With_Actions
);
3102 = build_stmt_group (Statements (gnat_when
), !is_case_expression
);
3103 bool group_may_fallthru
= block_may_fallthru (group
);
3105 if (group_may_fallthru
)
3107 tree stmt
= build1 (GOTO_EXPR
, void_type_node
, gnu_label
);
3108 SET_EXPR_LOCATION (stmt
, end_locus
);
3110 may_fallthru
= true;
3115 /* Now emit a definition of the label the cases branch to, if any. */
3117 add_stmt (build1 (LABEL_EXPR
, void_type_node
, gnu_label
));
3118 gnu_result
= build2 (SWITCH_EXPR
, gnu_type
, gnu_expr
, end_stmt_group ());
3123 /* Return true if we are in the body of a loop. */
3126 inside_loop_p (void)
3128 return !vec_safe_is_empty (gnu_loop_stack
);
3131 /* Find out whether EXPR is a simple additive expression based on the iteration
3132 variable of some enclosing loop in the current function. If so, return the
3133 loop and set *DISP to the displacement and *NEG_P to true if this is for a
3134 subtraction; otherwise, return NULL. */
3136 static struct loop_info_d
*
3137 find_loop_for (tree expr
, tree
*disp
, bool *neg_p
)
3141 struct loop_info_d
*iter
= NULL
;
3144 if (is_simple_additive_expression (expr
, &add
, &cst
, &minus_p
))
3161 var
= remove_conversions (var
, false);
3163 if (TREE_CODE (var
) != VAR_DECL
)
3166 if (decl_function_context (var
) != current_function_decl
)
3169 gcc_assert (vec_safe_length (gnu_loop_stack
) > 0);
3171 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack
, i
, iter
)
3172 if (var
== iter
->loop_var
)
3178 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
3179 false, or the maximum value if MAX is true, of TYPE. */
3182 can_equal_min_or_max_val_p (tree val
, tree type
, bool max
)
3184 tree min_or_max_val
= (max
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
));
3186 if (TREE_CODE (min_or_max_val
) != INTEGER_CST
)
3189 if (TREE_CODE (val
) == NOP_EXPR
)
3191 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0)))
3192 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0))));
3194 if (TREE_CODE (val
) != INTEGER_CST
)
3198 return tree_int_cst_lt (val
, min_or_max_val
) == 0;
3200 return tree_int_cst_lt (min_or_max_val
, val
) == 0;
3203 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
3204 If REVERSE is true, minimum value is taken as maximum value. */
3207 can_equal_min_val_p (tree val
, tree type
, bool reverse
)
3209 return can_equal_min_or_max_val_p (val
, type
, reverse
);
3212 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
3213 If REVERSE is true, maximum value is taken as minimum value. */
3216 can_equal_max_val_p (tree val
, tree type
, bool reverse
)
3218 return can_equal_min_or_max_val_p (val
, type
, !reverse
);
3221 /* Return true if VAL1 can be lower than VAL2. */
3224 can_be_lower_p (tree val1
, tree val2
)
3226 if (TREE_CODE (val1
) == NOP_EXPR
)
3228 tree type
= TREE_TYPE (TREE_OPERAND (val1
, 0));
3229 if (can_be_lower_p (TYPE_MAX_VALUE (type
), TYPE_MIN_VALUE (type
)))
3232 val1
= TYPE_MIN_VALUE (type
);
3235 if (TREE_CODE (val1
) != INTEGER_CST
)
3238 if (TREE_CODE (val2
) == NOP_EXPR
)
3240 tree type
= TREE_TYPE (TREE_OPERAND (val2
, 0));
3241 if (can_be_lower_p (TYPE_MAX_VALUE (type
), TYPE_MIN_VALUE (type
)))
3244 val2
= TYPE_MAX_VALUE (type
);
3247 if (TREE_CODE (val2
) != INTEGER_CST
)
3250 return tree_int_cst_lt (val1
, val2
);
3253 /* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
3254 true if both expressions have been replaced and false otherwise. */
3257 make_invariant (tree
*expr1
, tree
*expr2
)
3259 tree inv_expr1
= gnat_invariant_expr (*expr1
);
3260 tree inv_expr2
= gnat_invariant_expr (*expr2
);
3268 return inv_expr1
&& inv_expr2
;
3271 /* Helper function for walk_tree, used by independent_iterations_p below. */
3274 scan_rhs_r (tree
*tp
, int *walk_subtrees
, void *data
)
3276 bitmap
*params
= (bitmap
*)data
;
3279 /* No need to walk into types or decls. */
3280 if (IS_TYPE_OR_DECL_P (t
))
3283 if (TREE_CODE (t
) == PARM_DECL
&& bitmap_bit_p (*params
, DECL_UID (t
)))
3289 /* Return true if STMT_LIST generates independent iterations in a loop. */
3292 independent_iterations_p (tree stmt_list
)
3294 tree_stmt_iterator tsi
;
3295 bitmap params
= BITMAP_GGC_ALLOC();
3300 if (TREE_CODE (stmt_list
) == BIND_EXPR
)
3301 stmt_list
= BIND_EXPR_BODY (stmt_list
);
3303 /* Scan the list and return false on anything that is not either a check
3304 or an assignment to a parameter with restricted aliasing. */
3305 for (tsi
= tsi_start (stmt_list
); !tsi_end_p (tsi
); tsi_next (&tsi
))
3307 tree stmt
= tsi_stmt (tsi
);
3309 switch (TREE_CODE (stmt
))
3313 if (COND_EXPR_ELSE (stmt
))
3315 if (TREE_CODE (COND_EXPR_THEN (stmt
)) != CALL_EXPR
)
3317 tree func
= get_callee_fndecl (COND_EXPR_THEN (stmt
));
3318 if (!(func
&& TREE_THIS_VOLATILE (func
)))
3325 tree lhs
= TREE_OPERAND (stmt
, 0);
3326 while (handled_component_p (lhs
))
3327 lhs
= TREE_OPERAND (lhs
, 0);
3328 if (TREE_CODE (lhs
) != INDIRECT_REF
)
3330 lhs
= TREE_OPERAND (lhs
, 0);
3331 if (!(TREE_CODE (lhs
) == PARM_DECL
3332 && DECL_RESTRICTED_ALIASING_P (lhs
)))
3334 bitmap_set_bit (params
, DECL_UID (lhs
));
3335 rhs
.safe_push (TREE_OPERAND (stmt
, 1));
3344 /* At this point we know that the list contains only statements that will
3345 modify parameters with restricted aliasing. Check that the statements
3346 don't at the time read from these parameters. */
3347 FOR_EACH_VEC_ELT (rhs
, i
, iter
)
3348 if (walk_tree_without_duplicates (&iter
, scan_rhs_r
, ¶ms
))
3354 /* Helper for Loop_Statement_to_gnu to translate the body of a loop,
3355 designated by GNAT_LOOP, to which an Acc_Loop pragma applies. The pragma
3356 arguments might instruct us to collapse a nest of loops, where computation
3357 statements are expected only within the innermost loop, as in:
3359 for I in 1 .. 5 loop
3360 pragma Acc_Parallel;
3361 pragma Acc_Loop(Collapse => 3);
3362 for J in 1 .. 8 loop
3363 for K in 1 .. 4 loop
3364 X (I, J, K) := Y (I, J, K) + 2;
3369 We expect the top of gnu_loop_stack to hold a pointer to the loop info
3370 setup for the translation of GNAT_LOOP, which holds a pointer to the
3371 initial gnu loop stmt node. We return the new gnu loop statement to
3375 Acc_Loop_to_gnu (Node_Id gnat_loop
)
3377 const struct loop_info_d
* const gnu_loop_info
= gnu_loop_stack
->last ();
3378 tree gnu_loop_stmt
= gnu_loop_info
->stmt
;
3380 tree acc_loop
= make_node (OACC_LOOP
);
3381 tree acc_bind_expr
= NULL_TREE
;
3382 Node_Id cur_loop
= gnat_loop
;
3383 int collapse_count
= 1;
3388 /* Parse the pragmas, adding clauses to the current gnu_loop_stack through
3390 for (Node_Id tmp
= First (Statements (gnat_loop
));
3391 Present (tmp
) && Nkind (tmp
) == N_Pragma
;
3395 /* Find the number of loops that should be collapsed. */
3396 for (tree tmp
= gnu_loop_stack
->last ()->omp_loop_clauses
; tmp
;
3397 tmp
= OMP_CLAUSE_CHAIN (tmp
))
3398 if (OMP_CLAUSE_CODE (tmp
) == OMP_CLAUSE_COLLAPSE
)
3399 collapse_count
= tree_to_shwi (OMP_CLAUSE_COLLAPSE_EXPR (tmp
));
3400 else if (OMP_CLAUSE_CODE (tmp
) == OMP_CLAUSE_TILE
)
3401 collapse_count
= list_length (OMP_CLAUSE_TILE_LIST (tmp
));
3403 initv
= make_tree_vec (collapse_count
);
3404 condv
= make_tree_vec (collapse_count
);
3405 incrv
= make_tree_vec (collapse_count
);
3407 start_stmt_group ();
3410 /* For each nested loop that should be collapsed ... */
3411 for (int count
= 0; count
< collapse_count
; ++count
)
3414 Loop_Parameter_Specification (Iteration_Scheme (cur_loop
));
3416 Acc_gnat_to_gnu (Low_Bound (Discrete_Subtype_Definition (lps
)));
3418 Acc_gnat_to_gnu (High_Bound (Discrete_Subtype_Definition (lps
)));
3420 gnat_to_gnu_entity (Defining_Identifier (lps
), NULL_TREE
, true);
3422 /* Build the initial value of the variable of the invariant. */
3423 TREE_VEC_ELT (initv
, count
) = build2 (MODIFY_EXPR
,
3424 TREE_TYPE (variable
),
3427 add_stmt (TREE_VEC_ELT (initv
, count
));
3429 /* Build the invariant of the loop. */
3430 TREE_VEC_ELT (condv
, count
) = build2 (LE_EXPR
,
3435 /* Build the incrementation expression of the loop. */
3436 TREE_VEC_ELT (incrv
, count
) =
3437 build2 (MODIFY_EXPR
,
3438 TREE_TYPE (variable
),
3441 TREE_TYPE (variable
),
3443 build_int_cst (TREE_TYPE (variable
), 1)));
3445 /* Don't process the innermost loop because its statements belong to
3446 another statement group. */
3447 if (count
< collapse_count
- 1)
3448 /* Process the current loop's body. */
3449 for (Node_Id stmt
= First (Statements (cur_loop
));
3450 Present (stmt
); stmt
= Next (stmt
))
3452 /* If we are processsing the outermost loop, it is ok for it to
3454 if (Nkind (stmt
) == N_Pragma
&& count
== 0)
3456 /* The frontend might have inserted a N_Object_Declaration in the
3457 loop's body to declare the iteration variable of the next loop.
3458 It will need to be hoisted before the collapsed loops. */
3459 else if (Nkind (stmt
) == N_Object_Declaration
)
3460 Acc_gnat_to_gnu (stmt
);
3461 else if (Nkind (stmt
) == N_Loop_Statement
)
3463 /* Every other kind of statement is prohibited in collapsed
3465 else if (count
< collapse_count
- 1)
3470 acc_bind_expr
= end_stmt_group ();
3472 /* Parse the innermost loop. */
3474 for (Node_Id stmt
= First (Statements (cur_loop
));
3478 /* When the innermost loop is the only loop, do not parse the pragmas
3480 if (Nkind (stmt
) == N_Pragma
&& collapse_count
== 1)
3482 add_stmt (Acc_gnat_to_gnu (stmt
));
3485 TREE_TYPE (acc_loop
) = void_type_node
;
3486 OMP_FOR_INIT (acc_loop
) = initv
;
3487 OMP_FOR_COND (acc_loop
) = condv
;
3488 OMP_FOR_INCR (acc_loop
) = incrv
;
3489 OMP_FOR_BODY (acc_loop
) = end_stmt_group ();
3490 OMP_FOR_PRE_BODY (acc_loop
) = NULL
;
3491 OMP_FOR_ORIG_DECLS (acc_loop
) = NULL
;
3492 OMP_FOR_CLAUSES (acc_loop
) = gnu_loop_stack
->last ()->omp_loop_clauses
;
3494 BIND_EXPR_BODY (acc_bind_expr
) = acc_loop
;
3496 return gnu_loop_stmt
;
3499 /* Helper for Loop_Statement_to_gnu, to translate the body of a loop not
3500 subject to any sort of parallelization directive or restriction, designated
3503 We expect the top of gnu_loop_stack to hold a pointer to the loop info
3504 setup for the translation, which holds a pointer to the initial gnu loop
3505 stmt node. We return the new gnu loop statement to use.
3507 We might also set *GNU_COND_EXPR_P to request a variant of the translation
3508 scheme in Loop_Statement_to_gnu. */
3511 Regular_Loop_to_gnu (Node_Id gnat_node
, tree
*gnu_cond_expr_p
)
3513 const Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
3514 struct loop_info_d
*const gnu_loop_info
= gnu_loop_stack
->last ();
3515 tree gnu_loop_stmt
= gnu_loop_info
->stmt
;
3516 tree gnu_loop_label
= LOOP_STMT_LABEL (gnu_loop_stmt
);
3517 tree gnu_cond_expr
= *gnu_cond_expr_p
;
3518 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
3520 /* Set the condition under which the loop must keep going. If we have an
3521 explicit condition, use it to set the location information throughout
3522 the translation of the loop statement to avoid having multiple SLOCs.
3524 For the case "LOOP .... END LOOP;" the condition is always true. */
3525 if (No (gnat_iter_scheme
))
3528 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
3529 else if (Present (Condition (gnat_iter_scheme
)))
3531 LOOP_STMT_COND (gnu_loop_stmt
)
3532 = gnat_to_gnu (Condition (gnat_iter_scheme
));
3534 set_expr_location_from_node (gnu_loop_stmt
, gnat_iter_scheme
);
3537 /* Otherwise we have an iteration scheme and the condition is given by the
3538 bounds of the subtype of the iteration variable. */
3541 Node_Id gnat_loop_spec
= Loop_Parameter_Specification (gnat_iter_scheme
);
3542 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
3543 Entity_Id gnat_type
= Etype (gnat_loop_var
);
3544 tree gnu_type
= get_unpadded_type (gnat_type
);
3545 tree gnu_base_type
= maybe_character_type (get_base_type (gnu_type
));
3546 tree gnu_one_node
= build_int_cst (gnu_base_type
, 1);
3547 tree gnu_loop_var
, gnu_loop_iv
, gnu_first
, gnu_last
, gnu_stmt
;
3548 enum tree_code update_code
, test_code
, shift_code
;
3549 bool reverse
= Reverse_Present (gnat_loop_spec
), use_iv
= false;
3551 gnu_low
= convert (gnu_base_type
, TYPE_MIN_VALUE (gnu_type
));
3552 gnu_high
= convert (gnu_base_type
, TYPE_MAX_VALUE (gnu_type
));
3554 /* We must disable modulo reduction for the iteration variable, if any,
3555 in order for the loop comparison to be effective. */
3558 gnu_first
= gnu_high
;
3560 update_code
= MINUS_NOMOD_EXPR
;
3561 test_code
= GE_EXPR
;
3562 shift_code
= PLUS_NOMOD_EXPR
;
3566 gnu_first
= gnu_low
;
3567 gnu_last
= gnu_high
;
3568 update_code
= PLUS_NOMOD_EXPR
;
3569 test_code
= LE_EXPR
;
3570 shift_code
= MINUS_NOMOD_EXPR
;
3573 /* We use two different strategies to translate the loop, depending on
3574 whether optimization is enabled.
3576 If it is, we generate the canonical loop form expected by the loop
3577 optimizer and the loop vectorizer, which is the do-while form:
3586 This avoids an implicit dependency on loop header copying and makes
3587 it possible to turn BOTTOM_COND into an inequality test.
3589 If optimization is disabled, loop header copying doesn't come into
3590 play and we try to generate the loop form with the fewer conditional
3591 branches. First, the default form, which is:
3599 It should catch most loops with constant ending point. Then, if we
3600 cannot, we try to generate the shifted form:
3608 which should catch loops with constant starting point. Otherwise, if
3609 we cannot, we generate the fallback form:
3618 which works in all cases. */
3622 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
3624 if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
))
3627 /* Otherwise, use the do-while form with the help of a special
3628 induction variable in the unsigned version of the base type
3629 or the unsigned version of the size type, whichever is the
3630 largest, in order to have wrap-around arithmetics for it. */
3633 if (TYPE_PRECISION (gnu_base_type
)
3634 > TYPE_PRECISION (size_type_node
))
3636 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type
), 1);
3638 gnu_base_type
= size_type_node
;
3640 gnu_first
= convert (gnu_base_type
, gnu_first
);
3641 gnu_last
= convert (gnu_base_type
, gnu_last
);
3642 gnu_one_node
= build_int_cst (gnu_base_type
, 1);
3647 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
3649 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
3650 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
3654 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
3655 if (!can_equal_max_val_p (gnu_last
, gnu_base_type
, reverse
))
3658 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
3660 else if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
)
3661 && !can_equal_min_val_p (gnu_last
, gnu_base_type
, reverse
))
3664 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
3667 = build_binary_op (shift_code
, gnu_base_type
, gnu_last
,
3669 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
3672 /* Otherwise, use the fallback form. */
3674 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
3677 /* If we use the BOTTOM_COND, we can turn the test into an inequality
3678 test but we may have to add ENTRY_COND to protect the empty loop. */
3679 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
))
3681 test_code
= NE_EXPR
;
3682 if (can_be_lower_p (gnu_high
, gnu_low
))
3685 = build3 (COND_EXPR
, void_type_node
,
3686 build_binary_op (LE_EXPR
, boolean_type_node
,
3688 NULL_TREE
, alloc_stmt_list ());
3689 set_expr_location_from_node (gnu_cond_expr
, gnat_iter_scheme
);
3693 /* Open a new nesting level that will surround the loop to declare the
3694 iteration variable. */
3695 start_stmt_group ();
3698 /* If we use the special induction variable, create it and set it to
3699 its initial value. Morever, the regular iteration variable cannot
3700 itself be initialized, lest the initial value wrapped around. */
3704 = create_init_temporary ("I", gnu_first
, &gnu_stmt
, gnat_loop_var
);
3705 add_stmt (gnu_stmt
);
3706 gnu_first
= NULL_TREE
;
3709 gnu_loop_iv
= NULL_TREE
;
3711 /* Declare the iteration variable and set it to its initial value. */
3712 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, true);
3713 if (DECL_BY_REF_P (gnu_loop_var
))
3714 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_loop_var
);
3717 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var
));
3718 SET_DECL_INDUCTION_VAR (gnu_loop_var
, gnu_loop_iv
);
3720 gnu_loop_info
->loop_var
= gnu_loop_var
;
3721 gnu_loop_info
->low_bound
= gnu_low
;
3722 gnu_loop_info
->high_bound
= gnu_high
;
3724 /* Do all the arithmetics in the base type. */
3725 gnu_loop_var
= convert (gnu_base_type
, gnu_loop_var
);
3727 /* Set either the top or bottom exit condition. */
3729 LOOP_STMT_COND (gnu_loop_stmt
)
3730 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_iv
,
3733 LOOP_STMT_COND (gnu_loop_stmt
)
3734 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_var
,
3737 /* Set either the top or bottom update statement and give it the source
3738 location of the iteration for better coverage info. */
3742 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_iv
,
3743 build_binary_op (update_code
, gnu_base_type
,
3744 gnu_loop_iv
, gnu_one_node
));
3745 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3746 append_to_statement_list (gnu_stmt
,
3747 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
3749 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
3751 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3752 append_to_statement_list (gnu_stmt
,
3753 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
3758 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
3759 build_binary_op (update_code
, gnu_base_type
,
3760 gnu_loop_var
, gnu_one_node
));
3761 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3762 LOOP_STMT_UPDATE (gnu_loop_stmt
) = gnu_stmt
;
3765 set_expr_location_from_node (gnu_loop_stmt
, gnat_iter_scheme
);
3768 /* If the loop was named, have the name point to this loop. In this case,
3769 the association is not a DECL node, but the end label of the loop. */
3770 if (Present (Identifier (gnat_node
)))
3771 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_label
, true);
3773 /* Make the loop body into its own block, so any allocated storage will be
3774 released every iteration. This is needed for stack allocation. */
3775 LOOP_STMT_BODY (gnu_loop_stmt
)
3776 = build_stmt_group (Statements (gnat_node
), true);
3777 TREE_SIDE_EFFECTS (gnu_loop_stmt
) = 1;
3779 /* If we have an iteration scheme, then we are in a statement group. Add
3780 the LOOP_STMT to it, finish it and make it the "loop". */
3781 if (Present (gnat_iter_scheme
) && No (Condition (gnat_iter_scheme
)))
3783 /* First, if we have computed invariant conditions for range (or index)
3784 checks applied to the iteration variable, find out whether they can
3785 be evaluated to false at compile time; otherwise, if there are not
3786 too many of them, combine them with the original checks. If loop
3787 unswitching is enabled, do not require the loop bounds to be also
3788 invariant, as their evaluation will still be ahead of the loop. */
3789 if (vec_safe_length (gnu_loop_info
->checks
) > 0
3790 && (make_invariant (&gnu_low
, &gnu_high
) || optimize
>= 3))
3792 struct range_check_info_d
*rci
;
3793 unsigned int i
, n_remaining_checks
= 0;
3795 FOR_EACH_VEC_ELT (*gnu_loop_info
->checks
, i
, rci
)
3797 tree low_ok
, high_ok
;
3801 tree gnu_adjusted_low
= convert (rci
->type
, gnu_low
);
3804 = fold_build2 (rci
->neg_p
? MINUS_EXPR
: PLUS_EXPR
,
3805 rci
->type
, gnu_adjusted_low
, rci
->disp
);
3807 = build_binary_op (GE_EXPR
, boolean_type_node
,
3808 gnu_adjusted_low
, rci
->low_bound
);
3811 low_ok
= boolean_true_node
;
3813 if (rci
->high_bound
)
3815 tree gnu_adjusted_high
= convert (rci
->type
, gnu_high
);
3818 = fold_build2 (rci
->neg_p
? MINUS_EXPR
: PLUS_EXPR
,
3819 rci
->type
, gnu_adjusted_high
, rci
->disp
);
3821 = build_binary_op (LE_EXPR
, boolean_type_node
,
3822 gnu_adjusted_high
, rci
->high_bound
);
3825 high_ok
= boolean_true_node
;
3828 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
3832 = build_unary_op (TRUTH_NOT_EXPR
, boolean_type_node
, range_ok
);
3834 if (rci
->invariant_cond
== boolean_false_node
)
3835 TREE_OPERAND (rci
->inserted_cond
, 0) = rci
->invariant_cond
;
3837 n_remaining_checks
++;
3840 /* Note that loop unswitching can only be applied a small number of
3841 times to a given loop (PARAM_MAX_UNSWITCH_LEVEL default to 3). */
3842 if (IN_RANGE (n_remaining_checks
, 1, 3)
3845 FOR_EACH_VEC_ELT (*gnu_loop_info
->checks
, i
, rci
)
3846 if (rci
->invariant_cond
!= boolean_false_node
)
3848 TREE_OPERAND (rci
->inserted_cond
, 0) = rci
->invariant_cond
;
3851 add_stmt_with_node_force (rci
->inserted_cond
, gnat_node
);
3855 /* Second, if loop vectorization is enabled and the iterations of the
3856 loop can easily be proved as independent, mark the loop. */
3858 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt
)))
3859 LOOP_STMT_IVDEP (gnu_loop_stmt
) = 1;
3861 add_stmt (gnu_loop_stmt
);
3863 gnu_loop_stmt
= end_stmt_group ();
3866 *gnu_cond_expr_p
= gnu_cond_expr
;
3868 return gnu_loop_stmt
;
3871 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
3872 to a GCC tree, which is returned. */
3875 Loop_Statement_to_gnu (Node_Id gnat_node
)
3877 struct loop_info_d
*gnu_loop_info
= ggc_cleared_alloc
<loop_info_d
> ();
3879 tree gnu_loop_stmt
= build4 (LOOP_STMT
, void_type_node
, NULL_TREE
,
3880 NULL_TREE
, NULL_TREE
, NULL_TREE
);
3881 tree gnu_cond_expr
= NULL_TREE
;
3882 tree gnu_loop_label
= create_artificial_label (input_location
);
3885 /* Push the loop_info structure associated with the LOOP_STMT. */
3886 vec_safe_push (gnu_loop_stack
, gnu_loop_info
);
3888 /* Set location information for statement and end label. */
3889 set_expr_location_from_node (gnu_loop_stmt
, gnat_node
);
3890 Sloc_to_locus (Sloc (End_Label (gnat_node
)),
3891 &DECL_SOURCE_LOCATION (gnu_loop_label
));
3892 LOOP_STMT_LABEL (gnu_loop_stmt
) = gnu_loop_label
;
3894 /* Save the statement for later reuse. */
3895 gnu_loop_info
->stmt
= gnu_loop_stmt
;
3897 /* Perform the core loop body translation. */
3898 if (Is_OpenAcc_Loop (gnat_node
))
3899 gnu_loop_stmt
= Acc_Loop_to_gnu (gnat_node
);
3901 gnu_loop_stmt
= Regular_Loop_to_gnu (gnat_node
, &gnu_cond_expr
);
3903 /* A gnat_node that has its OpenAcc_Environment flag set needs to be
3904 offloaded. Note that the OpenAcc_Loop flag is not necessarily set. */
3905 if (Is_OpenAcc_Environment (gnat_node
))
3907 tree_code code
= gnu_loop_stack
->last ()->omp_code
;
3908 tree tmp
= make_node (code
);
3909 TREE_TYPE (tmp
) = void_type_node
;
3910 if (code
== OACC_PARALLEL
|| code
== OACC_KERNELS
)
3912 OMP_BODY (tmp
) = gnu_loop_stmt
;
3913 OMP_CLAUSES (tmp
) = gnu_loop_stack
->last ()->omp_construct_clauses
;
3915 else if (code
== OACC_DATA
)
3917 OACC_DATA_BODY (tmp
) = gnu_loop_stmt
;
3918 OACC_DATA_CLAUSES (tmp
) =
3919 gnu_loop_stack
->last ()->omp_construct_clauses
;
3923 set_expr_location_from_node (tmp
, gnat_node
);
3924 gnu_loop_stmt
= tmp
;
3927 /* If we have an outer COND_EXPR, that's our result and this loop is its
3928 "true" statement. Otherwise, the result is the LOOP_STMT. */
3931 COND_EXPR_THEN (gnu_cond_expr
) = gnu_loop_stmt
;
3932 TREE_SIDE_EFFECTS (gnu_cond_expr
) = 1;
3933 gnu_result
= gnu_cond_expr
;
3936 gnu_result
= gnu_loop_stmt
;
3938 gnu_loop_stack
->pop ();
3943 /* This page implements a form of Named Return Value optimization modelled
3944 on the C++ optimization of the same name. The main difference is that
3945 we disregard any semantical considerations when applying it here, the
3946 counterpart being that we don't try to apply it to semantically loaded
3947 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3949 We consider a function body of the following GENERIC form:
3953 RETURN_EXPR [<retval> = ...]
3955 RETURN_EXPR [<retval> = R1]
3959 RETURN_EXPR [<retval> = ...]
3961 RETURN_EXPR [<retval> = Ri]
3964 where the Ri are not addressable and we try to fulfill a simple criterion
3965 that would make it possible to replace one or several Ri variables by the
3966 single RESULT_DECL of the function.
3968 The first observation is that RETURN_EXPRs that don't directly reference
3969 any of the Ri variables on the RHS of their assignment are transparent wrt
3970 the optimization. This is because the Ri variables aren't addressable so
3971 any transformation applied to them doesn't affect the RHS; moreover, the
3972 assignment writes the full <retval> object so existing values are entirely
3975 This property can be extended to some forms of RETURN_EXPRs that reference
3976 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3977 case, in particular when function calls are involved.
3979 Therefore the algorithm is as follows:
3981 1. Collect the list of candidates for a Named Return Value (Ri variables
3982 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3983 other expressions on the RHS of such assignments.
3985 2. Prune the members of the first list (candidates) that are referenced
3986 by a member of the second list (expressions).
3988 3. Extract a set of candidates with non-overlapping live ranges from the
3989 first list. These are the Named Return Values.
3991 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3992 Named Return Values in the function with the RESULT_DECL.
3994 If the function returns an unconstrained type, things are a bit different
3995 because the anonymous return object is allocated on the secondary stack
3996 and RESULT_DECL is only a pointer to it. Each return object can be of a
3997 different size and is allocated separately so we need not care about the
3998 addressability and the aforementioned overlapping issues. Therefore, we
3999 don't collect the other expressions and skip step #2 in the algorithm. */
4006 hash_set
<tree
> *visited
;
4009 /* Return true if T is a Named Return Value. */
4012 is_nrv_p (bitmap nrv
, tree t
)
4014 return TREE_CODE (t
) == VAR_DECL
&& bitmap_bit_p (nrv
, DECL_UID (t
));
4017 /* Helper function for walk_tree, used by finalize_nrv below. */
4020 prune_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
4022 struct nrv_data
*dp
= (struct nrv_data
*)data
;
4025 /* No need to walk into types or decls. */
4026 if (IS_TYPE_OR_DECL_P (t
))
4029 if (is_nrv_p (dp
->nrv
, t
))
4030 bitmap_clear_bit (dp
->nrv
, DECL_UID (t
));
4035 /* Prune Named Return Values in BLOCK and return true if there is still a
4036 Named Return Value in BLOCK or one of its sub-blocks. */
4039 prune_nrv_in_block (bitmap nrv
, tree block
)
4041 bool has_nrv
= false;
4044 /* First recurse on the sub-blocks. */
4045 for (t
= BLOCK_SUBBLOCKS (block
); t
; t
= BLOCK_CHAIN (t
))
4046 has_nrv
|= prune_nrv_in_block (nrv
, t
);
4048 /* Then make sure to keep at most one NRV per block. */
4049 for (t
= BLOCK_VARS (block
); t
; t
= DECL_CHAIN (t
))
4050 if (is_nrv_p (nrv
, t
))
4053 bitmap_clear_bit (nrv
, DECL_UID (t
));
4061 /* Helper function for walk_tree, used by finalize_nrv below. */
4064 finalize_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
4066 struct nrv_data
*dp
= (struct nrv_data
*)data
;
4069 /* No need to walk into types. */
4073 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
4074 nop, but differs from using NULL_TREE in that it indicates that we care
4075 about the value of the RESULT_DECL. */
4076 else if (TREE_CODE (t
) == RETURN_EXPR
4077 && TREE_CODE (TREE_OPERAND (t
, 0)) == INIT_EXPR
)
4079 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1);
4081 /* Strip useless conversions around the return value. */
4082 if (gnat_useless_type_conversion (ret_val
))
4083 ret_val
= TREE_OPERAND (ret_val
, 0);
4085 if (is_nrv_p (dp
->nrv
, ret_val
))
4086 TREE_OPERAND (t
, 0) = dp
->result
;
4089 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
4091 else if (TREE_CODE (t
) == DECL_EXPR
4092 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
4094 tree var
= DECL_EXPR_DECL (t
), init
;
4096 if (DECL_INITIAL (var
))
4098 init
= build_binary_op (INIT_EXPR
, NULL_TREE
, dp
->result
,
4099 DECL_INITIAL (var
));
4100 SET_EXPR_LOCATION (init
, EXPR_LOCATION (t
));
4101 DECL_INITIAL (var
) = NULL_TREE
;
4104 init
= build_empty_stmt (EXPR_LOCATION (t
));
4107 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
4108 SET_DECL_VALUE_EXPR (var
, dp
->result
);
4109 DECL_HAS_VALUE_EXPR_P (var
) = 1;
4110 /* ??? Kludge to avoid an assertion failure during inlining. */
4111 DECL_SIZE (var
) = bitsize_unit_node
;
4112 DECL_SIZE_UNIT (var
) = size_one_node
;
4115 /* And replace all uses of NRVs with the RESULT_DECL. */
4116 else if (is_nrv_p (dp
->nrv
, t
))
4117 *tp
= convert (TREE_TYPE (t
), dp
->result
);
4119 /* Avoid walking into the same tree more than once. Unfortunately, we
4120 can't just use walk_tree_without_duplicates because it would only
4121 call us for the first occurrence of NRVs in the function body. */
4122 if (dp
->visited
->add (*tp
))
4128 /* Likewise, but used when the function returns an unconstrained type. */
4131 finalize_nrv_unc_r (tree
*tp
, int *walk_subtrees
, void *data
)
4133 struct nrv_data
*dp
= (struct nrv_data
*)data
;
4136 /* No need to walk into types. */
4140 /* We need to see the DECL_EXPR of NRVs before any other references so we
4141 walk the body of BIND_EXPR before walking its variables. */
4142 else if (TREE_CODE (t
) == BIND_EXPR
)
4143 walk_tree (&BIND_EXPR_BODY (t
), finalize_nrv_unc_r
, data
, NULL
);
4145 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
4146 return value built by the allocator instead of the whole construct. */
4147 else if (TREE_CODE (t
) == RETURN_EXPR
4148 && TREE_CODE (TREE_OPERAND (t
, 0)) == INIT_EXPR
)
4150 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1);
4152 /* This is the construct returned by the allocator. */
4153 if (TREE_CODE (ret_val
) == COMPOUND_EXPR
4154 && TREE_CODE (TREE_OPERAND (ret_val
, 0)) == INIT_EXPR
)
4156 tree rhs
= TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 1);
4158 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val
)))
4159 ret_val
= CONSTRUCTOR_ELT (rhs
, 1)->value
;
4164 /* Strip useless conversions around the return value. */
4165 if (gnat_useless_type_conversion (ret_val
)
4166 || TREE_CODE (ret_val
) == VIEW_CONVERT_EXPR
)
4167 ret_val
= TREE_OPERAND (ret_val
, 0);
4169 /* Strip unpadding around the return value. */
4170 if (TREE_CODE (ret_val
) == COMPONENT_REF
4171 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
4172 ret_val
= TREE_OPERAND (ret_val
, 0);
4174 /* Assign the new return value to the RESULT_DECL. */
4175 if (is_nrv_p (dp
->nrv
, ret_val
))
4176 TREE_OPERAND (TREE_OPERAND (t
, 0), 1)
4177 = TREE_OPERAND (DECL_INITIAL (ret_val
), 0);
4180 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
4181 into a new variable. */
4182 else if (TREE_CODE (t
) == DECL_EXPR
4183 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
4185 tree saved_current_function_decl
= current_function_decl
;
4186 tree var
= DECL_EXPR_DECL (t
);
4187 tree alloc
, p_array
, new_var
, new_ret
;
4188 vec
<constructor_elt
, va_gc
> *v
;
4191 /* Create an artificial context to build the allocation. */
4192 current_function_decl
= decl_function_context (var
);
4193 start_stmt_group ();
4196 /* This will return a COMPOUND_EXPR with the allocation in the first
4197 arm and the final return value in the second arm. */
4198 alloc
= build_allocator (TREE_TYPE (var
), DECL_INITIAL (var
),
4199 TREE_TYPE (dp
->result
),
4200 Procedure_To_Call (dp
->gnat_ret
),
4201 Storage_Pool (dp
->gnat_ret
),
4204 /* The new variable is built as a reference to the allocated space. */
4206 = build_decl (DECL_SOURCE_LOCATION (var
), VAR_DECL
, DECL_NAME (var
),
4207 build_reference_type (TREE_TYPE (var
)));
4208 DECL_BY_REFERENCE (new_var
) = 1;
4210 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc
)))
4212 tree cst
= TREE_OPERAND (alloc
, 1);
4214 /* The new initial value is a COMPOUND_EXPR with the allocation in
4215 the first arm and the value of P_ARRAY in the second arm. */
4216 DECL_INITIAL (new_var
)
4217 = build2 (COMPOUND_EXPR
, TREE_TYPE (new_var
),
4218 TREE_OPERAND (alloc
, 0),
4219 CONSTRUCTOR_ELT (cst
, 0)->value
);
4221 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
4222 p_array
= TYPE_FIELDS (TREE_TYPE (alloc
));
4223 CONSTRUCTOR_APPEND_ELT (v
, p_array
,
4224 fold_convert (TREE_TYPE (p_array
), new_var
));
4225 CONSTRUCTOR_APPEND_ELT (v
, DECL_CHAIN (p_array
),
4226 CONSTRUCTOR_ELT (cst
, 1)->value
);
4227 new_ret
= build_constructor (TREE_TYPE (alloc
), v
);
4231 /* The new initial value is just the allocation. */
4232 DECL_INITIAL (new_var
) = alloc
;
4233 new_ret
= fold_convert (TREE_TYPE (alloc
), new_var
);
4236 gnat_pushdecl (new_var
, Empty
);
4238 /* Destroy the artificial context and insert the new statements. */
4240 *tp
= end_stmt_group ();
4241 current_function_decl
= saved_current_function_decl
;
4243 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
4244 DECL_CHAIN (new_var
) = DECL_CHAIN (var
);
4245 DECL_CHAIN (var
) = new_var
;
4246 DECL_IGNORED_P (var
) = 1;
4248 /* Save the new return value and the dereference of NEW_VAR. */
4250 = build2 (COMPOUND_EXPR
, TREE_TYPE (var
), new_ret
,
4251 build1 (INDIRECT_REF
, TREE_TYPE (var
), new_var
));
4252 /* ??? Kludge to avoid messing up during inlining. */
4253 DECL_CONTEXT (var
) = NULL_TREE
;
4256 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
4257 else if (is_nrv_p (dp
->nrv
, t
))
4258 *tp
= TREE_OPERAND (DECL_INITIAL (t
), 1);
4260 /* Avoid walking into the same tree more than once. Unfortunately, we
4261 can't just use walk_tree_without_duplicates because it would only
4262 call us for the first occurrence of NRVs in the function body. */
4263 if (dp
->visited
->add (*tp
))
4269 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
4270 contains the candidates for Named Return Value and OTHER is a list of
4271 the other return values. GNAT_RET is a representative return node. */
4274 finalize_nrv (tree fndecl
, bitmap nrv
, vec
<tree
, va_gc
> *other
, Node_Id gnat_ret
)
4276 struct cgraph_node
*node
;
4277 struct nrv_data data
;
4282 /* We shouldn't be applying the optimization to return types that we aren't
4283 allowed to manipulate freely. */
4284 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl
))));
4286 /* Prune the candidates that are referenced by other return values. */
4288 data
.result
= NULL_TREE
;
4289 data
.gnat_ret
= Empty
;
4290 data
.visited
= NULL
;
4291 FOR_EACH_VEC_SAFE_ELT (other
, i
, iter
)
4292 walk_tree_without_duplicates (&iter
, prune_nrv_r
, &data
);
4293 if (bitmap_empty_p (nrv
))
4296 /* Prune also the candidates that are referenced by nested functions. */
4297 node
= cgraph_node::get_create (fndecl
);
4298 for (node
= node
->nested
; node
; node
= node
->next_nested
)
4299 walk_tree_without_duplicates (&DECL_SAVED_TREE (node
->decl
), prune_nrv_r
,
4301 if (bitmap_empty_p (nrv
))
4304 /* Extract a set of NRVs with non-overlapping live ranges. */
4305 if (!prune_nrv_in_block (nrv
, DECL_INITIAL (fndecl
)))
4308 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
4310 data
.result
= DECL_RESULT (fndecl
);
4311 data
.gnat_ret
= gnat_ret
;
4312 data
.visited
= new hash_set
<tree
>;
4313 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl
)))
4314 func
= finalize_nrv_unc_r
;
4316 func
= finalize_nrv_r
;
4317 walk_tree (&DECL_SAVED_TREE (fndecl
), func
, &data
, NULL
);
4318 delete data
.visited
;
4321 /* Return true if RET_VAL can be used as a Named Return Value for the
4322 anonymous return object RET_OBJ. */
4325 return_value_ok_for_nrv_p (tree ret_obj
, tree ret_val
)
4327 if (TREE_CODE (ret_val
) != VAR_DECL
)
4330 if (TREE_THIS_VOLATILE (ret_val
))
4333 if (DECL_CONTEXT (ret_val
) != current_function_decl
)
4336 if (TREE_STATIC (ret_val
))
4339 /* For the constrained case, test for addressability. */
4340 if (ret_obj
&& TREE_ADDRESSABLE (ret_val
))
4343 /* For the constrained case, test for overalignment. */
4344 if (ret_obj
&& DECL_ALIGN (ret_val
) > DECL_ALIGN (ret_obj
))
4347 /* For the unconstrained case, test for bogus initialization. */
4349 && DECL_INITIAL (ret_val
)
4350 && TREE_CODE (DECL_INITIAL (ret_val
)) == NULL_EXPR
)
4356 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
4357 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
4358 around RESULT_OBJ, which may be null in this case. */
4361 build_return_expr (tree ret_obj
, tree ret_val
)
4367 /* The gimplifier explicitly enforces the following invariant:
4376 As a consequence, type consistency dictates that we use the type
4377 of the RET_OBJ as the operation type. */
4378 tree operation_type
= TREE_TYPE (ret_obj
);
4380 /* Convert the right operand to the operation type. Note that this is
4381 the transformation applied in the INIT_EXPR case of build_binary_op,
4382 with the assumption that the type cannot involve a placeholder. */
4383 if (operation_type
!= TREE_TYPE (ret_val
))
4384 ret_val
= convert (operation_type
, ret_val
);
4386 /* We always can use an INIT_EXPR for the return object. */
4387 result_expr
= build2 (INIT_EXPR
, void_type_node
, ret_obj
, ret_val
);
4389 /* If the function returns an aggregate type, find out whether this is
4390 a candidate for Named Return Value. If so, record it. Otherwise,
4391 if this is an expression of some kind, record it elsewhere. */
4393 && AGGREGATE_TYPE_P (operation_type
)
4394 && !TYPE_IS_FAT_POINTER_P (operation_type
)
4395 && TYPE_MODE (operation_type
) == BLKmode
4396 && aggregate_value_p (operation_type
, current_function_decl
))
4398 /* Strip useless conversions around the return value. */
4399 if (gnat_useless_type_conversion (ret_val
))
4400 ret_val
= TREE_OPERAND (ret_val
, 0);
4402 /* Now apply the test to the return value. */
4403 if (return_value_ok_for_nrv_p (ret_obj
, ret_val
))
4405 if (!f_named_ret_val
)
4406 f_named_ret_val
= BITMAP_GGC_ALLOC ();
4407 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
4410 /* Note that we need not care about CONSTRUCTORs here, as they are
4411 totally transparent given the read-compose-write semantics of
4412 assignments from CONSTRUCTORs. */
4413 else if (EXPR_P (ret_val
))
4414 vec_safe_push (f_other_ret_val
, ret_val
);
4418 result_expr
= ret_obj
;
4420 return build1 (RETURN_EXPR
, void_type_node
, result_expr
);
4423 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
4424 don't return anything. */
4427 Subprogram_Body_to_gnu (Node_Id gnat_node
)
4429 /* Defining identifier of a parameter to the subprogram. */
4430 Entity_Id gnat_param
;
4431 /* The defining identifier for the subprogram body. Note that if a
4432 specification has appeared before for this body, then the identifier
4433 occurring in that specification will also be a defining identifier and all
4434 the calls to this subprogram will point to that specification. */
4435 Entity_Id gnat_subprog_id
4436 = (Present (Corresponding_Spec (gnat_node
))
4437 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
4438 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
4439 tree gnu_subprog_decl
;
4440 /* Its RESULT_DECL node. */
4441 tree gnu_result_decl
;
4442 /* Its FUNCTION_TYPE node. */
4443 tree gnu_subprog_type
;
4444 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
4446 /* The entry in the CI_CO_LIST that represents a function return, if any. */
4447 tree gnu_return_var_elmt
= NULL_TREE
;
4450 struct language_function
*gnu_subprog_language
;
4451 vec
<parm_attr
, va_gc
> *cache
;
4453 /* If this is a generic object or if it has been eliminated,
4455 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
4456 || Ekind (gnat_subprog_id
) == E_Generic_Function
4457 || Is_Eliminated (gnat_subprog_id
))
4460 /* If this subprogram acts as its own spec, define it. Otherwise, just get
4461 the already-elaborated tree node. However, if this subprogram had its
4462 elaboration deferred, we will already have made a tree node for it. So
4463 treat it as not being defined in that case. Such a subprogram cannot
4464 have an address clause or a freeze node, so this test is safe, though it
4465 does disable some otherwise-useful error checking. */
4467 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
4468 Acts_As_Spec (gnat_node
)
4469 && !present_gnu_tree (gnat_subprog_id
));
4470 DECL_FUNCTION_IS_DEF (gnu_subprog_decl
) = true;
4471 gnu_result_decl
= DECL_RESULT (gnu_subprog_decl
);
4472 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
4473 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
4474 if (gnu_cico_list
&& TREE_VALUE (gnu_cico_list
) == void_type_node
)
4475 gnu_return_var_elmt
= gnu_cico_list
;
4477 /* If the function returns by invisible reference, make it explicit in the
4478 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
4479 if (TREE_ADDRESSABLE (gnu_subprog_type
))
4481 TREE_TYPE (gnu_result_decl
)
4482 = build_reference_type (TREE_TYPE (gnu_result_decl
));
4483 relayout_decl (gnu_result_decl
);
4486 /* Set the line number in the decl to correspond to that of the body. */
4487 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
, false, gnu_subprog_decl
))
4488 locus
= input_location
;
4489 DECL_SOURCE_LOCATION (gnu_subprog_decl
) = locus
;
4491 /* If the body comes from an expression function, arrange it to be inlined
4492 in almost all cases. */
4493 if (Was_Expression_Function (gnat_node
))
4494 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog_decl
) = 1;
4496 /* Try to create a bona-fide thunk and hand it over to the middle-end. */
4497 if (Is_Thunk (gnat_subprog_id
)
4498 && maybe_make_gnu_thunk (gnat_subprog_id
, gnu_subprog_decl
))
4501 /* Initialize the information structure for the function. */
4502 allocate_struct_function (gnu_subprog_decl
, false);
4503 gnu_subprog_language
= ggc_cleared_alloc
<language_function
> ();
4504 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->language
= gnu_subprog_language
;
4505 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->function_start_locus
= locus
;
4508 begin_subprog_body (gnu_subprog_decl
);
4510 /* If there are copy-in/copy-out parameters, we need to ensure that they are
4511 properly copied out by the return statement. We do this by making a new
4512 block and converting any return into a goto to a label at the end of the
4516 tree gnu_return_var
= NULL_TREE
;
4518 vec_safe_push (gnu_return_label_stack
,
4519 create_artificial_label (input_location
));
4521 start_stmt_group ();
4524 /* If this is a function with copy-in/copy-out parameters and which does
4525 not return by invisible reference, we also need a variable for the
4526 return value to be placed. */
4527 if (gnu_return_var_elmt
&& !TREE_ADDRESSABLE (gnu_subprog_type
))
4529 tree gnu_return_type
4530 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt
));
4533 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE
,
4534 gnu_return_type
, NULL_TREE
,
4535 false, false, false, false, false,
4536 true, false, NULL
, gnat_subprog_id
);
4537 TREE_VALUE (gnu_return_var_elmt
) = gnu_return_var
;
4540 vec_safe_push (gnu_return_var_stack
, gnu_return_var
);
4542 /* See whether there are parameters for which we don't have a GCC tree
4543 yet. These must be Out parameters. Make a VAR_DECL for them and
4544 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
4545 We can match up the entries because TYPE_CI_CO_LIST is in the order
4546 of the parameters. */
4547 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
4548 Present (gnat_param
);
4549 gnat_param
= Next_Formal_With_Extras (gnat_param
))
4550 if (!present_gnu_tree (gnat_param
))
4552 tree gnu_cico_entry
= gnu_cico_list
;
4555 /* Skip any entries that have been already filled in; they must
4556 correspond to In Out parameters. */
4557 while (gnu_cico_entry
&& TREE_VALUE (gnu_cico_entry
))
4558 gnu_cico_entry
= TREE_CHAIN (gnu_cico_entry
);
4560 /* Do any needed dereferences for by-ref objects. */
4561 gnu_decl
= gnat_to_gnu_entity (gnat_param
, NULL_TREE
, true);
4562 gcc_assert (DECL_P (gnu_decl
));
4563 if (DECL_BY_REF_P (gnu_decl
))
4564 gnu_decl
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_decl
);
4566 /* Do any needed references for padded types. */
4567 TREE_VALUE (gnu_cico_entry
)
4568 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry
)), gnu_decl
);
4572 vec_safe_push (gnu_return_label_stack
, NULL_TREE
);
4574 /* Get a tree corresponding to the code for the subprogram. */
4575 start_stmt_group ();
4578 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
4580 /* Generate the code of the subprogram itself. A return statement will be
4581 present and any Out parameters will be handled there. */
4582 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
4584 gnu_result
= end_stmt_group ();
4586 /* If we populated the parameter attributes cache, we need to make sure that
4587 the cached expressions are evaluated on all the possible paths leading to
4588 their uses. So we force their evaluation on entry of the function. */
4589 cache
= gnu_subprog_language
->parm_attr_cache
;
4592 struct parm_attr_d
*pa
;
4595 start_stmt_group ();
4597 FOR_EACH_VEC_ELT (*cache
, i
, pa
)
4600 add_stmt_with_node_force (pa
->first
, gnat_node
);
4602 add_stmt_with_node_force (pa
->last
, gnat_node
);
4604 add_stmt_with_node_force (pa
->length
, gnat_node
);
4607 add_stmt (gnu_result
);
4608 gnu_result
= end_stmt_group ();
4610 gnu_subprog_language
->parm_attr_cache
= NULL
;
4613 /* If we are dealing with a return from an Ada procedure with parameters
4614 passed by copy-in/copy-out, we need to return a record containing the
4615 final values of these parameters. If the list contains only one entry,
4616 return just that entry though.
4618 For a full description of the copy-in/copy-out parameter mechanism, see
4619 the part of the gnat_to_gnu_entity routine dealing with the translation
4622 We need to make a block that contains the definition of that label and
4623 the copying of the return value. It first contains the function, then
4624 the label and copy statement. */
4627 const Node_Id gnat_end_label
4628 = End_Label (Handled_Statement_Sequence (gnat_node
));
4630 gnu_return_var_stack
->pop ();
4632 add_stmt (gnu_result
);
4633 add_stmt (build1 (LABEL_EXPR
, void_type_node
,
4634 gnu_return_label_stack
->last ()));
4636 /* If this is a function which returns by invisible reference, the
4637 return value has already been dealt with at the return statements,
4638 so we only need to indirectly copy out the parameters. */
4639 if (TREE_ADDRESSABLE (gnu_subprog_type
))
4642 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result_decl
);
4645 gcc_assert (TREE_VALUE (gnu_cico_list
) == void_type_node
);
4647 for (t
= TREE_CHAIN (gnu_cico_list
); t
; t
= TREE_CHAIN (t
))
4649 tree gnu_field_deref
4650 = build_component_ref (gnu_ret_deref
, TREE_PURPOSE (t
), true);
4651 gnu_result
= build2 (MODIFY_EXPR
, void_type_node
,
4652 gnu_field_deref
, TREE_VALUE (t
));
4653 add_stmt_with_node (gnu_result
, gnat_end_label
);
4657 /* Otherwise, if this is a procedure or a function which does not return
4658 by invisible reference, we can do a direct block-copy out. */
4663 if (list_length (gnu_cico_list
) == 1)
4664 gnu_retval
= TREE_VALUE (gnu_cico_list
);
4667 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type
),
4670 gnu_result
= build_return_expr (gnu_result_decl
, gnu_retval
);
4671 add_stmt_with_node (gnu_result
, gnat_end_label
);
4675 gnu_result
= end_stmt_group ();
4678 gnu_return_label_stack
->pop ();
4680 /* Attempt setting the end_locus of our GCC body tree, typically a
4681 BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
4682 declaration tree. */
4683 set_end_locus_from_node (gnu_result
, gnat_node
);
4684 set_end_locus_from_node (gnu_subprog_decl
, gnat_node
);
4686 /* On SEH targets, install an exception handler around the main entry
4687 point to catch unhandled exceptions. */
4688 if (DECL_NAME (gnu_subprog_decl
) == main_identifier_node
4689 && targetm_common
.except_unwind_info (&global_options
) == UI_SEH
)
4694 t
= build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
4695 1, integer_zero_node
);
4696 t
= build_call_n_expr (unhandled_except_decl
, 1, t
);
4698 etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, unhandled_others_decl
);
4699 etype
= tree_cons (NULL_TREE
, etype
, NULL_TREE
);
4701 t
= build2 (CATCH_EXPR
, void_type_node
, etype
, t
);
4702 gnu_result
= build2 (TRY_CATCH_EXPR
, TREE_TYPE (gnu_result
),
4706 end_subprog_body (gnu_result
);
4708 /* Finally annotate the parameters and disconnect the trees for parameters
4709 that we have turned into variables since they are now unusable. */
4710 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
4711 Present (gnat_param
);
4712 gnat_param
= Next_Formal_With_Extras (gnat_param
))
4714 tree gnu_param
= get_gnu_tree (gnat_param
);
4715 bool is_var_decl
= (TREE_CODE (gnu_param
) == VAR_DECL
);
4717 annotate_object (gnat_param
, TREE_TYPE (gnu_param
), NULL_TREE
,
4718 DECL_BY_REF_P (gnu_param
));
4721 save_gnu_tree (gnat_param
, NULL_TREE
, false);
4724 /* Disconnect the variable created for the return value. */
4725 if (gnu_return_var_elmt
)
4726 TREE_VALUE (gnu_return_var_elmt
) = void_type_node
;
4728 /* If the function returns an aggregate type and we have candidates for
4729 a Named Return Value, finalize the optimization. */
4730 if (optimize
&& gnu_subprog_language
->named_ret_val
)
4732 finalize_nrv (gnu_subprog_decl
,
4733 gnu_subprog_language
->named_ret_val
,
4734 gnu_subprog_language
->other_ret_val
,
4735 gnu_subprog_language
->gnat_ret
);
4736 gnu_subprog_language
->named_ret_val
= NULL
;
4737 gnu_subprog_language
->other_ret_val
= NULL
;
4740 /* If this is an inlined external function that has been marked uninlinable,
4741 drop the body and stop there. Otherwise compile the body. */
4742 if (DECL_EXTERNAL (gnu_subprog_decl
) && DECL_UNINLINABLE (gnu_subprog_decl
))
4743 DECL_SAVED_TREE (gnu_subprog_decl
) = NULL_TREE
;
4745 rest_of_subprog_body_compilation (gnu_subprog_decl
);
4748 /* Return true if GNAT_NODE references an Atomic entity. */
4751 node_is_atomic (Node_Id gnat_node
)
4753 Entity_Id gnat_entity
;
4755 switch (Nkind (gnat_node
))
4758 case N_Expanded_Name
:
4759 gnat_entity
= Entity (gnat_node
);
4760 if (Ekind (gnat_entity
) != E_Variable
)
4762 return Is_Atomic (gnat_entity
) || Is_Atomic (Etype (gnat_entity
));
4764 case N_Selected_Component
:
4765 gnat_entity
= Entity (Selector_Name (gnat_node
));
4766 return Is_Atomic (gnat_entity
) || Is_Atomic (Etype (gnat_entity
));
4768 case N_Indexed_Component
:
4769 if (Has_Atomic_Components (Etype (Prefix (gnat_node
))))
4771 if (Is_Entity_Name (Prefix (gnat_node
))
4772 && Has_Atomic_Components (Entity (Prefix (gnat_node
))))
4775 /* ... fall through ... */
4777 case N_Explicit_Dereference
:
4778 return Is_Atomic (Etype (gnat_node
));
4787 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. */
4790 node_has_volatile_full_access (Node_Id gnat_node
)
4792 Entity_Id gnat_entity
;
4794 switch (Nkind (gnat_node
))
4797 case N_Expanded_Name
:
4798 gnat_entity
= Entity (gnat_node
);
4799 if (!Is_Object (gnat_entity
))
4801 return Is_Volatile_Full_Access (gnat_entity
)
4802 || Is_Volatile_Full_Access (Etype (gnat_entity
));
4804 case N_Selected_Component
:
4805 gnat_entity
= Entity (Selector_Name (gnat_node
));
4806 return Is_Volatile_Full_Access (gnat_entity
)
4807 || Is_Volatile_Full_Access (Etype (gnat_entity
));
4809 case N_Indexed_Component
:
4810 case N_Explicit_Dereference
:
4811 return Is_Volatile_Full_Access (Etype (gnat_node
));
4820 /* Strip any type conversion on GNAT_NODE and return the result. */
4823 gnat_strip_type_conversion (Node_Id gnat_node
)
4825 Node_Kind kind
= Nkind (gnat_node
);
4827 if (kind
== N_Type_Conversion
|| kind
== N_Unchecked_Type_Conversion
)
4828 gnat_node
= Expression (gnat_node
);
4833 /* Return true if GNAT_NODE requires outer atomic access, i.e. atomic access
4834 of an object of which GNAT_NODE is a component. */
4837 outer_atomic_access_required_p (Node_Id gnat_node
)
4839 gnat_node
= gnat_strip_type_conversion (gnat_node
);
4843 switch (Nkind (gnat_node
))
4846 case N_Expanded_Name
:
4847 if (No (Renamed_Object (Entity (gnat_node
))))
4850 = gnat_strip_type_conversion (Renamed_Object (Entity (gnat_node
)));
4853 case N_Indexed_Component
:
4854 case N_Selected_Component
:
4856 gnat_node
= gnat_strip_type_conversion (Prefix (gnat_node
));
4857 if (node_has_volatile_full_access (gnat_node
))
4869 /* Return true if GNAT_NODE requires atomic access and set SYNC according to
4870 the associated synchronization setting. */
4873 atomic_access_required_p (Node_Id gnat_node
, bool *sync
)
4875 const Node_Id gnat_parent
= Parent (gnat_node
);
4876 unsigned char attr_id
;
4877 bool as_a_whole
= true;
4879 /* First, scan the parent to find out cases where the flag is irrelevant. */
4880 switch (Nkind (gnat_parent
))
4882 case N_Attribute_Reference
:
4883 attr_id
= Get_Attribute_Id (Attribute_Name (gnat_parent
));
4884 /* Do not mess up machine code insertions. */
4885 if (attr_id
== Attr_Asm_Input
|| attr_id
== Attr_Asm_Output
)
4888 /* Nothing to do if we are the prefix of an attribute, since we do not
4889 want an atomic access for things like 'Size. */
4891 /* ... fall through ... */
4894 /* The N_Reference node is like an attribute. */
4895 if (Prefix (gnat_parent
) == gnat_node
)
4899 case N_Indexed_Component
:
4900 case N_Selected_Component
:
4902 /* If we are the prefix, then the access is only partial. */
4903 if (Prefix (gnat_parent
) == gnat_node
)
4907 case N_Object_Renaming_Declaration
:
4908 /* Nothing to do for the identifier in an object renaming declaration,
4909 the renaming itself does not need atomic access. */
4916 /* Then, scan the node to find the atomic object. */
4917 gnat_node
= gnat_strip_type_conversion (gnat_node
);
4919 /* For Atomic itself, only reads and updates of the object as a whole require
4920 atomic access (RM C.6 (15)). But for Volatile_Full_Access, all reads and
4921 updates require atomic access. */
4922 if (!(as_a_whole
&& node_is_atomic (gnat_node
))
4923 && !node_has_volatile_full_access (gnat_node
))
4926 /* If an outer atomic access will also be required, it cancels this one. */
4927 if (outer_atomic_access_required_p (gnat_node
))
4930 *sync
= Atomic_Sync_Required (gnat_node
);
4935 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4938 create_temporary (const char *prefix
, tree type
)
4941 = create_var_decl (create_tmp_var_name (prefix
), NULL_TREE
,
4943 false, false, false, false, false,
4944 true, false, NULL
, Empty
);
4948 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4949 Put the initialization statement into GNU_INIT_STMT and annotate it with
4950 the SLOC of GNAT_NODE. Return the temporary variable. */
4953 create_init_temporary (const char *prefix
, tree gnu_init
, tree
*gnu_init_stmt
,
4956 tree gnu_temp
= create_temporary (prefix
, TREE_TYPE (gnu_init
));
4958 *gnu_init_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_temp
, gnu_init
);
4959 set_expr_location_from_node (*gnu_init_stmt
, gnat_node
);
4964 /* Return whether ACTUAL parameter corresponding to FORMAL_TYPE must be passed
4965 by copy in a call as per RM C.6(19). Note that we use the same predicates
4966 as in the front-end for RM C.6(12) because it's purely a legality issue. */
4969 atomic_or_volatile_copy_required_p (Node_Id actual
, Entity_Id formal_type
)
4971 /* We should not have a scalar type here because such a type is passed
4972 by copy. But the Interlocked routines in System.Aux_DEC force some
4973 of the their scalar parameters to be passed by reference so we need
4974 to preserve that if we do not want to break the interface. */
4975 if (Is_Scalar_Type (formal_type
))
4978 if (Is_Atomic_Object (actual
) && !Is_Atomic (formal_type
))
4980 post_error ("?atomic actual passed by copy (RM C.6(19))", actual
);
4984 if (Is_Volatile_Object (actual
) && !Is_Volatile (formal_type
))
4986 post_error ("?volatile actual passed by copy (RM C.6(19))", actual
);
4993 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
4994 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4995 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4996 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4997 N_Assignment_Statement and the result is to be placed into that object.
4998 If OUTER_ATOMIC_ACCESS is true, then the assignment to GNU_TARGET must be a
4999 load-modify-store sequence. Otherwise, if ATOMIC_ACCESS is true, then the
5000 assignment to GNU_TARGET must be atomic. If, in addition, ATOMIC_SYNC is
5001 true, then the assignment to GNU_TARGET requires atomic synchronization. */
5004 Call_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, tree gnu_target
,
5005 bool outer_atomic_access
, bool atomic_access
, bool atomic_sync
)
5007 const bool function_call
= (Nkind (gnat_node
) == N_Function_Call
);
5008 const bool returning_value
= (function_call
&& !gnu_target
);
5009 /* The GCC node corresponding to the GNAT subprogram name. This can either
5010 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
5011 or an indirect reference expression (an INDIRECT_REF node) pointing to a
5013 tree gnu_subprog
= gnat_to_gnu (Name (gnat_node
));
5014 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
5015 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog
);
5016 /* The return type of the FUNCTION_TYPE. */
5017 tree gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
5018 tree gnu_subprog_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog
);
5019 vec
<tree
, va_gc
> *gnu_actual_vec
= NULL
;
5020 tree gnu_name_list
= NULL_TREE
;
5021 tree gnu_stmt_list
= NULL_TREE
;
5022 tree gnu_after_list
= NULL_TREE
;
5023 tree gnu_retval
= NULL_TREE
;
5024 tree gnu_call
, gnu_result
;
5025 bool by_descriptor
= false;
5026 bool went_into_elab_proc
= false;
5027 bool pushed_binding_level
= false;
5028 Entity_Id gnat_formal
;
5029 Node_Id gnat_actual
;
5032 gcc_assert (FUNC_OR_METHOD_TYPE_P (gnu_subprog_type
));
5034 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
5035 all our args first. */
5036 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
&& DECL_STUBBED_P (gnu_subprog
))
5038 tree call_expr
= build_call_raise (PE_Stubbed_Subprogram_Called
,
5039 gnat_node
, N_Raise_Program_Error
);
5041 for (gnat_actual
= First_Actual (gnat_node
);
5042 Present (gnat_actual
);
5043 gnat_actual
= Next_Actual (gnat_actual
))
5044 add_stmt (gnat_to_gnu (gnat_actual
));
5046 if (returning_value
)
5048 *gnu_result_type_p
= gnu_result_type
;
5049 return build1 (NULL_EXPR
, gnu_result_type
, call_expr
);
5055 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
)
5057 /* For a call to a nested function, check the inlining status. */
5058 if (decl_function_context (gnu_subprog
))
5059 check_inlining_for_nested_subprog (gnu_subprog
);
5061 /* For a recursive call, avoid explosion due to recursive inlining. */
5062 if (gnu_subprog
== current_function_decl
)
5063 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog
) = 0;
5066 /* The only way we can be making a call via an access type is if Name is an
5067 explicit dereference. In that case, get the list of formal args from the
5068 type the access type is pointing to. Otherwise, get the formals from the
5069 entity being called. */
5070 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
5072 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
5074 /* If the access type doesn't require foreign-compatible representation,
5075 be prepared for descriptors. */
5076 if (targetm
.calls
.custom_function_descriptors
> 0
5077 && Can_Use_Internal_Rep (Etype (Prefix (Name (gnat_node
)))))
5078 by_descriptor
= true;
5080 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
5081 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
5082 gnat_formal
= Empty
;
5084 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
5086 /* The lifetime of the temporaries created for the call ends right after the
5087 return value is copied, so we can give them the scope of the elaboration
5088 routine at top level. */
5089 if (!current_function_decl
)
5091 current_function_decl
= get_elaboration_procedure ();
5092 went_into_elab_proc
= true;
5095 /* First, create the temporary for the return value when:
5097 1. There is no target and the function has copy-in/copy-out parameters,
5098 because we need to preserve the return value before copying back the
5101 2. There is no target and the call is made for neither an object, nor a
5102 renaming declaration, nor a return statement, nor an allocator, and
5103 the return type has variable size because in this case the gimplifier
5104 cannot create the temporary, or more generally is an aggregate type,
5105 because the gimplifier would create the temporary in the outermost
5106 scope instead of locally. But there is an exception for an allocator
5107 of an unconstrained record type with default discriminant because we
5108 allocate the actual size in this case, unlike the other 3 cases, so
5109 we need a temporary to fetch the discriminant and we create it here.
5111 3. There is a target and it is a slice or an array with fixed size,
5112 and the return type has variable size, because the gimplifier
5113 doesn't handle these cases.
5115 4. There is no target and we have misaligned In Out or Out parameters
5116 passed by reference, because we need to preserve the return value
5117 before copying back the parameters. However, in this case, we'll
5118 defer creating the temporary, see below.
5120 This must be done before we push a binding level around the call, since
5121 we will pop it before copying the return value. */
5123 && ((!gnu_target
&& TYPE_CI_CO_LIST (gnu_subprog_type
))
5125 && Nkind (Parent (gnat_node
)) != N_Object_Declaration
5126 && Nkind (Parent (gnat_node
)) != N_Object_Renaming_Declaration
5127 && Nkind (Parent (gnat_node
)) != N_Simple_Return_Statement
5128 && (!(Nkind (Parent (gnat_node
)) == N_Qualified_Expression
5129 && Nkind (Parent (Parent (gnat_node
))) == N_Allocator
)
5130 || type_is_padding_self_referential (gnu_result_type
))
5131 && AGGREGATE_TYPE_P (gnu_result_type
)
5132 && !TYPE_IS_FAT_POINTER_P (gnu_result_type
))
5134 && (TREE_CODE (gnu_target
) == ARRAY_RANGE_REF
5135 || (TREE_CODE (TREE_TYPE (gnu_target
)) == ARRAY_TYPE
5136 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target
)))
5138 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
)))
5140 gnu_retval
= create_temporary ("R", gnu_result_type
);
5141 DECL_RETURN_VALUE_P (gnu_retval
) = 1;
5144 /* If we don't need a value or have already created it, push a binding level
5145 around the call. This will narrow the lifetime of the temporaries we may
5146 need to make when translating the parameters as much as possible. */
5147 if (!returning_value
|| gnu_retval
)
5149 start_stmt_group ();
5151 pushed_binding_level
= true;
5154 /* Create the list of the actual parameters as GCC expects it, namely a
5155 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
5156 is an expression and the TREE_PURPOSE field is null. But skip Out
5157 parameters not passed by reference and that need not be copied in. */
5158 for (gnat_actual
= First_Actual (gnat_node
);
5159 Present (gnat_actual
);
5160 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
5161 gnat_actual
= Next_Actual (gnat_actual
))
5163 Entity_Id gnat_formal_type
= Etype (gnat_formal
);
5164 tree gnu_formal_type
= gnat_to_gnu_type (gnat_formal_type
);
5165 tree gnu_formal
= present_gnu_tree (gnat_formal
)
5166 ? get_gnu_tree (gnat_formal
) : NULL_TREE
;
5167 const bool in_param
= (Ekind (gnat_formal
) == E_In_Parameter
);
5168 const bool is_true_formal_parm
5169 = gnu_formal
&& TREE_CODE (gnu_formal
) == PARM_DECL
;
5170 const bool is_by_ref_formal_parm
5171 = is_true_formal_parm
5172 && (DECL_BY_REF_P (gnu_formal
)
5173 || DECL_BY_COMPONENT_PTR_P (gnu_formal
));
5174 /* In the In Out or Out case, we must suppress conversions that yield
5175 an lvalue but can nevertheless cause the creation of a temporary,
5176 because we need the real object in this case, either to pass its
5177 address if it's passed by reference or as target of the back copy
5178 done after the call if it uses the copy-in/copy-out mechanism.
5179 We do it in the In case too, except for an unchecked conversion
5180 to an elementary type or a constrained composite type because it
5181 alone can cause the actual to be misaligned and the addressability
5182 test is applied to the real object. */
5183 const bool suppress_type_conversion
5184 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
5186 || !is_by_ref_formal_parm
5187 || (Is_Composite_Type (Underlying_Type (gnat_formal_type
))
5188 && !Is_Constrained (Underlying_Type (gnat_formal_type
)))))
5189 || (Nkind (gnat_actual
) == N_Type_Conversion
5190 && Is_Composite_Type (Underlying_Type (gnat_formal_type
))));
5191 Node_Id gnat_name
= suppress_type_conversion
5192 ? Expression (gnat_actual
) : gnat_actual
;
5193 tree gnu_name
= gnat_to_gnu (gnat_name
), gnu_name_type
;
5195 /* If it's possible we may need to use this expression twice, make sure
5196 that any side-effects are handled via SAVE_EXPRs; likewise if we need
5197 to force side-effects before the call. */
5198 if (!in_param
&& !is_by_ref_formal_parm
)
5200 tree init
= NULL_TREE
;
5201 gnu_name
= gnat_stabilize_reference (gnu_name
, true, &init
);
5204 = build_compound_expr (TREE_TYPE (gnu_name
), init
, gnu_name
);
5207 /* If we are passing a non-addressable actual parameter by reference,
5208 pass the address of a copy and, in the In Out or Out case, set up
5209 to copy back after the call. We also need to do that if the actual
5210 parameter is atomic or volatile but the formal parameter is not. */
5211 if (is_by_ref_formal_parm
5212 && (gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
)))
5213 && (!addressable_p (gnu_name
, gnu_name_type
)
5214 || (Comes_From_Source (gnat_node
)
5215 && atomic_or_volatile_copy_required_p (gnat_actual
,
5216 gnat_formal_type
))))
5218 const bool atomic_p
= atomic_access_required_p (gnat_actual
, &sync
);
5219 tree gnu_orig
= gnu_name
, gnu_temp
, gnu_stmt
;
5221 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
5222 but sort of an instantiation for them. */
5223 if (TREE_CODE (gnu_name
) == CONSTRUCTOR
)
5226 /* If the type is passed by reference, a copy is not allowed. */
5227 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type
))
5228 post_error ("misaligned actual cannot be passed by reference",
5231 /* For users of Starlet we issue a warning because the interface
5232 apparently assumes that by-ref parameters outlive the procedure
5233 invocation. The code still will not work as intended, but we
5234 cannot do much better since low-level parts of the back-end
5235 would allocate temporaries at will because of the misalignment
5236 if we did not do so here. */
5237 else if (Is_Valued_Procedure (Entity (Name (gnat_node
))))
5240 ("?possible violation of implicit assumption", gnat_actual
);
5242 ("?made by pragma Import_Valued_Procedure on &", gnat_actual
,
5243 Entity (Name (gnat_node
)));
5244 post_error_ne ("?because of misalignment of &", gnat_actual
,
5248 /* If the actual type of the object is already the nominal type,
5249 we have nothing to do, except if the size is self-referential
5250 in which case we'll remove the unpadding below. */
5251 if (TREE_TYPE (gnu_name
) == gnu_name_type
5252 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type
)))
5255 /* Otherwise remove the unpadding from all the objects. */
5256 else if (TREE_CODE (gnu_name
) == COMPONENT_REF
5257 && TYPE_IS_PADDING_P
5258 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))
5259 gnu_orig
= gnu_name
= TREE_OPERAND (gnu_name
, 0);
5261 /* Otherwise convert to the nominal type of the object if needed.
5262 There are several cases in which we need to make the temporary
5263 using this type instead of the actual type of the object when
5264 they are distinct, because the expectations of the callee would
5265 otherwise not be met:
5266 - if it's a justified modular type,
5267 - if the actual type is a smaller form of it,
5268 - if it's a smaller form of the actual type. */
5269 else if ((TREE_CODE (gnu_name_type
) == RECORD_TYPE
5270 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type
)
5271 || smaller_form_type_p (TREE_TYPE (gnu_name
),
5273 || (INTEGRAL_TYPE_P (gnu_name_type
)
5274 && smaller_form_type_p (gnu_name_type
,
5275 TREE_TYPE (gnu_name
))))
5276 gnu_name
= convert (gnu_name_type
, gnu_name
);
5278 /* If this is an In Out or Out parameter and we're returning a value,
5279 we need to create a temporary for the return value because we must
5280 preserve it before copying back at the very end. */
5281 if (!in_param
&& returning_value
&& !gnu_retval
)
5283 gnu_retval
= create_temporary ("R", gnu_result_type
);
5284 DECL_RETURN_VALUE_P (gnu_retval
) = 1;
5287 /* If we haven't pushed a binding level, push it now. This will
5288 narrow the lifetime of the temporary we are about to make as
5289 much as possible. */
5290 if (!pushed_binding_level
&& (!returning_value
|| gnu_retval
))
5292 start_stmt_group ();
5294 pushed_binding_level
= true;
5297 /* Create an explicit temporary holding the copy. */
5299 gnu_name
= build_atomic_load (gnu_name
, sync
);
5301 = create_init_temporary ("A", gnu_name
, &gnu_stmt
, gnat_actual
);
5303 /* But initialize it on the fly like for an implicit temporary as
5304 we aren't necessarily having a statement list. */
5305 gnu_name
= build_compound_expr (TREE_TYPE (gnu_name
), gnu_stmt
,
5308 /* Set up to move the copy back to the original if needed. */
5311 /* If the original is a COND_EXPR whose first arm isn't meant to
5312 be further used, just deal with the second arm. This is very
5313 likely the conditional expression built for a check. */
5314 if (TREE_CODE (gnu_orig
) == COND_EXPR
5315 && TREE_CODE (TREE_OPERAND (gnu_orig
, 1)) == COMPOUND_EXPR
5317 (TREE_OPERAND (TREE_OPERAND (gnu_orig
, 1), 1)))
5318 gnu_orig
= TREE_OPERAND (gnu_orig
, 2);
5322 = build_atomic_store (gnu_orig
, gnu_temp
, sync
);
5325 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_orig
,
5327 set_expr_location_from_node (gnu_stmt
, gnat_node
);
5329 append_to_statement_list (gnu_stmt
, &gnu_after_list
);
5333 /* Start from the real object and build the actual. */
5334 tree gnu_actual
= gnu_name
;
5336 /* If atomic access is required for an In or In Out actual parameter,
5337 build the atomic load. */
5338 if (is_true_formal_parm
5339 && !is_by_ref_formal_parm
5340 && Ekind (gnat_formal
) != E_Out_Parameter
5341 && atomic_access_required_p (gnat_actual
, &sync
))
5342 gnu_actual
= build_atomic_load (gnu_actual
, sync
);
5344 /* If this was a procedure call, we may not have removed any padding.
5345 So do it here for the part we will use as an input, if any. */
5346 if (Ekind (gnat_formal
) != E_Out_Parameter
5347 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
5349 = convert (get_unpadded_type (Etype (gnat_actual
)), gnu_actual
);
5351 /* Put back the conversion we suppressed above in the computation of the
5352 real object. And even if we didn't suppress any conversion there, we
5353 may have suppressed a conversion to the Etype of the actual earlier,
5354 since the parent is a procedure call, so put it back here. Note that
5355 we might have a dummy type here if the actual is the dereference of a
5356 pointer to it, but that's OK if the formal is passed by reference. */
5357 tree gnu_actual_type
= gnat_to_gnu_type (Etype (gnat_actual
));
5358 if (TYPE_IS_DUMMY_P (gnu_actual_type
))
5359 gcc_assert (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
));
5360 else if (suppress_type_conversion
5361 && Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
5362 gnu_actual
= unchecked_convert (gnu_actual_type
, gnu_actual
,
5363 No_Truncation (gnat_actual
));
5365 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
5367 /* Make sure that the actual is in range of the formal's type. */
5368 if (Ekind (gnat_formal
) != E_Out_Parameter
5369 && Do_Range_Check (gnat_actual
))
5371 = emit_range_check (gnu_actual
, gnat_formal_type
, gnat_actual
);
5373 /* First see if the parameter is passed by reference. */
5374 if (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
))
5378 /* In Out or Out parameters passed by reference don't use the
5379 copy-in/copy-out mechanism so the address of the real object
5380 must be passed to the function. */
5381 gnu_actual
= gnu_name
;
5383 /* If we have a padded type, be sure we've removed padding. */
5384 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
5385 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
5388 /* If we have the constructed subtype of an aliased object
5389 with an unconstrained nominal subtype, the type of the
5390 actual includes the template, although it is formally
5391 constrained. So we need to convert it back to the real
5392 constructed subtype to retrieve the constrained part
5393 and takes its address. */
5394 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
5395 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual
))
5396 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual
))
5397 && Is_Array_Type (Underlying_Type (Etype (gnat_actual
))))
5398 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
5401 /* There is no need to convert the actual to the formal's type before
5402 taking its address. The only exception is for unconstrained array
5403 types because of the way we build fat pointers. */
5404 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5406 /* Put back the conversion we suppressed above for In Out or Out
5407 parameters, since it may set the bounds of the actual. */
5408 if (!in_param
&& suppress_type_conversion
)
5409 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
5410 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
5413 /* Take the address of the object and convert to the proper pointer
5415 gnu_formal_type
= TREE_TYPE (gnu_formal
);
5416 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
5419 /* Then see if the parameter is an array passed to a foreign convention
5421 else if (is_true_formal_parm
&& DECL_BY_COMPONENT_PTR_P (gnu_formal
))
5423 gnu_actual
= maybe_implicit_deref (gnu_actual
);
5424 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
5426 /* Take the address of the object and convert to the proper pointer
5427 type. We'd like to actually compute the address of the beginning
5428 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
5429 possibility that the ARRAY_REF might return a constant and we'd be
5430 getting the wrong address. Neither approach is exactly correct,
5431 but this is the most likely to work in all cases. */
5432 gnu_formal_type
= TREE_TYPE (gnu_formal
);
5433 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
5436 /* Otherwise the parameter is passed by copy. */
5442 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
5444 /* If we didn't create a PARM_DECL for the formal, this means that
5445 it is an Out parameter not passed by reference and that need not
5446 be copied in. In this case, the value of the actual need not be
5447 read. However, we still need to make sure that its side-effects
5448 are evaluated before the call, so we evaluate its address. */
5449 if (!is_true_formal_parm
)
5451 if (TREE_SIDE_EFFECTS (gnu_name
))
5453 tree addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_name
);
5454 append_to_statement_list (addr
, &gnu_stmt_list
);
5459 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
5461 /* If this is 'Null_Parameter, pass a zero even though we are
5462 dereferencing it. */
5463 if (TREE_CODE (gnu_actual
) == INDIRECT_REF
5464 && TREE_PRIVATE (gnu_actual
)
5465 && (gnu_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
)))
5466 && TREE_CODE (gnu_size
) == INTEGER_CST
5467 && compare_tree_int (gnu_size
, BITS_PER_WORD
) <= 0)
5470 = gnat_type_for_size (TREE_INT_CST_LOW (gnu_size
), 1);
5472 = unchecked_convert (DECL_ARG_TYPE (gnu_formal
),
5473 build_int_cst (type_for_size
, 0),
5477 gnu_actual
= convert (DECL_ARG_TYPE (gnu_formal
), gnu_actual
);
5480 vec_safe_push (gnu_actual_vec
, gnu_actual
);
5484 = build_call_vec (gnu_result_type
, gnu_subprog_addr
, gnu_actual_vec
);
5485 CALL_EXPR_BY_DESCRIPTOR (gnu_call
) = by_descriptor
;
5486 set_expr_location_from_node (gnu_call
, gnat_node
);
5488 /* If we have created a temporary for the return value, initialize it. */
5492 = build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_retval
, gnu_call
);
5493 set_expr_location_from_node (gnu_stmt
, gnat_node
);
5494 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
5495 gnu_call
= gnu_retval
;
5498 /* If this is a subprogram with copy-in/copy-out parameters, we need to
5499 unpack the valued returned from the function into the In Out or Out
5500 parameters. We deal with the function return (if this is an Ada
5502 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
5504 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
5505 copy-out parameters. */
5506 tree gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
5507 const int length
= list_length (gnu_cico_list
);
5509 /* The call sequence must contain one and only one call, even though the
5510 function is pure. Save the result into a temporary if needed. */
5517 = create_init_temporary ("P", gnu_call
, &gnu_stmt
, gnat_node
);
5518 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
5521 gnu_name_list
= nreverse (gnu_name_list
);
5524 /* The first entry is for the actual return value if this is a
5525 function, so skip it. */
5527 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
5529 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
5530 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
5532 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
5534 for (gnat_actual
= First_Actual (gnat_node
);
5535 Present (gnat_actual
);
5536 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
5537 gnat_actual
= Next_Actual (gnat_actual
))
5538 /* If we are dealing with a copy-in/copy-out parameter, we must
5539 retrieve its value from the record returned in the call. */
5540 if (!(present_gnu_tree (gnat_formal
)
5541 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
5542 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
5543 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))))
5544 && Ekind (gnat_formal
) != E_In_Parameter
)
5546 /* Get the value to assign to this In Out or Out parameter. It is
5547 either the result of the function if there is only a single such
5548 parameter or the appropriate field from the record returned. */
5552 : build_component_ref (gnu_call
, TREE_PURPOSE (gnu_cico_list
),
5555 /* If the actual is a conversion, get the inner expression, which
5556 will be the real destination, and convert the result to the
5557 type of the actual parameter. */
5559 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
5561 /* If the result is a padded type, remove the padding. */
5562 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
5564 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
5567 /* If the actual is a type conversion, the real target object is
5568 denoted by the inner Expression and we need to convert the
5569 result to the associated type.
5570 We also need to convert our gnu assignment target to this type
5571 if the corresponding GNU_NAME was constructed from the GNAT
5572 conversion node and not from the inner Expression. */
5573 if (Nkind (gnat_actual
) == N_Type_Conversion
)
5576 = convert_with_check
5577 (Etype (Expression (gnat_actual
)), gnu_result
,
5578 Do_Overflow_Check (gnat_actual
),
5579 Do_Range_Check (Expression (gnat_actual
)),
5580 Float_Truncate (gnat_actual
), gnat_actual
);
5582 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal
))))
5583 gnu_actual
= convert (TREE_TYPE (gnu_result
), gnu_actual
);
5586 /* Unchecked conversions as actuals for Out parameters are not
5587 allowed in user code because they are not variables, but do
5588 occur in front-end expansions. The associated GNU_NAME is
5589 always obtained from the inner expression in such cases. */
5590 else if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
5591 gnu_result
= unchecked_convert (TREE_TYPE (gnu_actual
),
5593 No_Truncation (gnat_actual
));
5596 if (Do_Range_Check (gnat_actual
))
5598 = emit_range_check (gnu_result
, Etype (gnat_actual
),
5601 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
5602 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
5603 gnu_result
= convert (TREE_TYPE (gnu_actual
), gnu_result
);
5606 /* If an outer atomic access is required for an actual parameter,
5607 build the load-modify-store sequence. */
5608 if (outer_atomic_access_required_p (gnat_actual
))
5610 = build_load_modify_store (gnu_actual
, gnu_result
, gnat_node
);
5612 /* Or else, if simple atomic access is required, build the atomic
5614 else if (atomic_access_required_p (gnat_actual
, &sync
))
5615 gnu_result
= build_atomic_store (gnu_actual
, gnu_result
, sync
);
5617 /* Otherwise build a regular assignment. */
5619 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5620 gnu_actual
, gnu_result
);
5622 if (EXPR_P (gnu_result
))
5623 set_expr_location_from_node (gnu_result
, gnat_node
);
5624 append_to_statement_list (gnu_result
, &gnu_stmt_list
);
5625 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
5626 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
5630 /* If this is a function call, the result is the call expression unless a
5631 target is specified, in which case we copy the result into the target
5632 and return the assignment statement. */
5635 /* If this is a function with copy-in/copy-out parameters, extract the
5636 return value from it and update the return type. */
5637 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
5639 tree gnu_elmt
= TYPE_CI_CO_LIST (gnu_subprog_type
);
5641 = build_component_ref (gnu_call
, TREE_PURPOSE (gnu_elmt
), false);
5642 gnu_result_type
= TREE_TYPE (gnu_call
);
5645 /* If the function returns an unconstrained array or by direct reference,
5646 we have to dereference the pointer. */
5647 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
)
5648 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
))
5649 gnu_call
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_call
);
5653 Node_Id gnat_parent
= Parent (gnat_node
);
5654 enum tree_code op_code
;
5656 /* If range check is needed, emit code to generate it. */
5657 if (Do_Range_Check (gnat_node
))
5659 = emit_range_check (gnu_call
, Etype (Name (gnat_parent
)),
5662 /* ??? If the return type has variable size, then force the return
5663 slot optimization as we would not be able to create a temporary.
5664 That's what has been done historically. */
5665 if (return_type_with_variable_size_p (gnu_result_type
))
5666 op_code
= INIT_EXPR
;
5668 op_code
= MODIFY_EXPR
;
5670 /* Use the required method to move the result to the target. */
5671 if (outer_atomic_access
)
5673 = build_load_modify_store (gnu_target
, gnu_call
, gnat_node
);
5674 else if (atomic_access
)
5675 gnu_call
= build_atomic_store (gnu_target
, gnu_call
, atomic_sync
);
5678 = build_binary_op (op_code
, NULL_TREE
, gnu_target
, gnu_call
);
5680 if (EXPR_P (gnu_call
))
5681 set_expr_location_from_node (gnu_call
, gnat_parent
);
5682 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
5685 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
5688 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
5689 parameters, the result is just the call statement. */
5690 else if (!TYPE_CI_CO_LIST (gnu_subprog_type
))
5691 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
5693 /* Finally, add the copy back statements, if any. */
5694 append_to_statement_list (gnu_after_list
, &gnu_stmt_list
);
5696 if (went_into_elab_proc
)
5697 current_function_decl
= NULL_TREE
;
5699 /* If we have pushed a binding level, pop it and finish up the enclosing
5701 if (pushed_binding_level
)
5703 add_stmt (gnu_stmt_list
);
5705 gnu_result
= end_stmt_group ();
5708 /* Otherwise, retrieve the statement list, if any. */
5709 else if (gnu_stmt_list
)
5710 gnu_result
= gnu_stmt_list
;
5712 /* Otherwise, just return the call expression. */
5716 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
5717 But first simplify if we have only one statement in the list. */
5718 if (returning_value
)
5720 tree first
= expr_first (gnu_result
), last
= expr_last (gnu_result
);
5724 = build_compound_expr (TREE_TYPE (gnu_call
), gnu_result
, gnu_call
);
5730 /* Subroutine of gnat_to_gnu to translate gnat_node, an
5731 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
5734 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node
)
5736 /* If just annotating, ignore all EH and cleanups. */
5738 = (!type_annotate_only
5739 && Present (Exception_Handlers (gnat_node
))
5740 && Back_End_Exceptions ());
5741 const bool fe_sjlj_eh
5742 = (!type_annotate_only
5743 && Present (Exception_Handlers (gnat_node
))
5744 && Exception_Mechanism
== Front_End_SJLJ
);
5745 const bool at_end
= !type_annotate_only
&& Present (At_End_Proc (gnat_node
));
5746 const bool binding_for_block
= (at_end
|| gcc_eh
|| fe_sjlj_eh
);
5747 tree gnu_jmpsave_decl
= NULL_TREE
;
5748 tree gnu_jmpbuf_decl
= NULL_TREE
;
5749 tree gnu_inner_block
; /* The statement(s) for the block itself. */
5754 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
5755 and the front-end has its own SJLJ mechanism. To call the GCC mechanism,
5756 we call add_cleanup, and when we leave the binding, end_stmt_group will
5757 create the TRY_FINALLY_EXPR construct.
5759 ??? The region level calls down there have been specifically put in place
5760 for a ZCX context and currently the order in which things are emitted
5761 (region/handlers) is different from the SJLJ case. Instead of putting
5762 other calls with different conditions at other places for the SJLJ case,
5763 it seems cleaner to reorder things for the SJLJ case and generalize the
5764 condition to make it not ZCX specific.
5766 If there are any exceptions or cleanup processing involved, we need an
5767 outer statement group (for front-end SJLJ) and binding level. */
5768 if (binding_for_block
)
5770 start_stmt_group ();
5774 /* If using fe_sjlj_eh, make the variables for the setjmp buffer and save
5775 area for address of previous buffer. Do this first since we need to have
5776 the setjmp buf known for any decls in this block. */
5780 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
5782 build_call_n_expr (get_jmpbuf_decl
, 0),
5783 false, false, false, false, false, true, false,
5786 /* The __builtin_setjmp receivers will immediately reinstall it. Now
5787 because of the unstructured form of EH used by fe_sjlj_eh, there
5788 might be forward edges going to __builtin_setjmp receivers on which
5789 it is uninitialized, although they will never be actually taken. */
5790 TREE_NO_WARNING (gnu_jmpsave_decl
) = 1;
5792 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE
,
5795 false, false, false, false, false, true, false,
5798 set_block_jmpbuf_decl (gnu_jmpbuf_decl
);
5800 /* When we exit this block, restore the saved value. */
5801 add_cleanup (build_call_n_expr (set_jmpbuf_decl
, 1, gnu_jmpsave_decl
),
5802 Present (End_Label (gnat_node
))
5803 ? End_Label (gnat_node
) : gnat_node
);
5806 /* If we are to call a function when exiting this block, add a cleanup
5807 to the binding level we made above. Note that add_cleanup is FIFO
5808 so we must register this cleanup after the EH cleanup just above. */
5811 tree proc_decl
= gnat_to_gnu (At_End_Proc (gnat_node
));
5813 /* When not optimizing, disable inlining of finalizers as this can
5814 create a more complex CFG in the parent function. */
5816 DECL_DECLARED_INLINE_P (proc_decl
) = 0;
5818 /* If there is no end label attached, we use the location of the At_End
5819 procedure because Expand_Cleanup_Actions might reset the location of
5820 the enclosing construct to that of an inner statement. */
5821 add_cleanup (build_call_n_expr (proc_decl
, 0),
5822 Present (End_Label (gnat_node
))
5823 ? End_Label (gnat_node
) : At_End_Proc (gnat_node
));
5826 /* Now build the tree for the declarations and statements inside this block.
5827 If this is SJLJ, set our jmp_buf as the current buffer. */
5828 start_stmt_group ();
5832 gnu_expr
= build_call_n_expr (set_jmpbuf_decl
, 1,
5833 build_unary_op (ADDR_EXPR
, NULL_TREE
,
5835 set_expr_location_from_node (gnu_expr
, gnat_node
);
5836 add_stmt (gnu_expr
);
5839 if (Present (First_Real_Statement (gnat_node
)))
5840 process_decls (Statements (gnat_node
), Empty
,
5841 First_Real_Statement (gnat_node
), true, true);
5843 /* Generate code for each statement in the block. */
5844 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
5845 ? First_Real_Statement (gnat_node
)
5846 : First (Statements (gnat_node
)));
5847 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
5848 add_stmt (gnat_to_gnu (gnat_temp
));
5850 gnu_inner_block
= end_stmt_group ();
5852 /* Now generate code for the two exception models, if either is relevant for
5856 tree
*gnu_else_ptr
= 0;
5859 /* Make a binding level for the exception handling declarations and code
5860 and set up gnu_except_ptr_stack for the handlers to use. */
5861 start_stmt_group ();
5864 vec_safe_push (gnu_except_ptr_stack
,
5865 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
5866 build_pointer_type (except_type_node
),
5867 build_call_n_expr (get_excptr_decl
, 0),
5868 false, false, false, false, false,
5869 true, false, NULL
, gnat_node
));
5871 /* Generate code for each handler. The N_Exception_Handler case does the
5872 real work and returns a COND_EXPR for each handler, which we chain
5874 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
5875 Present (gnat_temp
); gnat_temp
= Next_Non_Pragma (gnat_temp
))
5877 gnu_expr
= gnat_to_gnu (gnat_temp
);
5879 /* If this is the first one, set it as the outer one. Otherwise,
5880 point the "else" part of the previous handler to us. Then point
5881 to our "else" part. */
5883 add_stmt (gnu_expr
);
5885 *gnu_else_ptr
= gnu_expr
;
5887 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
5890 /* If none of the exception handlers did anything, re-raise but do not
5892 gnu_expr
= build_call_n_expr (raise_nodefer_decl
, 1,
5893 gnu_except_ptr_stack
->last ());
5894 set_expr_location_from_node
5896 Present (End_Label (gnat_node
)) ? End_Label (gnat_node
) : gnat_node
);
5899 *gnu_else_ptr
= gnu_expr
;
5901 add_stmt (gnu_expr
);
5903 /* End the binding level dedicated to the exception handlers and get the
5904 whole statement group. */
5905 gnu_except_ptr_stack
->pop ();
5907 gnu_handler
= end_stmt_group ();
5909 /* If the setjmp returns 1, we restore our incoming longjmp value and
5910 then check the handlers. */
5911 start_stmt_group ();
5912 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl
, 1,
5915 add_stmt (gnu_handler
);
5916 gnu_handler
= end_stmt_group ();
5918 /* This block is now "if (setjmp) ... <handlers> else <block>". */
5919 gnu_result
= build3 (COND_EXPR
, void_type_node
,
5922 build_unary_op (ADDR_EXPR
, NULL_TREE
,
5924 gnu_handler
, gnu_inner_block
);
5931 /* First make a block containing the handlers. */
5932 start_stmt_group ();
5933 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
5934 Present (gnat_temp
);
5935 gnat_temp
= Next_Non_Pragma (gnat_temp
))
5936 add_stmt (gnat_to_gnu (gnat_temp
));
5937 gnu_handlers
= end_stmt_group ();
5939 /* Now make the TRY_CATCH_EXPR for the block. */
5940 gnu_result
= build2 (TRY_CATCH_EXPR
, void_type_node
,
5941 gnu_inner_block
, gnu_handlers
);
5942 /* Set a location. We need to find a unique location for the dispatching
5943 code, otherwise we can get coverage or debugging issues. Try with
5944 the location of the end label. */
5945 if (Present (End_Label (gnat_node
))
5946 && Sloc_to_locus (Sloc (End_Label (gnat_node
)), &locus
))
5947 SET_EXPR_LOCATION (gnu_result
, locus
);
5949 /* Clear column information so that the exception handler of an
5950 implicit transient block does not incorrectly inherit the slocs
5951 of a decision, which would otherwise confuse control flow based
5952 coverage analysis tools. */
5953 set_expr_location_from_node (gnu_result
, gnat_node
, true);
5956 gnu_result
= gnu_inner_block
;
5958 /* Now close our outer block, if we had to make one. */
5959 if (binding_for_block
)
5961 add_stmt (gnu_result
);
5963 gnu_result
= end_stmt_group ();
5969 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5970 to a GCC tree, which is returned. This is the variant for front-end sjlj
5971 exception handling. */
5974 Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node
)
5976 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
5977 an "if" statement to select the proper exceptions. For "Others", exclude
5978 exceptions where Handled_By_Others is nonzero unless the All_Others flag
5979 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
5980 tree gnu_choice
= boolean_false_node
;
5981 tree gnu_body
= build_stmt_group (Statements (gnat_node
), false);
5984 for (gnat_temp
= First (Exception_Choices (gnat_node
));
5985 gnat_temp
; gnat_temp
= Next (gnat_temp
))
5989 if (Nkind (gnat_temp
) == N_Others_Choice
)
5991 if (All_Others (gnat_temp
))
5992 this_choice
= boolean_true_node
;
5996 (EQ_EXPR
, boolean_type_node
,
6001 (INDIRECT_REF
, NULL_TREE
,
6002 gnu_except_ptr_stack
->last ()),
6003 not_handled_by_others_decl
,
6008 else if (Nkind (gnat_temp
) == N_Identifier
6009 || Nkind (gnat_temp
) == N_Expanded_Name
)
6011 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
6014 /* Exception may be a renaming. Recover original exception which is
6015 the one elaborated and registered. */
6016 if (Present (Renamed_Object (gnat_ex_id
)))
6017 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
6019 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, false);
6023 (EQ_EXPR
, boolean_type_node
,
6024 gnu_except_ptr_stack
->last (),
6025 convert (TREE_TYPE (gnu_except_ptr_stack
->last ()),
6026 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
6031 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
6032 gnu_choice
, this_choice
);
6035 return build3 (COND_EXPR
, void_type_node
, gnu_choice
, gnu_body
, NULL_TREE
);
6038 /* Return true if no statement in GNAT_LIST can alter the control flow. */
6041 stmt_list_cannot_alter_control_flow_p (List_Id gnat_list
)
6046 /* This is very conservative, we reject everything except for simple
6047 assignments between identifiers or literals. */
6048 for (Node_Id gnat_node
= First (gnat_list
);
6049 Present (gnat_node
);
6050 gnat_node
= Next (gnat_node
))
6052 if (Nkind (gnat_node
) != N_Assignment_Statement
)
6055 if (Nkind (Name (gnat_node
)) != N_Identifier
)
6058 Node_Kind nkind
= Nkind (Expression (gnat_node
));
6059 if (nkind
!= N_Identifier
6060 && nkind
!= N_Integer_Literal
6061 && nkind
!= N_Real_Literal
)
6068 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
6069 to a GCC tree, which is returned. This is the variant for GCC exception
6073 Exception_Handler_to_gnu_gcc (Node_Id gnat_node
)
6075 tree gnu_etypes_list
= NULL_TREE
;
6077 /* We build a TREE_LIST of nodes representing what exception types this
6078 handler can catch, with special cases for others and all others cases.
6080 Each exception type is actually identified by a pointer to the exception
6081 id, or to a dummy object for "others" and "all others". */
6082 for (Node_Id gnat_temp
= First (Exception_Choices (gnat_node
));
6084 gnat_temp
= Next (gnat_temp
))
6086 tree gnu_expr
, gnu_etype
;
6088 if (Nkind (gnat_temp
) == N_Others_Choice
)
6090 gnu_expr
= All_Others (gnat_temp
) ? all_others_decl
: others_decl
;
6091 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
6093 else if (Nkind (gnat_temp
) == N_Identifier
6094 || Nkind (gnat_temp
) == N_Expanded_Name
)
6096 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
6098 /* Exception may be a renaming. Recover original exception which is
6099 the one elaborated and registered. */
6100 if (Present (Renamed_Object (gnat_ex_id
)))
6101 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
6103 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, false);
6104 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
6109 /* The GCC interface expects NULL to be passed for catch all handlers, so
6110 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
6111 is integer_zero_node. It would not work, however, because GCC's
6112 notion of "catch all" is stronger than our notion of "others". Until
6113 we correctly use the cleanup interface as well, doing that would
6114 prevent the "all others" handlers from being seen, because nothing
6115 can be caught beyond a catch all from GCC's point of view. */
6116 gnu_etypes_list
= tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
6119 start_stmt_group ();
6122 /* Expand a call to the begin_handler hook at the beginning of the handler,
6123 and arrange for a call to the end_handler hook to occur on every possible
6126 The hooks expect a pointer to the low level occurrence. This is required
6127 for our stack management scheme because a raise inside the handler pushes
6128 a new occurrence on top of the stack, which means that this top does not
6129 necessarily match the occurrence this handler was dealing with.
6131 __builtin_eh_pointer references the exception occurrence being
6132 propagated. Upon handler entry, this is the exception for which the
6133 handler is triggered. This might not be the case upon handler exit,
6134 however, as we might have a new occurrence propagated by the handler's
6135 body, and the end_handler hook called as a cleanup in this context.
6137 We use a local variable to retrieve the incoming value at handler entry
6138 time, and reuse it to feed the end_handler hook's argument at exit. */
6140 tree gnu_current_exc_ptr
6141 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
6142 1, integer_zero_node
);
6143 tree prev_gnu_incoming_exc_ptr
= gnu_incoming_exc_ptr
;
6144 gnu_incoming_exc_ptr
6145 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
6146 ptr_type_node
, gnu_current_exc_ptr
,
6147 false, false, false, false, false, true, true,
6150 add_stmt_with_node (build_call_n_expr (begin_handler_decl
, 1,
6151 gnu_incoming_exc_ptr
),
6154 /* Declare and initialize the choice parameter, if present. */
6155 if (Present (Choice_Parameter (gnat_node
)))
6158 = gnat_to_gnu_entity (Choice_Parameter (gnat_node
), NULL_TREE
, true);
6160 add_stmt (build_call_n_expr
6161 (set_exception_parameter_decl
, 2,
6162 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_param
),
6163 gnu_incoming_exc_ptr
));
6166 add_stmt_list (Statements (gnat_node
));
6168 /* We don't have an End_Label at hand to set the location of the cleanup
6169 actions, so we use that of the exception handler itself instead. */
6170 tree stmt
= build_call_n_expr (end_handler_decl
, 1, gnu_incoming_exc_ptr
);
6171 if (stmt_list_cannot_alter_control_flow_p (Statements (gnat_node
)))
6172 add_stmt_with_node (stmt
, gnat_node
);
6174 add_cleanup (stmt
, gnat_node
);
6178 gnu_incoming_exc_ptr
= prev_gnu_incoming_exc_ptr
;
6181 build2 (CATCH_EXPR
, void_type_node
, gnu_etypes_list
, end_stmt_group ());
6184 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
6187 Compilation_Unit_to_gnu (Node_Id gnat_node
)
6189 const Node_Id gnat_unit
= Unit (gnat_node
);
6190 const bool body_p
= (Nkind (gnat_unit
) == N_Package_Body
6191 || Nkind (gnat_unit
) == N_Subprogram_Body
);
6192 const Entity_Id gnat_unit_entity
= Defining_Entity (gnat_unit
);
6193 Entity_Id gnat_entity
;
6194 Node_Id gnat_pragma
;
6195 /* Make the decl for the elaboration procedure. Emit debug info for it, so
6196 that users can break into their elaboration code in debuggers. Kludge:
6197 don't consider it as a definition so that we have a line map for its body,
6198 but no subprogram description in debug info. */
6199 tree gnu_elab_proc_decl
6200 = create_subprog_decl
6201 (create_concat_name (gnat_unit_entity
, body_p
? "elabb" : "elabs"),
6202 NULL_TREE
, void_ftype
, NULL_TREE
,
6203 is_default
, true, false, true, true, false, NULL
, gnat_unit
);
6204 struct elab_info
*info
;
6206 vec_safe_push (gnu_elab_proc_stack
, gnu_elab_proc_decl
);
6207 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl
) = 1;
6209 /* Initialize the information structure for the function. */
6210 allocate_struct_function (gnu_elab_proc_decl
, false);
6213 current_function_decl
= NULL_TREE
;
6215 start_stmt_group ();
6218 /* For a body, first process the spec if there is one. */
6219 if (Nkind (gnat_unit
) == N_Package_Body
6220 || (Nkind (gnat_unit
) == N_Subprogram_Body
&& !Acts_As_Spec (gnat_node
)))
6221 add_stmt (gnat_to_gnu (Library_Unit (gnat_node
)));
6223 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
6225 elaborate_all_entities (gnat_node
);
6227 if (Nkind (gnat_unit
) == N_Subprogram_Declaration
6228 || Nkind (gnat_unit
) == N_Generic_Package_Declaration
6229 || Nkind (gnat_unit
) == N_Generic_Subprogram_Declaration
)
6233 /* Then process any pragmas and declarations preceding the unit. */
6234 for (gnat_pragma
= First (Context_Items (gnat_node
));
6235 Present (gnat_pragma
);
6236 gnat_pragma
= Next (gnat_pragma
))
6237 if (Nkind (gnat_pragma
) == N_Pragma
)
6238 add_stmt (gnat_to_gnu (gnat_pragma
));
6239 process_decls (Declarations (Aux_Decls_Node (gnat_node
)), Empty
, Empty
,
6242 /* Process the unit itself. */
6243 add_stmt (gnat_to_gnu (gnat_unit
));
6245 /* Generate code for all the inlined subprograms. */
6246 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
6247 Present (gnat_entity
);
6248 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
6252 /* Without optimization, process only the required subprograms. */
6253 if (!optimize
&& !Has_Pragma_Inline_Always (gnat_entity
))
6256 /* The set of inlined subprograms is computed from data recorded early
6257 during expansion and it can be a strict superset of the final set
6258 computed after semantic analysis, for example if a call to such a
6259 subprogram occurs in a pragma Assert and assertions are disabled.
6260 In that case, semantic analysis resets Is_Public to false but the
6261 entry for the subprogram in the inlining tables is stalled. */
6262 if (!Is_Public (gnat_entity
))
6265 gnat_body
= Parent (Declaration_Node (gnat_entity
));
6266 if (Nkind (gnat_body
) != N_Subprogram_Body
)
6268 /* ??? This happens when only the spec of a package is provided. */
6269 if (No (Corresponding_Body (gnat_body
)))
6273 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
6276 /* Define the entity first so we set DECL_EXTERNAL. */
6277 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
6278 add_stmt (gnat_to_gnu (gnat_body
));
6281 /* Process any pragmas and actions following the unit. */
6282 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node
)));
6283 add_stmt_list (Actions (Aux_Decls_Node (gnat_node
)));
6284 finalize_from_limited_with ();
6286 /* Save away what we've made so far and finish it up. */
6287 set_current_block_context (gnu_elab_proc_decl
);
6289 DECL_SAVED_TREE (gnu_elab_proc_decl
) = end_stmt_group ();
6290 set_end_locus_from_node (gnu_elab_proc_decl
, gnat_unit
);
6291 gnu_elab_proc_stack
->pop ();
6293 /* Record this potential elaboration procedure for later processing. */
6294 info
= ggc_alloc
<elab_info
> ();
6295 info
->next
= elab_info_list
;
6296 info
->elab_proc
= gnu_elab_proc_decl
;
6297 info
->gnat_node
= gnat_node
;
6298 elab_info_list
= info
;
6300 /* Force the processing for all nodes that remain in the queue. */
6301 process_deferred_decl_context (true);
6304 /* Mark COND, a boolean expression, as predicating a call to a noreturn
6305 function, i.e. predict that it is very likely false, and return it.
6307 The compiler will automatically predict the last edge leading to a call
6308 to a noreturn function as very unlikely taken. This function makes it
6309 possible to expand the prediction to predecessors in case the condition
6310 is made up of several short-circuit operators. */
6313 build_noreturn_cond (tree cond
)
6315 tree fn
= builtin_decl_explicit (BUILT_IN_EXPECT
);
6316 tree arg_types
= TYPE_ARG_TYPES (TREE_TYPE (fn
));
6317 tree pred_type
= TREE_VALUE (arg_types
);
6318 tree expected_type
= TREE_VALUE (TREE_CHAIN (arg_types
));
6320 tree t
= build_call_expr (fn
, 3,
6321 fold_convert (pred_type
, cond
),
6322 build_int_cst (expected_type
, 0),
6323 build_int_cst (integer_type_node
,
6326 return build1 (NOP_EXPR
, boolean_type_node
, t
);
6329 /* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a
6330 range of values, into GNU_LOW and GNU_HIGH bounds. */
6333 Range_to_gnu (Node_Id gnat_range
, tree
*gnu_low
, tree
*gnu_high
)
6335 /* GNAT_RANGE is either an N_Range or an identifier denoting a subtype. */
6336 switch (Nkind (gnat_range
))
6339 *gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
6340 *gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
6343 case N_Expanded_Name
:
6346 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
6347 tree gnu_range_base_type
= get_base_type (gnu_range_type
);
6350 = convert (gnu_range_base_type
, TYPE_MIN_VALUE (gnu_range_type
));
6352 = convert (gnu_range_base_type
, TYPE_MAX_VALUE (gnu_range_type
));
6361 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
6362 to a GCC tree and return it. GNU_RESULT_TYPE_P is a pointer to where
6363 we should place the result type. */
6366 Raise_Error_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
6368 const Node_Kind kind
= Nkind (gnat_node
);
6369 const int reason
= UI_To_Int (Reason (gnat_node
));
6370 const Node_Id gnat_cond
= Condition (gnat_node
);
6371 const bool with_extra_info
6372 = Exception_Extra_Info
6373 && !No_Exception_Handlers_Set ()
6374 && No (get_exception_label (kind
));
6375 tree gnu_result
= NULL_TREE
, gnu_cond
= NULL_TREE
;
6377 /* The following processing is not required for correctness. Its purpose is
6378 to give more precise error messages and to record some information. */
6381 case CE_Access_Check_Failed
:
6382 if (with_extra_info
)
6383 gnu_result
= build_call_raise_column (reason
, gnat_node
, kind
);
6386 case CE_Index_Check_Failed
:
6387 case CE_Range_Check_Failed
:
6388 case CE_Invalid_Data
:
6389 if (Present (gnat_cond
) && Nkind (gnat_cond
) == N_Op_Not
)
6391 Node_Id gnat_index
, gnat_type
;
6392 tree gnu_type
, gnu_index
, gnu_low_bound
, gnu_high_bound
, disp
;
6394 struct loop_info_d
*loop
;
6396 switch (Nkind (Right_Opnd (gnat_cond
)))
6399 Range_to_gnu (Right_Opnd (Right_Opnd (gnat_cond
)),
6400 &gnu_low_bound
, &gnu_high_bound
);
6404 gnu_low_bound
= gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond
)));
6405 gnu_high_bound
= NULL_TREE
;
6409 gnu_low_bound
= NULL_TREE
;
6410 gnu_high_bound
= gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond
)));
6417 gnat_index
= Left_Opnd (Right_Opnd (gnat_cond
));
6418 gnat_type
= Etype (gnat_index
);
6419 gnu_type
= maybe_character_type (get_unpadded_type (gnat_type
));
6420 gnu_index
= gnat_to_gnu (gnat_index
);
6422 if (TREE_TYPE (gnu_index
) != gnu_type
)
6425 gnu_low_bound
= convert (gnu_type
, gnu_low_bound
);
6427 gnu_high_bound
= convert (gnu_type
, gnu_high_bound
);
6428 gnu_index
= convert (gnu_type
, gnu_index
);
6434 && Known_Esize (gnat_type
)
6435 && UI_To_Int (Esize (gnat_type
)) <= 32)
6437 = build_call_raise_range (reason
, gnat_node
, kind
, gnu_index
,
6438 gnu_low_bound
, gnu_high_bound
);
6440 /* If optimization is enabled and we are inside a loop, we try to
6441 compute invariant conditions for checks applied to the iteration
6442 variable, i.e. conditions that are independent of the variable
6443 and necessary in order for the checks to fail in the course of
6444 some iteration. If we succeed, we consider an alternative:
6446 1. If loop unswitching is enabled, we prepend these conditions
6447 to the original conditions of the checks. This will make it
6448 possible for the loop unswitching pass to replace the loop
6449 with two loops, one of which has the checks eliminated and
6450 the other has the original checks reinstated, and a prologue
6451 implementing a run-time selection. The former loop will be
6452 for example suitable for vectorization.
6454 2. Otherwise, we instead append the conditions to the original
6455 conditions of the checks. At worse, if the conditions cannot
6456 be evaluated at compile time, they will be evaluated as true
6457 at run time only when the checks have already failed, thus
6458 contributing negatively only to the size of the executable.
6459 But the hope is that these invariant conditions be evaluated
6460 at compile time to false, thus taking away the entire checks
6465 || (gnu_low_bound
= gnat_invariant_expr (gnu_low_bound
)))
6467 || (gnu_high_bound
= gnat_invariant_expr (gnu_high_bound
)))
6468 && (loop
= find_loop_for (gnu_index
, &disp
, &neg_p
)))
6470 struct range_check_info_d
*rci
= ggc_alloc
<range_check_info_d
> ();
6471 rci
->low_bound
= gnu_low_bound
;
6472 rci
->high_bound
= gnu_high_bound
;
6475 rci
->type
= gnu_type
;
6477 = build1 (SAVE_EXPR
, boolean_type_node
, boolean_true_node
);
6478 vec_safe_push (loop
->checks
, rci
);
6479 gnu_cond
= build_noreturn_cond (gnat_to_gnu (gnat_cond
));
6481 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6486 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6489 rci
->inserted_cond
);
6498 /* The following processing does the common work. */
6501 gnu_result
= build_call_raise (reason
, gnat_node
, kind
);
6502 set_expr_location_from_node (gnu_result
, gnat_node
);
6504 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
6506 /* If the type is VOID, this is a statement, so we need to generate the code
6507 for the call. Handle a condition, if there is one. */
6508 if (VOID_TYPE_P (*gnu_result_type_p
))
6510 if (Present (gnat_cond
))
6513 gnu_cond
= gnat_to_gnu (gnat_cond
);
6514 gnu_result
= build3 (COND_EXPR
, void_type_node
, gnu_cond
, gnu_result
,
6515 alloc_stmt_list ());
6519 gnu_result
= build1 (NULL_EXPR
, *gnu_result_type_p
, gnu_result
);
6524 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
6525 parameter of a call. */
6528 lhs_or_actual_p (Node_Id gnat_node
)
6530 Node_Id gnat_parent
= Parent (gnat_node
);
6531 Node_Kind kind
= Nkind (gnat_parent
);
6533 if (kind
== N_Assignment_Statement
&& Name (gnat_parent
) == gnat_node
)
6536 if ((kind
== N_Procedure_Call_Statement
|| kind
== N_Function_Call
)
6537 && Name (gnat_parent
) != gnat_node
)
6540 if (kind
== N_Parameter_Association
)
6546 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
6547 of an assignment or an actual parameter of a call. */
6550 present_in_lhs_or_actual_p (Node_Id gnat_node
)
6554 if (lhs_or_actual_p (gnat_node
))
6557 kind
= Nkind (Parent (gnat_node
));
6559 if ((kind
== N_Type_Conversion
|| kind
== N_Unchecked_Type_Conversion
)
6560 && lhs_or_actual_p (Parent (gnat_node
)))
6566 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
6567 as gigi is concerned. This is used to avoid conversions on the LHS. */
6570 unchecked_conversion_nop (Node_Id gnat_node
)
6572 Entity_Id from_type
, to_type
;
6574 /* The conversion must be on the LHS of an assignment or an actual parameter
6575 of a call. Otherwise, even if the conversion was essentially a no-op, it
6576 could de facto ensure type consistency and this should be preserved. */
6577 if (!lhs_or_actual_p (gnat_node
))
6580 from_type
= Etype (Expression (gnat_node
));
6582 /* We're interested in artificial conversions generated by the front-end
6583 to make private types explicit, e.g. in Expand_Assign_Array. */
6584 if (!Is_Private_Type (from_type
))
6587 from_type
= Underlying_Type (from_type
);
6588 to_type
= Etype (gnat_node
);
6590 /* The direct conversion to the underlying type is a no-op. */
6591 if (to_type
== from_type
)
6594 /* For an array subtype, the conversion to the PAIT is a no-op. */
6595 if (Ekind (from_type
) == E_Array_Subtype
6596 && to_type
== Packed_Array_Impl_Type (from_type
))
6599 /* For a record subtype, the conversion to the type is a no-op. */
6600 if (Ekind (from_type
) == E_Record_Subtype
6601 && to_type
== Etype (from_type
))
6607 /* Return true if GNAT_NODE represents a statement. */
6610 statement_node_p (Node_Id gnat_node
)
6612 const Node_Kind kind
= Nkind (gnat_node
);
6614 if (kind
== N_Label
)
6617 if (IN (kind
, N_Statement_Other_Than_Procedure_Call
))
6620 if (kind
== N_Procedure_Call_Statement
)
6623 if (IN (kind
, N_Raise_xxx_Error
) && Ekind (Etype (gnat_node
)) == E_Void
)
6629 /* This function is the driver of the GNAT to GCC tree transformation process.
6630 It is the entry point of the tree transformer. GNAT_NODE is the root of
6631 some GNAT tree. Return the root of the corresponding GCC tree. If this
6632 is an expression, return the GCC equivalent of the expression. If this
6633 is a statement, return the statement or add it to the current statement
6634 group, in which case anything returned is to be interpreted as occurring
6635 after anything added. */
6638 gnat_to_gnu (Node_Id gnat_node
)
6640 const Node_Kind kind
= Nkind (gnat_node
);
6641 bool went_into_elab_proc
= false;
6642 tree gnu_result
= error_mark_node
; /* Default to no value. */
6643 tree gnu_result_type
= void_type_node
;
6644 tree gnu_expr
, gnu_lhs
, gnu_rhs
;
6648 /* Save node number for error message and set location information. */
6649 Current_Error_Node
= gnat_node
;
6650 Sloc_to_locus (Sloc (gnat_node
), &input_location
);
6652 /* If we are only annotating types and this node is a statement, return
6653 an empty statement list. */
6654 if (type_annotate_only
&& statement_node_p (gnat_node
))
6655 return alloc_stmt_list ();
6657 /* If we are only annotating types and this node is a subexpression, return
6658 a NULL_EXPR, but filter out nodes appearing in the expressions attached
6659 to packed array implementation types. */
6660 if (type_annotate_only
6661 && IN (kind
, N_Subexpr
)
6662 && !(((IN (kind
, N_Op
) && kind
!= N_Op_Expon
)
6663 || kind
== N_Type_Conversion
)
6664 && Is_Integer_Type (Etype (gnat_node
)))
6665 && !(kind
== N_Attribute_Reference
6666 && (Get_Attribute_Id (Attribute_Name (gnat_node
)) == Attr_Length
6667 || Get_Attribute_Id (Attribute_Name (gnat_node
)) == Attr_Size
)
6668 && Is_Constrained (Etype (Prefix (gnat_node
)))
6669 && !Is_Constr_Subt_For_U_Nominal (Etype (Prefix (gnat_node
))))
6670 && kind
!= N_Expanded_Name
6671 && kind
!= N_Identifier
6672 && !Compile_Time_Known_Value (gnat_node
))
6673 return build1 (NULL_EXPR
, get_unpadded_type (Etype (gnat_node
)),
6674 build_call_raise (CE_Range_Check_Failed
, gnat_node
,
6675 N_Raise_Constraint_Error
));
6677 if ((statement_node_p (gnat_node
) && kind
!= N_Null_Statement
)
6678 || kind
== N_Handled_Sequence_Of_Statements
6679 || kind
== N_Implicit_Label_Declaration
)
6681 tree current_elab_proc
= get_elaboration_procedure ();
6683 /* If this is a statement and we are at top level, it must be part of
6684 the elaboration procedure, so mark us as being in that procedure. */
6685 if (!current_function_decl
)
6687 current_function_decl
= current_elab_proc
;
6688 went_into_elab_proc
= true;
6691 /* If we are in the elaboration procedure, check if we are violating a
6692 No_Elaboration_Code restriction by having a statement there. Don't
6693 check for a possible No_Elaboration_Code restriction violation on
6694 N_Handled_Sequence_Of_Statements, as we want to signal an error on
6695 every nested real statement instead. This also avoids triggering
6696 spurious errors on dummy (empty) sequences created by the front-end
6697 for package bodies in some cases. */
6698 if (current_function_decl
== current_elab_proc
6699 && kind
!= N_Handled_Sequence_Of_Statements
6700 && kind
!= N_Implicit_Label_Declaration
)
6701 Check_Elaboration_Code_Allowed (gnat_node
);
6706 /********************************/
6707 /* Chapter 2: Lexical Elements */
6708 /********************************/
6711 case N_Expanded_Name
:
6712 case N_Operator_Symbol
:
6713 case N_Defining_Identifier
:
6714 case N_Defining_Operator_Symbol
:
6715 gnu_result
= Identifier_to_gnu (gnat_node
, &gnu_result_type
);
6717 /* If atomic access is required on the RHS, build the atomic load. */
6718 if (atomic_access_required_p (gnat_node
, &sync
)
6719 && !present_in_lhs_or_actual_p (gnat_node
))
6720 gnu_result
= build_atomic_load (gnu_result
, sync
);
6723 case N_Integer_Literal
:
6727 /* Get the type of the result, looking inside any padding and
6728 justified modular types. Then get the value in that type. */
6729 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6731 if (TREE_CODE (gnu_type
) == RECORD_TYPE
6732 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
6733 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
6735 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
6737 /* If the result overflows (meaning it doesn't fit in its base type),
6738 abort. We would like to check that the value is within the range
6739 of the subtype, but that causes problems with subtypes whose usage
6740 will raise Constraint_Error and with biased representation, so
6742 gcc_assert (!TREE_OVERFLOW (gnu_result
));
6746 case N_Character_Literal
:
6747 /* If a Entity is present, it means that this was one of the
6748 literals in a user-defined character type. In that case,
6749 just return the value in the CONST_DECL. Otherwise, use the
6750 character code. In that case, the base type should be an
6751 INTEGER_TYPE, but we won't bother checking for that. */
6752 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6753 if (Present (Entity (gnat_node
)))
6754 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
6757 = build_int_cst (gnu_result_type
,
6758 UI_To_CC (Char_Literal_Value (gnat_node
)));
6761 case N_Real_Literal
:
6762 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6764 /* If this is of a fixed-point type, the value we want is the value of
6765 the corresponding integer. */
6766 if (Is_Fixed_Point_Type (Underlying_Type (Etype (gnat_node
))))
6768 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
6770 gcc_assert (!TREE_OVERFLOW (gnu_result
));
6775 Ureal ur_realval
= Realval (gnat_node
);
6777 /* First convert the value to a machine number if it isn't already.
6778 That will force the base to 2 for non-zero values and simplify
6779 the rest of the logic. */
6780 if (!Is_Machine_Number (gnat_node
))
6782 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
6783 ur_realval
, Round_Even
, gnat_node
);
6785 if (UR_Is_Zero (ur_realval
))
6786 gnu_result
= build_real (gnu_result_type
, dconst0
);
6789 REAL_VALUE_TYPE tmp
;
6791 gnu_result
= UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
6793 /* The base must be 2 as Machine guarantees this, so we scale
6794 the value, which we know can fit in the mantissa of the type
6795 (hence the use of that type above). */
6796 gcc_assert (Rbase (ur_realval
) == 2);
6797 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
6798 - UI_To_Int (Denominator (ur_realval
)));
6799 gnu_result
= build_real (gnu_result_type
, tmp
);
6802 /* Now see if we need to negate the result. Do it this way to
6803 properly handle -0. */
6804 if (UR_Is_Negative (Realval (gnat_node
)))
6806 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
6812 case N_String_Literal
:
6813 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6814 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
6816 String_Id gnat_string
= Strval (gnat_node
);
6817 int length
= String_Length (gnat_string
);
6820 if (length
>= ALLOCA_THRESHOLD
)
6821 string
= XNEWVEC (char, length
+ 1);
6823 string
= (char *) alloca (length
+ 1);
6825 /* Build the string with the characters in the literal. Note
6826 that Ada strings are 1-origin. */
6827 for (i
= 0; i
< length
; i
++)
6828 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
6830 /* Put a null at the end of the string in case it's in a context
6831 where GCC will want to treat it as a C string. */
6834 gnu_result
= build_string (length
, string
);
6836 /* Strings in GCC don't normally have types, but we want
6837 this to not be converted to the array type. */
6838 TREE_TYPE (gnu_result
) = gnu_result_type
;
6840 if (length
>= ALLOCA_THRESHOLD
)
6845 /* Build a list consisting of each character, then make
6847 String_Id gnat_string
= Strval (gnat_node
);
6848 int length
= String_Length (gnat_string
);
6850 tree gnu_idx
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
6851 tree gnu_one_node
= convert (TREE_TYPE (gnu_idx
), integer_one_node
);
6852 vec
<constructor_elt
, va_gc
> *gnu_vec
;
6853 vec_alloc (gnu_vec
, length
);
6855 for (i
= 0; i
< length
; i
++)
6857 tree t
= build_int_cst (TREE_TYPE (gnu_result_type
),
6858 Get_String_Char (gnat_string
, i
+ 1));
6860 CONSTRUCTOR_APPEND_ELT (gnu_vec
, gnu_idx
, t
);
6861 gnu_idx
= int_const_binop (PLUS_EXPR
, gnu_idx
, gnu_one_node
);
6864 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
6869 gnu_result
= Pragma_to_gnu (gnat_node
);
6872 /**************************************/
6873 /* Chapter 3: Declarations and Types */
6874 /**************************************/
6876 case N_Subtype_Declaration
:
6877 case N_Full_Type_Declaration
:
6878 case N_Incomplete_Type_Declaration
:
6879 case N_Private_Type_Declaration
:
6880 case N_Private_Extension_Declaration
:
6881 case N_Task_Type_Declaration
:
6882 process_type (Defining_Entity (gnat_node
));
6883 gnu_result
= alloc_stmt_list ();
6886 case N_Object_Declaration
:
6887 case N_Exception_Declaration
:
6888 gnat_temp
= Defining_Entity (gnat_node
);
6889 gnu_result
= alloc_stmt_list ();
6891 /* If we are just annotating types and this object has an unconstrained
6892 or task type, don't elaborate it. */
6893 if (type_annotate_only
6894 && (((Is_Array_Type (Etype (gnat_temp
))
6895 || Is_Record_Type (Etype (gnat_temp
)))
6896 && !Is_Constrained (Etype (gnat_temp
)))
6897 || Is_Concurrent_Type (Etype (gnat_temp
))))
6900 if (Present (Expression (gnat_node
))
6901 && !(kind
== N_Object_Declaration
&& No_Initialization (gnat_node
))
6902 && (!type_annotate_only
6903 || Compile_Time_Known_Value (Expression (gnat_node
))))
6905 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
6906 if (Do_Range_Check (Expression (gnat_node
)))
6908 = emit_range_check (gnu_expr
, Etype (gnat_temp
), gnat_node
);
6910 if (type_annotate_only
&& TREE_CODE (gnu_expr
) == ERROR_MARK
)
6911 gnu_expr
= NULL_TREE
;
6914 gnu_expr
= NULL_TREE
;
6916 /* If this is a deferred constant with an address clause, we ignore the
6917 full view since the clause is on the partial view and we cannot have
6918 2 different GCC trees for the object. The only bits of the full view
6919 we will use is the initializer, but it will be directly fetched. */
6920 if (Ekind (gnat_temp
) == E_Constant
6921 && Present (Address_Clause (gnat_temp
))
6922 && Present (Full_View (gnat_temp
)))
6923 save_gnu_tree (Full_View (gnat_temp
), error_mark_node
, true);
6925 /* If this object has its elaboration delayed, we must force evaluation
6926 of GNU_EXPR now and save it for the freeze point. Note that we need
6927 not do anything special at the global level since the lifetime of the
6928 temporary is fully contained within the elaboration routine. */
6929 if (Present (Freeze_Node (gnat_temp
)))
6933 gnu_result
= gnat_save_expr (gnu_expr
);
6934 save_gnu_tree (gnat_node
, gnu_result
, true);
6938 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, true);
6941 case N_Object_Renaming_Declaration
:
6942 gnat_temp
= Defining_Entity (gnat_node
);
6943 gnu_result
= alloc_stmt_list ();
6945 /* Don't do anything if this renaming is handled by the front end and it
6946 does not need debug info. Note that we consider renamings don't need
6947 debug info when optimizing: our way to describe them has a
6948 memory/elaboration footprint.
6950 Don't do anything neither if we are just annotating types and this
6951 object has a composite or task type, don't elaborate it. */
6952 if ((!Is_Renaming_Of_Object (gnat_temp
)
6953 || (Needs_Debug_Info (gnat_temp
)
6955 && can_materialize_object_renaming_p
6956 (Renamed_Object (gnat_temp
))))
6957 && ! (type_annotate_only
6958 && (Is_Array_Type (Etype (gnat_temp
))
6959 || Is_Record_Type (Etype (gnat_temp
))
6960 || Is_Concurrent_Type (Etype (gnat_temp
)))))
6963 = gnat_to_gnu_entity (gnat_temp
,
6964 gnat_to_gnu (Renamed_Object (gnat_temp
)),
6966 /* See case 2 of renaming in gnat_to_gnu_entity. */
6967 if (TREE_SIDE_EFFECTS (gnu_temp
))
6968 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_temp
);
6972 case N_Exception_Renaming_Declaration
:
6973 gnat_temp
= Defining_Entity (gnat_node
);
6974 gnu_result
= alloc_stmt_list ();
6976 /* See the above case for the rationale. */
6977 if (Present (Renamed_Entity (gnat_temp
)))
6980 = gnat_to_gnu_entity (gnat_temp
,
6981 gnat_to_gnu (Renamed_Entity (gnat_temp
)),
6983 if (TREE_SIDE_EFFECTS (gnu_temp
))
6984 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_temp
);
6988 case N_Subprogram_Renaming_Declaration
:
6990 const Node_Id gnat_renaming
= Defining_Entity (gnat_node
);
6991 const Node_Id gnat_renamed
= Renamed_Entity (gnat_renaming
);
6993 gnu_result
= alloc_stmt_list ();
6995 /* Materializing renamed subprograms will only benefit the debugging
6996 information as they aren't referenced in the generated code. So
6997 skip them when they aren't needed. Avoid doing this if:
6999 - there is a freeze node: in this case the renamed entity is not
7001 - the renamed subprogram is intrinsic: it will not be available in
7002 the debugging information (note that both or only one of the
7003 renaming and the renamed subprograms can be intrinsic). */
7004 if (!type_annotate_only
7005 && Needs_Debug_Info (gnat_renaming
)
7006 && No (Freeze_Node (gnat_renaming
))
7007 && Present (gnat_renamed
)
7008 && (Ekind (gnat_renamed
) == E_Function
7009 || Ekind (gnat_renamed
) == E_Procedure
)
7010 && !Is_Intrinsic_Subprogram (gnat_renaming
)
7011 && !Is_Intrinsic_Subprogram (gnat_renamed
))
7012 gnat_to_gnu_entity (gnat_renaming
, gnat_to_gnu (gnat_renamed
), true);
7016 case N_Implicit_Label_Declaration
:
7017 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, true);
7018 gnu_result
= alloc_stmt_list ();
7021 case N_Number_Declaration
:
7022 case N_Package_Renaming_Declaration
:
7023 /* These are fully handled in the front end. */
7024 /* ??? For package renamings, find a way to use GENERIC namespaces so
7025 that we get proper debug information for them. */
7026 gnu_result
= alloc_stmt_list ();
7029 /*************************************/
7030 /* Chapter 4: Names and Expressions */
7031 /*************************************/
7033 case N_Explicit_Dereference
:
7034 /* Make sure the designated type is complete before dereferencing. */
7035 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7036 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
7037 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
7039 /* If atomic access is required on the RHS, build the atomic load. */
7040 if (atomic_access_required_p (gnat_node
, &sync
)
7041 && !present_in_lhs_or_actual_p (gnat_node
))
7042 gnu_result
= build_atomic_load (gnu_result
, sync
);
7045 case N_Indexed_Component
:
7047 tree gnu_array_object
7048 = gnat_to_gnu (adjust_for_implicit_deref (Prefix (gnat_node
)));
7052 Node_Id
*gnat_expr_array
;
7054 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
7056 /* Convert vector inputs to their representative array type, to fit
7057 what the code below expects. */
7058 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object
)))
7060 if (present_in_lhs_or_actual_p (gnat_node
))
7061 gnat_mark_addressable (gnu_array_object
);
7062 gnu_array_object
= maybe_vector_array (gnu_array_object
);
7065 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
7067 /* If we got a padded type, remove it too. */
7068 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
7070 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
7073 /* The failure of this assertion will very likely come from a missing
7074 expansion for a packed array access. */
7075 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object
)) == ARRAY_TYPE
);
7077 /* First compute the number of dimensions of the array, then
7078 fill the expression array, the order depending on whether
7079 this is a Convention_Fortran array or not. */
7080 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
7081 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
7082 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
7083 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
7086 gnat_expr_array
= XALLOCAVEC (Node_Id
, ndim
);
7088 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
7089 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
7091 i
--, gnat_temp
= Next (gnat_temp
))
7092 gnat_expr_array
[i
] = gnat_temp
;
7094 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
7096 i
++, gnat_temp
= Next (gnat_temp
))
7097 gnat_expr_array
[i
] = gnat_temp
;
7099 /* Start with the prefix and build the successive references. */
7100 gnu_result
= gnu_array_object
;
7102 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
7104 i
++, gnu_type
= TREE_TYPE (gnu_type
))
7106 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
7107 gnat_temp
= gnat_expr_array
[i
];
7108 gnu_expr
= maybe_character_value (gnat_to_gnu (gnat_temp
));
7111 = build_binary_op (ARRAY_REF
, NULL_TREE
, gnu_result
, gnu_expr
);
7114 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7116 /* If atomic access is required on the RHS, build the atomic load. */
7117 if (atomic_access_required_p (gnat_node
, &sync
)
7118 && !present_in_lhs_or_actual_p (gnat_node
))
7119 gnu_result
= build_atomic_load (gnu_result
, sync
);
7125 tree gnu_array_object
7126 = gnat_to_gnu (adjust_for_implicit_deref (Prefix (gnat_node
)));
7128 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7130 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
7131 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
7133 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
7134 gnu_expr
= maybe_character_value (gnu_expr
);
7136 /* If this is a slice with non-constant size of an array with constant
7137 size, set the maximum size for the allocation of temporaries. */
7138 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type
))
7139 && TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object
))))
7140 TYPE_ARRAY_MAX_SIZE (gnu_result_type
)
7141 = TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object
));
7143 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
7144 gnu_array_object
, gnu_expr
);
7148 case N_Selected_Component
:
7150 Entity_Id gnat_prefix
7151 = adjust_for_implicit_deref (Prefix (gnat_node
));
7152 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
7153 tree gnu_prefix
= gnat_to_gnu (gnat_prefix
);
7155 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
7157 /* gnat_to_gnu_entity does not save the GNU tree made for renamed
7158 discriminants so avoid making recursive calls on each reference
7159 to them by following the appropriate link directly here. */
7160 if (Ekind (gnat_field
) == E_Discriminant
)
7162 /* For discriminant references in tagged types always substitute
7163 the corresponding discriminant as the actual component. */
7164 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix
))))
7165 while (Present (Corresponding_Discriminant (gnat_field
)))
7166 gnat_field
= Corresponding_Discriminant (gnat_field
);
7168 /* For discriminant references in untagged types always substitute
7169 the corresponding stored discriminant. */
7170 else if (Present (Corresponding_Discriminant (gnat_field
)))
7171 gnat_field
= Original_Record_Component (gnat_field
);
7174 /* Handle extracting the real or imaginary part of a complex.
7175 The real part is the first field and the imaginary the last. */
7176 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
7177 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
7178 ? REALPART_EXPR
: IMAGPART_EXPR
,
7179 NULL_TREE
, gnu_prefix
);
7182 tree gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
7185 = build_component_ref (gnu_prefix
, gnu_field
,
7186 (Nkind (Parent (gnat_node
))
7187 == N_Attribute_Reference
)
7188 && lvalue_required_for_attribute_p
7189 (Parent (gnat_node
)));
7192 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7194 /* If atomic access is required on the RHS, build the atomic load. */
7195 if (atomic_access_required_p (gnat_node
, &sync
)
7196 && !present_in_lhs_or_actual_p (gnat_node
))
7197 gnu_result
= build_atomic_load (gnu_result
, sync
);
7201 case N_Attribute_Reference
:
7203 /* The attribute designator. */
7204 const int attr
= Get_Attribute_Id (Attribute_Name (gnat_node
));
7206 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
7207 is a unit, not an object with a GCC equivalent. */
7208 if (attr
== Attr_Elab_Spec
|| attr
== Attr_Elab_Body
)
7210 create_subprog_decl (create_concat_name
7211 (Entity (Prefix (gnat_node
)),
7212 attr
== Attr_Elab_Body
? "elabb" : "elabs"),
7213 NULL_TREE
, void_ftype
, NULL_TREE
, is_default
,
7214 true, true, true, true, false, NULL
,
7217 gnu_result
= Attribute_to_gnu (gnat_node
, &gnu_result_type
, attr
);
7222 /* Like 'Access as far as we are concerned. */
7223 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
7224 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
7225 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7229 case N_Extension_Aggregate
:
7233 /* Check that this aggregate has not slipped through the cracks. */
7234 gcc_assert (!Expansion_Delayed (gnat_node
));
7236 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7238 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
7239 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
7241 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type
)));
7242 else if (TREE_CODE (gnu_result_type
) == VECTOR_TYPE
)
7243 gnu_aggr_type
= TYPE_REPRESENTATIVE_ARRAY (gnu_result_type
);
7245 gnu_aggr_type
= gnu_result_type
;
7247 if (Null_Record_Present (gnat_node
))
7248 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL
);
7250 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
7251 || TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
7253 = assoc_to_constructor (Etype (gnat_node
),
7254 First (Component_Associations (gnat_node
)),
7256 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
7257 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
7259 Component_Type (Etype (gnat_node
)));
7260 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
7263 (COMPLEX_EXPR
, gnu_aggr_type
,
7264 gnat_to_gnu (Expression (First
7265 (Component_Associations (gnat_node
)))),
7266 gnat_to_gnu (Expression
7268 (First (Component_Associations (gnat_node
))))));
7272 gnu_result
= convert (gnu_result_type
, gnu_result
);
7277 if (TARGET_VTABLE_USES_DESCRIPTORS
7278 && Ekind (Etype (gnat_node
)) == E_Access_Subprogram_Type
7279 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
7280 gnu_result
= null_fdesc_node
;
7282 gnu_result
= null_pointer_node
;
7283 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7286 case N_Type_Conversion
:
7287 case N_Qualified_Expression
:
7288 gnu_expr
= maybe_character_value (gnat_to_gnu (Expression (gnat_node
)));
7289 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7291 /* If this is a qualified expression for a tagged type, we mark the type
7292 as used. Because of polymorphism, this might be the only reference to
7293 the tagged type in the program while objects have it as dynamic type.
7294 The debugger needs to see it to display these objects properly. */
7295 if (kind
== N_Qualified_Expression
&& Is_Tagged_Type (Etype (gnat_node
)))
7296 used_types_insert (gnu_result_type
);
7299 = convert_with_check (Etype (gnat_node
), gnu_expr
,
7300 Do_Overflow_Check (gnat_node
),
7301 Do_Range_Check (Expression (gnat_node
)),
7302 kind
== N_Type_Conversion
7303 && Float_Truncate (gnat_node
), gnat_node
);
7306 case N_Unchecked_Type_Conversion
:
7307 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7308 gnu_expr
= maybe_character_value (gnat_to_gnu (Expression (gnat_node
)));
7310 /* Skip further processing if the conversion is deemed a no-op. */
7311 if (unchecked_conversion_nop (gnat_node
))
7313 gnu_result
= gnu_expr
;
7314 gnu_result_type
= TREE_TYPE (gnu_result
);
7318 /* If the result is a pointer type, see if we are improperly
7319 converting to a stricter alignment. */
7320 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
7321 && Is_Access_Type (Etype (gnat_node
)))
7323 unsigned int align
= known_alignment (gnu_expr
);
7324 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
7325 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
7327 if (align
!= 0 && align
< oalign
&& !TYPE_ALIGN_OK (gnu_obj_type
))
7328 post_error_ne_tree_2
7329 ("?source alignment (^) '< alignment of & (^)",
7330 gnat_node
, Designated_Type (Etype (gnat_node
)),
7331 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
7334 /* If we are converting a descriptor to a function pointer, first
7335 build the pointer. */
7336 if (TARGET_VTABLE_USES_DESCRIPTORS
7337 && TREE_TYPE (gnu_expr
) == fdesc_type_node
7338 && POINTER_TYPE_P (gnu_result_type
))
7339 gnu_expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
7341 gnu_result
= unchecked_convert (gnu_result_type
, gnu_expr
,
7342 No_Truncation (gnat_node
));
7348 tree gnu_obj
= gnat_to_gnu (Left_Opnd (gnat_node
));
7349 tree gnu_low
, gnu_high
;
7351 Range_to_gnu (Right_Opnd (gnat_node
), &gnu_low
, &gnu_high
);
7352 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7354 tree gnu_op_type
= maybe_character_type (TREE_TYPE (gnu_obj
));
7355 if (TREE_TYPE (gnu_obj
) != gnu_op_type
)
7357 gnu_obj
= convert (gnu_op_type
, gnu_obj
);
7358 gnu_low
= convert (gnu_op_type
, gnu_low
);
7359 gnu_high
= convert (gnu_op_type
, gnu_high
);
7362 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
7363 ensure that GNU_OBJ is evaluated only once and perform a full range
7365 if (operand_equal_p (gnu_low
, gnu_high
, 0))
7367 = build_binary_op (EQ_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
7371 gnu_obj
= gnat_protect_expr (gnu_obj
);
7372 t1
= build_binary_op (GE_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
7374 set_expr_location_from_node (t1
, gnat_node
);
7375 t2
= build_binary_op (LE_EXPR
, gnu_result_type
, gnu_obj
, gnu_high
);
7377 set_expr_location_from_node (t2
, gnat_node
);
7379 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
, t1
, t2
);
7382 if (kind
== N_Not_In
)
7384 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result
), gnu_result
);
7389 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
7390 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
7391 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7392 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
7394 : (Rounded_Result (gnat_node
)
7395 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
7396 gnu_result_type
, gnu_lhs
, gnu_rhs
);
7410 case N_Op_Rotate_Left
:
7411 case N_Op_Rotate_Right
:
7412 case N_Op_Shift_Left
:
7413 case N_Op_Shift_Right
:
7414 case N_Op_Shift_Right_Arithmetic
:
7421 enum tree_code code
= gnu_codes
[kind
];
7422 bool ignore_lhs_overflow
= false;
7423 location_t saved_location
= input_location
;
7426 /* Fix operations set up for boolean types in GNU_CODES above. */
7427 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node
))))
7431 code
= BIT_AND_EXPR
;
7434 code
= BIT_IOR_EXPR
;
7437 code
= BIT_XOR_EXPR
;
7443 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
7444 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
7445 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7447 /* Pending generic support for efficient vector logical operations in
7448 GCC, convert vectors to their representative array type view and
7450 gnu_lhs
= maybe_vector_array (gnu_lhs
);
7451 gnu_rhs
= maybe_vector_array (gnu_rhs
);
7453 /* If this is a comparison operator, convert any references to an
7454 unconstrained array value into a reference to the actual array. */
7455 if (TREE_CODE_CLASS (code
) == tcc_comparison
)
7457 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
7458 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
7460 tree gnu_op_type
= maybe_character_type (TREE_TYPE (gnu_lhs
));
7461 if (TREE_TYPE (gnu_lhs
) != gnu_op_type
)
7463 gnu_lhs
= convert (gnu_op_type
, gnu_lhs
);
7464 gnu_rhs
= convert (gnu_op_type
, gnu_rhs
);
7468 /* If this is a shift whose count is not guaranteed to be correct,
7469 we need to adjust the shift count. */
7470 if (IN (kind
, N_Op_Shift
) && !Shift_Count_OK (gnat_node
))
7472 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
7474 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
7476 if (kind
== N_Op_Rotate_Left
|| kind
== N_Op_Rotate_Right
)
7477 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
7478 gnu_rhs
, gnu_max_shift
);
7479 else if (kind
== N_Op_Shift_Right_Arithmetic
)
7482 (MIN_EXPR
, gnu_count_type
,
7483 build_binary_op (MINUS_EXPR
,
7486 build_int_cst (gnu_count_type
, 1)),
7490 /* For right shifts, the type says what kind of shift to do,
7491 so we may need to choose a different type. In this case,
7492 we have to ignore integer overflow lest it propagates all
7493 the way down and causes a CE to be explicitly raised. */
7494 if (kind
== N_Op_Shift_Right
&& !TYPE_UNSIGNED (gnu_type
))
7496 gnu_type
= gnat_unsigned_type_for (gnu_type
);
7497 ignore_lhs_overflow
= true;
7499 else if (kind
== N_Op_Shift_Right_Arithmetic
7500 && TYPE_UNSIGNED (gnu_type
))
7502 gnu_type
= gnat_signed_type_for (gnu_type
);
7503 ignore_lhs_overflow
= true;
7506 if (gnu_type
!= gnu_result_type
)
7508 tree gnu_old_lhs
= gnu_lhs
;
7509 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
7510 if (TREE_CODE (gnu_lhs
) == INTEGER_CST
&& ignore_lhs_overflow
)
7511 TREE_OVERFLOW (gnu_lhs
) = TREE_OVERFLOW (gnu_old_lhs
);
7512 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
7515 /* Instead of expanding overflow checks for addition, subtraction
7516 and multiplication itself, the front end will leave this to
7517 the back end when Backend_Overflow_Checks_On_Target is set. */
7518 if (Do_Overflow_Check (gnat_node
)
7519 && Backend_Overflow_Checks_On_Target
7520 && (code
== PLUS_EXPR
|| code
== MINUS_EXPR
|| code
== MULT_EXPR
)
7521 && !TYPE_UNSIGNED (gnu_type
)
7522 && !FLOAT_TYPE_P (gnu_type
))
7523 gnu_result
= build_binary_op_trapv (code
, gnu_type
,
7524 gnu_lhs
, gnu_rhs
, gnat_node
);
7527 /* Some operations, e.g. comparisons of arrays, generate complex
7528 trees that need to be annotated while they are being built. */
7529 input_location
= saved_location
;
7530 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
7533 /* If this is a logical shift with the shift count not verified,
7534 we must return zero if it is too large. We cannot compensate
7535 above in this case. */
7536 if ((kind
== N_Op_Shift_Left
|| kind
== N_Op_Shift_Right
)
7537 && !Shift_Count_OK (gnat_node
))
7541 build_binary_op (GE_EXPR
, boolean_type_node
,
7543 convert (TREE_TYPE (gnu_rhs
),
7544 TYPE_SIZE (gnu_type
))),
7545 build_int_cst (gnu_type
, 0),
7550 case N_If_Expression
:
7552 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
7553 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
7555 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
7557 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7559 = build_cond_expr (gnu_result_type
, gnu_cond
, gnu_true
, gnu_false
);
7564 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
7565 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7569 /* This case can apply to a boolean or a modular type.
7570 Fall through for a boolean operand since GNU_CODES is set
7571 up to handle this. */
7572 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node
))))
7574 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
7575 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7576 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
7581 /* ... fall through ... */
7585 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
7586 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7588 /* Instead of expanding overflow checks for negation and absolute
7589 value itself, the front end will leave this to the back end
7590 when Backend_Overflow_Checks_On_Target is set. */
7591 if (Do_Overflow_Check (gnat_node
)
7592 && Backend_Overflow_Checks_On_Target
7593 && !TYPE_UNSIGNED (gnu_result_type
)
7594 && !FLOAT_TYPE_P (gnu_result_type
))
7596 = build_unary_op_trapv (gnu_codes
[kind
],
7597 gnu_result_type
, gnu_expr
, gnat_node
);
7599 gnu_result
= build_unary_op (gnu_codes
[kind
],
7600 gnu_result_type
, gnu_expr
);
7605 tree gnu_init
= NULL_TREE
;
7607 bool ignore_init_type
= false;
7609 gnat_temp
= Expression (gnat_node
);
7611 /* The Expression operand can either be an N_Identifier or
7612 Expanded_Name, which must represent a type, or a
7613 N_Qualified_Expression, which contains both the object type and an
7614 initial value for the object. */
7615 if (Nkind (gnat_temp
) == N_Identifier
7616 || Nkind (gnat_temp
) == N_Expanded_Name
)
7617 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
7618 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
7620 Entity_Id gnat_desig_type
7621 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
7623 ignore_init_type
= Has_Constrained_Partial_View (gnat_desig_type
);
7624 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
7626 gnu_init
= maybe_unconstrained_array (gnu_init
);
7627 if (Do_Range_Check (Expression (gnat_temp
)))
7629 = emit_range_check (gnu_init
, gnat_desig_type
, gnat_temp
);
7631 if (Is_Elementary_Type (gnat_desig_type
)
7632 || Is_Constrained (gnat_desig_type
))
7633 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
7636 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
7637 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
7638 gnu_type
= TREE_TYPE (gnu_init
);
7641 /* See the N_Qualified_Expression case for the rationale. */
7642 if (Is_Tagged_Type (gnat_desig_type
))
7643 used_types_insert (gnu_type
);
7645 gnu_init
= convert (gnu_type
, gnu_init
);
7650 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7651 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
7652 Procedure_To_Call (gnat_node
),
7653 Storage_Pool (gnat_node
), gnat_node
,
7658 /**************************/
7659 /* Chapter 5: Statements */
7660 /**************************/
7663 gnu_result
= build1 (LABEL_EXPR
, void_type_node
,
7664 gnat_to_gnu (Identifier (gnat_node
)));
7667 case N_Null_Statement
:
7668 /* When not optimizing, turn null statements from source into gotos to
7669 the next statement that the middle-end knows how to preserve. */
7670 if (!optimize
&& Comes_From_Source (gnat_node
))
7672 tree stmt
, label
= create_label_decl (NULL_TREE
, gnat_node
);
7673 DECL_IGNORED_P (label
) = 1;
7674 start_stmt_group ();
7675 stmt
= build1 (GOTO_EXPR
, void_type_node
, label
);
7676 set_expr_location_from_node (stmt
, gnat_node
);
7678 stmt
= build1 (LABEL_EXPR
, void_type_node
, label
);
7679 set_expr_location_from_node (stmt
, gnat_node
);
7681 gnu_result
= end_stmt_group ();
7684 gnu_result
= alloc_stmt_list ();
7687 case N_Assignment_Statement
:
7688 /* Get the LHS and RHS of the statement and convert any reference to an
7689 unconstrained array into a reference to the underlying array. */
7690 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
7692 /* If the type has a size that overflows, convert this into raise of
7693 Storage_Error: execution shouldn't have gotten here anyway. */
7694 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
7695 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))))
7696 gnu_result
= build_call_raise (SE_Object_Too_Large
, gnat_node
,
7697 N_Raise_Storage_Error
);
7698 else if (Nkind (Expression (gnat_node
)) == N_Function_Call
)
7700 bool outer_atomic_access
7701 = outer_atomic_access_required_p (Name (gnat_node
));
7703 = !outer_atomic_access
7704 && atomic_access_required_p (Name (gnat_node
), &sync
);
7706 = Call_to_gnu (Expression (gnat_node
), &gnu_result_type
, gnu_lhs
,
7707 outer_atomic_access
, atomic_access
, sync
);
7711 const Node_Id gnat_expr
= Expression (gnat_node
);
7712 const Entity_Id gnat_type
7713 = Underlying_Type (Etype (Name (gnat_node
)));
7714 const bool regular_array_type_p
7715 = (Is_Array_Type (gnat_type
) && !Is_Bit_Packed_Array (gnat_type
));
7716 const bool use_memset_p
7717 = (regular_array_type_p
7718 && Nkind (gnat_expr
) == N_Aggregate
7719 && Is_Others_Aggregate (gnat_expr
));
7721 /* If we'll use memset, we need to find the inner expression. */
7725 = Expression (First (Component_Associations (gnat_expr
)));
7726 while (Nkind (gnat_inner
) == N_Aggregate
7727 && Is_Others_Aggregate (gnat_inner
))
7729 = Expression (First (Component_Associations (gnat_inner
)));
7730 gnu_rhs
= gnat_to_gnu (gnat_inner
);
7733 gnu_rhs
= maybe_unconstrained_array (gnat_to_gnu (gnat_expr
));
7735 /* If range check is needed, emit code to generate it. */
7736 if (Do_Range_Check (gnat_expr
))
7737 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)),
7740 /* If an outer atomic access is required on the LHS, build the load-
7741 modify-store sequence. */
7742 if (outer_atomic_access_required_p (Name (gnat_node
)))
7743 gnu_result
= build_load_modify_store (gnu_lhs
, gnu_rhs
, gnat_node
);
7745 /* Or else, if atomic access is required, build the atomic store. */
7746 else if (atomic_access_required_p (Name (gnat_node
), &sync
))
7747 gnu_result
= build_atomic_store (gnu_lhs
, gnu_rhs
, sync
);
7749 /* Or else, use memset when the conditions are met. This has already
7750 been validated by Aggr_Assignment_OK_For_Backend in the front-end
7751 and the RHS is thus guaranteed to be of the appropriate form. */
7752 else if (use_memset_p
)
7755 = real_zerop (gnu_rhs
)
7757 : fold_convert (integer_type_node
, gnu_rhs
);
7758 tree dest
= build_fold_addr_expr (gnu_lhs
);
7759 tree t
= builtin_decl_explicit (BUILT_IN_MEMSET
);
7760 /* Be extra careful not to write too much data. */
7762 if (TREE_CODE (gnu_lhs
) == COMPONENT_REF
)
7763 size
= DECL_SIZE_UNIT (TREE_OPERAND (gnu_lhs
, 1));
7764 else if (DECL_P (gnu_lhs
))
7765 size
= DECL_SIZE_UNIT (gnu_lhs
);
7767 size
= TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
));
7768 size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_lhs
);
7769 if (TREE_CODE (value
) == INTEGER_CST
&& !integer_zerop (value
))
7772 = build_int_cst (integer_type_node
,
7773 ((HOST_WIDE_INT
) 1 << BITS_PER_UNIT
) - 1);
7774 value
= int_const_binop (BIT_AND_EXPR
, value
, mask
);
7776 gnu_result
= build_call_expr (t
, 3, dest
, value
, size
);
7779 /* Otherwise build a regular assignment. */
7782 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
7784 /* If the assignment type is a regular array and the two sides are
7785 not completely disjoint, play safe and use memmove. But don't do
7786 it for a bit-packed array as it might not be byte-aligned. */
7787 if (TREE_CODE (gnu_result
) == MODIFY_EXPR
7788 && regular_array_type_p
7789 && !(Forwards_OK (gnat_node
) && Backwards_OK (gnat_node
)))
7791 tree to
= TREE_OPERAND (gnu_result
, 0);
7792 tree from
= TREE_OPERAND (gnu_result
, 1);
7793 tree type
= TREE_TYPE (from
);
7795 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type
), from
);
7796 tree to_ptr
= build_fold_addr_expr (to
);
7797 tree from_ptr
= build_fold_addr_expr (from
);
7798 tree t
= builtin_decl_explicit (BUILT_IN_MEMMOVE
);
7799 gnu_result
= build_call_expr (t
, 3, to_ptr
, from_ptr
, size
);
7804 case N_If_Statement
:
7806 tree
*gnu_else_ptr
; /* Point to put next "else if" or "else". */
7808 /* Make the outer COND_EXPR. Avoid non-determinism. */
7809 gnu_result
= build3 (COND_EXPR
, void_type_node
,
7810 gnat_to_gnu (Condition (gnat_node
)),
7811 NULL_TREE
, NULL_TREE
);
7812 COND_EXPR_THEN (gnu_result
)
7813 = build_stmt_group (Then_Statements (gnat_node
), false);
7814 TREE_SIDE_EFFECTS (gnu_result
) = 1;
7815 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_result
);
7817 /* Now make a COND_EXPR for each of the "else if" parts. Put each
7818 into the previous "else" part and point to where to put any
7819 outer "else". Also avoid non-determinism. */
7820 if (Present (Elsif_Parts (gnat_node
)))
7821 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
7822 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
7824 gnu_expr
= build3 (COND_EXPR
, void_type_node
,
7825 gnat_to_gnu (Condition (gnat_temp
)),
7826 NULL_TREE
, NULL_TREE
);
7827 COND_EXPR_THEN (gnu_expr
)
7828 = build_stmt_group (Then_Statements (gnat_temp
), false);
7829 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
7830 set_expr_location_from_node (gnu_expr
, gnat_temp
);
7831 *gnu_else_ptr
= gnu_expr
;
7832 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
7835 *gnu_else_ptr
= build_stmt_group (Else_Statements (gnat_node
), false);
7839 case N_Case_Statement
:
7840 gnu_result
= Case_Statement_to_gnu (gnat_node
);
7843 case N_Loop_Statement
:
7844 gnu_result
= Loop_Statement_to_gnu (gnat_node
);
7847 case N_Block_Statement
:
7848 /* The only way to enter the block is to fall through to it. */
7849 if (stmt_group_may_fallthru ())
7851 start_stmt_group ();
7853 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7854 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
7856 gnu_result
= end_stmt_group ();
7859 gnu_result
= alloc_stmt_list ();
7862 case N_Exit_Statement
:
7864 = build2 (EXIT_STMT
, void_type_node
,
7865 (Present (Condition (gnat_node
))
7866 ? gnat_to_gnu (Condition (gnat_node
)) : NULL_TREE
),
7867 (Present (Name (gnat_node
))
7868 ? get_gnu_tree (Entity (Name (gnat_node
)))
7869 : LOOP_STMT_LABEL (gnu_loop_stack
->last ()->stmt
)));
7872 case N_Simple_Return_Statement
:
7874 tree gnu_ret_obj
, gnu_ret_val
;
7876 /* If the subprogram is a function, we must return the expression. */
7877 if (Present (Expression (gnat_node
)))
7879 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
7881 /* If this function has copy-in/copy-out parameters parameters and
7882 doesn't return by invisible reference, get the real object for
7883 the return. See Subprogram_Body_to_gnu. */
7884 if (TYPE_CI_CO_LIST (gnu_subprog_type
)
7885 && !TREE_ADDRESSABLE (gnu_subprog_type
))
7886 gnu_ret_obj
= gnu_return_var_stack
->last ();
7888 gnu_ret_obj
= DECL_RESULT (current_function_decl
);
7890 /* Get the GCC tree for the expression to be returned. */
7891 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
7893 /* Do not remove the padding from GNU_RET_VAL if the inner type is
7894 self-referential since we want to allocate the fixed size. */
7895 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
7896 && type_is_padding_self_referential
7897 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
7898 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
7900 /* If the function returns by direct reference, return a pointer
7901 to the return value. */
7902 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
)
7903 || By_Ref (gnat_node
))
7904 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
7906 /* Otherwise, if it returns an unconstrained array, we have to
7907 allocate a new version of the result and return it. */
7908 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
))
7910 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
7912 /* And find out whether this is a candidate for Named Return
7913 Value. If so, record it. */
7914 if (!TYPE_CI_CO_LIST (gnu_subprog_type
) && optimize
)
7916 tree ret_val
= gnu_ret_val
;
7918 /* Strip useless conversions around the return value. */
7919 if (gnat_useless_type_conversion (ret_val
))
7920 ret_val
= TREE_OPERAND (ret_val
, 0);
7922 /* Strip unpadding around the return value. */
7923 if (TREE_CODE (ret_val
) == COMPONENT_REF
7924 && TYPE_IS_PADDING_P
7925 (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
7926 ret_val
= TREE_OPERAND (ret_val
, 0);
7928 /* Now apply the test to the return value. */
7929 if (return_value_ok_for_nrv_p (NULL_TREE
, ret_val
))
7931 if (!f_named_ret_val
)
7932 f_named_ret_val
= BITMAP_GGC_ALLOC ();
7933 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
7935 f_gnat_ret
= gnat_node
;
7939 gnu_ret_val
= build_allocator (TREE_TYPE (gnu_ret_val
),
7941 TREE_TYPE (gnu_ret_obj
),
7942 Procedure_To_Call (gnat_node
),
7943 Storage_Pool (gnat_node
),
7947 /* Otherwise, if it returns by invisible reference, dereference
7948 the pointer it is passed using the type of the return value
7949 and build the copy operation manually. This ensures that we
7950 don't copy too much data, for example if the return type is
7951 unconstrained with a maximum size. */
7952 else if (TREE_ADDRESSABLE (gnu_subprog_type
))
7955 = build_unary_op (INDIRECT_REF
, TREE_TYPE (gnu_ret_val
),
7957 gnu_result
= build2 (INIT_EXPR
, void_type_node
,
7958 gnu_ret_deref
, gnu_ret_val
);
7959 add_stmt_with_node (gnu_result
, gnat_node
);
7960 gnu_ret_val
= NULL_TREE
;
7965 gnu_ret_obj
= gnu_ret_val
= NULL_TREE
;
7967 /* If we have a return label defined, convert this into a branch to
7968 that label. The return proper will be handled elsewhere. */
7969 if (gnu_return_label_stack
->last ())
7972 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_ret_obj
,
7975 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
7976 gnu_return_label_stack
->last ());
7978 /* When not optimizing, make sure the return is preserved. */
7979 if (!optimize
&& Comes_From_Source (gnat_node
))
7980 DECL_ARTIFICIAL (gnu_return_label_stack
->last ()) = 0;
7983 /* Otherwise, build a regular return. */
7985 gnu_result
= build_return_expr (gnu_ret_obj
, gnu_ret_val
);
7989 case N_Goto_Statement
:
7990 gnu_expr
= gnat_to_gnu (Name (gnat_node
));
7991 gnu_result
= build1 (GOTO_EXPR
, void_type_node
, gnu_expr
);
7992 TREE_USED (gnu_expr
) = 1;
7995 /***************************/
7996 /* Chapter 6: Subprograms */
7997 /***************************/
7999 case N_Subprogram_Declaration
:
8000 /* Unless there is a freeze node, declare the entity. We consider
8001 this a definition even though we're not generating code for the
8002 subprogram because we will be making the corresponding GCC node.
8003 When there is a freeze node, it is considered the definition of
8004 the subprogram and we do nothing until after it is encountered.
8005 That's an efficiency issue: the types involved in the profile
8006 are far more likely to be frozen between the declaration and
8007 the freeze node than before the declaration, so we save some
8008 updates of the GCC node by waiting until the freeze node.
8009 The counterpart is that we assume that there is no reference
8010 to the subprogram between the declaration and the freeze node
8011 in the expanded code; otherwise, it will be interpreted as an
8012 external reference and very likely give rise to a link failure. */
8013 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
8014 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
8016 gnu_result
= alloc_stmt_list ();
8019 case N_Abstract_Subprogram_Declaration
:
8020 /* This subprogram doesn't exist for code generation purposes, but we
8021 have to elaborate the types of any parameters and result, unless
8022 they are imported types (nothing to generate in this case).
8024 The parameter list may contain types with freeze nodes, e.g. not null
8025 subtypes, so the subprogram itself may carry a freeze node, in which
8026 case its elaboration must be deferred. */
8028 /* Process the parameter types first. */
8029 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
8031 = First_Formal_With_Extras
8032 (Defining_Entity (Specification (gnat_node
)));
8033 Present (gnat_temp
);
8034 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
8035 if (Is_Itype (Etype (gnat_temp
))
8036 && !From_Limited_With (Etype (gnat_temp
)))
8037 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, false);
8039 /* Then the result type, set to Standard_Void_Type for procedures. */
8041 Entity_Id gnat_temp_type
8042 = Etype (Defining_Entity (Specification (gnat_node
)));
8044 if (Is_Itype (gnat_temp_type
) && !From_Limited_With (gnat_temp_type
))
8045 gnat_to_gnu_entity (Etype (gnat_temp_type
), NULL_TREE
, false);
8048 gnu_result
= alloc_stmt_list ();
8051 case N_Defining_Program_Unit_Name
:
8052 /* For a child unit identifier go up a level to get the specification.
8053 We get this when we try to find the spec of a child unit package
8054 that is the compilation unit being compiled. */
8055 gnu_result
= gnat_to_gnu (Parent (gnat_node
));
8058 case N_Subprogram_Body
:
8059 Subprogram_Body_to_gnu (gnat_node
);
8060 gnu_result
= alloc_stmt_list ();
8063 case N_Function_Call
:
8064 case N_Procedure_Call_Statement
:
8065 gnu_result
= Call_to_gnu (gnat_node
, &gnu_result_type
, NULL_TREE
,
8066 false, false, false);
8069 /************************/
8070 /* Chapter 7: Packages */
8071 /************************/
8073 case N_Package_Declaration
:
8074 gnu_result
= gnat_to_gnu (Specification (gnat_node
));
8077 case N_Package_Specification
:
8079 start_stmt_group ();
8080 process_decls (Visible_Declarations (gnat_node
),
8081 Private_Declarations (gnat_node
), Empty
, true, true);
8082 gnu_result
= end_stmt_group ();
8085 case N_Package_Body
:
8087 /* If this is the body of a generic package - do nothing. */
8088 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
8090 gnu_result
= alloc_stmt_list ();
8094 start_stmt_group ();
8095 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
8097 if (Present (Handled_Statement_Sequence (gnat_node
)))
8098 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
8100 gnu_result
= end_stmt_group ();
8103 /********************************/
8104 /* Chapter 8: Visibility Rules */
8105 /********************************/
8107 case N_Use_Package_Clause
:
8108 case N_Use_Type_Clause
:
8109 /* Nothing to do here - but these may appear in list of declarations. */
8110 gnu_result
= alloc_stmt_list ();
8113 /*********************/
8114 /* Chapter 9: Tasks */
8115 /*********************/
8117 case N_Protected_Type_Declaration
:
8118 gnu_result
= alloc_stmt_list ();
8121 case N_Single_Task_Declaration
:
8122 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, true);
8123 gnu_result
= alloc_stmt_list ();
8126 /*********************************************************/
8127 /* Chapter 10: Program Structure and Compilation Issues */
8128 /*********************************************************/
8130 case N_Compilation_Unit
:
8131 /* This is not called for the main unit on which gigi is invoked. */
8132 Compilation_Unit_to_gnu (gnat_node
);
8133 gnu_result
= alloc_stmt_list ();
8137 gnu_result
= gnat_to_gnu (Proper_Body (gnat_node
));
8141 case N_Protected_Body
:
8143 /* These nodes should only be present when annotating types. */
8144 gcc_assert (type_annotate_only
);
8145 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
8146 gnu_result
= alloc_stmt_list ();
8149 case N_Subprogram_Body_Stub
:
8150 case N_Package_Body_Stub
:
8151 case N_Protected_Body_Stub
:
8152 case N_Task_Body_Stub
:
8153 /* Simply process whatever unit is being inserted. */
8154 if (Present (Library_Unit (gnat_node
)))
8155 gnu_result
= gnat_to_gnu (Unit (Library_Unit (gnat_node
)));
8158 gcc_assert (type_annotate_only
);
8159 gnu_result
= alloc_stmt_list ();
8163 /***************************/
8164 /* Chapter 11: Exceptions */
8165 /***************************/
8167 case N_Handled_Sequence_Of_Statements
:
8168 /* If there is an At_End procedure attached to this node, and the EH
8169 mechanism is front-end, we must have at least a corresponding At_End
8170 handler, unless the No_Exception_Handlers restriction is set. */
8171 gcc_assert (type_annotate_only
8172 || !Front_End_Exceptions ()
8173 || No (At_End_Proc (gnat_node
))
8174 || Present (Exception_Handlers (gnat_node
))
8175 || No_Exception_Handlers_Set ());
8177 gnu_result
= Handled_Sequence_Of_Statements_to_gnu (gnat_node
);
8180 case N_Exception_Handler
:
8181 if (Back_End_Exceptions ())
8182 gnu_result
= Exception_Handler_to_gnu_gcc (gnat_node
);
8183 else if (Exception_Mechanism
== Front_End_SJLJ
)
8184 gnu_result
= Exception_Handler_to_gnu_fe_sjlj (gnat_node
);
8189 case N_Raise_Statement
:
8190 /* Only for reraise in back-end exceptions mode. */
8191 gcc_assert (No (Name (gnat_node
)) && Back_End_Exceptions ());
8193 start_stmt_group ();
8196 /* Clear the current exception pointer so that the occurrence won't be
8198 gnu_expr
= create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE
,
8199 ptr_type_node
, gnu_incoming_exc_ptr
,
8200 false, false, false, false, false,
8201 true, true, NULL
, gnat_node
);
8203 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_incoming_exc_ptr
,
8204 build_int_cst (ptr_type_node
, 0)));
8205 add_stmt (build_call_n_expr (reraise_zcx_decl
, 1, gnu_expr
));
8207 gnu_result
= end_stmt_group ();
8210 case N_Push_Constraint_Error_Label
:
8211 gnu_constraint_error_label_stack
.safe_push (Exception_Label (gnat_node
));
8214 case N_Push_Storage_Error_Label
:
8215 gnu_storage_error_label_stack
.safe_push (Exception_Label (gnat_node
));
8218 case N_Push_Program_Error_Label
:
8219 gnu_program_error_label_stack
.safe_push (Exception_Label (gnat_node
));
8222 case N_Pop_Constraint_Error_Label
:
8223 gnat_temp
= gnu_constraint_error_label_stack
.pop ();
8224 if (Present (gnat_temp
)
8225 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
8226 Warn_If_No_Local_Raise (gnat_temp
);
8229 case N_Pop_Storage_Error_Label
:
8230 gnat_temp
= gnu_storage_error_label_stack
.pop ();
8231 if (Present (gnat_temp
)
8232 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
8233 Warn_If_No_Local_Raise (gnat_temp
);
8236 case N_Pop_Program_Error_Label
:
8237 gnat_temp
= gnu_program_error_label_stack
.pop ();
8238 if (Present (gnat_temp
)
8239 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
8240 Warn_If_No_Local_Raise (gnat_temp
);
8243 /******************************/
8244 /* Chapter 12: Generic Units */
8245 /******************************/
8247 case N_Generic_Function_Renaming_Declaration
:
8248 case N_Generic_Package_Renaming_Declaration
:
8249 case N_Generic_Procedure_Renaming_Declaration
:
8250 case N_Generic_Package_Declaration
:
8251 case N_Generic_Subprogram_Declaration
:
8252 case N_Package_Instantiation
:
8253 case N_Procedure_Instantiation
:
8254 case N_Function_Instantiation
:
8255 /* These nodes can appear on a declaration list but there is nothing to
8256 to be done with them. */
8257 gnu_result
= alloc_stmt_list ();
8260 /**************************************************/
8261 /* Chapter 13: Representation Clauses and */
8262 /* Implementation-Dependent Features */
8263 /**************************************************/
8265 case N_Attribute_Definition_Clause
:
8266 gnu_result
= alloc_stmt_list ();
8268 /* The only one we need to deal with is 'Address since, for the others,
8269 the front-end puts the information elsewhere. */
8270 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
)
8273 /* And we only deal with 'Address if the object has a Freeze node. */
8274 gnat_temp
= Entity (Name (gnat_node
));
8275 if (Freeze_Node (gnat_temp
))
8277 tree gnu_address
= gnat_to_gnu (Expression (gnat_node
));
8279 /* Get the value to use as the address and save it as the equivalent
8280 for the object; when it is frozen, gnat_to_gnu_entity will do the
8281 right thing. For a subprogram, put the naked address but build a
8282 meaningfull expression for an object in case its address is taken
8283 before the Freeze node is encountered; this can happen if the type
8284 of the object is limited and it is initialized with the result of
8286 if (Is_Subprogram (gnat_temp
))
8287 gnu_result
= gnu_address
;
8290 tree gnu_type
= gnat_to_gnu_type (Etype (gnat_temp
));
8291 /* Drop atomic and volatile qualifiers for the expression. */
8292 gnu_type
= TYPE_MAIN_VARIANT (gnu_type
);
8294 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
8295 gnu_address
= convert (gnu_type
, gnu_address
);
8297 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_address
);
8300 save_gnu_tree (gnat_temp
, gnu_result
, true);
8304 case N_Enumeration_Representation_Clause
:
8305 case N_Record_Representation_Clause
:
8307 /* We do nothing with these. SEM puts the information elsewhere. */
8308 gnu_result
= alloc_stmt_list ();
8311 case N_Code_Statement
:
8312 if (!type_annotate_only
)
8314 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
8315 tree gnu_inputs
= NULL_TREE
, gnu_outputs
= NULL_TREE
;
8316 tree gnu_clobbers
= NULL_TREE
, tail
;
8317 bool allows_mem
, allows_reg
, fake
;
8318 int ninputs
, noutputs
, i
;
8319 const char **oconstraints
;
8320 const char *constraint
;
8323 /* First retrieve the 3 operand lists built by the front-end. */
8324 Setup_Asm_Outputs (gnat_node
);
8325 while (Present (gnat_temp
= Asm_Output_Variable ()))
8327 tree gnu_value
= gnat_to_gnu (gnat_temp
);
8328 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
8329 (Asm_Output_Constraint ()));
8331 gnu_outputs
= tree_cons (gnu_constr
, gnu_value
, gnu_outputs
);
8335 Setup_Asm_Inputs (gnat_node
);
8336 while (Present (gnat_temp
= Asm_Input_Value ()))
8338 tree gnu_value
= gnat_to_gnu (gnat_temp
);
8339 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
8340 (Asm_Input_Constraint ()));
8342 gnu_inputs
= tree_cons (gnu_constr
, gnu_value
, gnu_inputs
);
8346 Clobber_Setup (gnat_node
);
8347 while ((clobber
= Clobber_Get_Next ()))
8349 = tree_cons (NULL_TREE
,
8350 build_string (strlen (clobber
) + 1, clobber
),
8353 /* Then perform some standard checking and processing on the
8354 operands. In particular, mark them addressable if needed. */
8355 gnu_outputs
= nreverse (gnu_outputs
);
8356 noutputs
= list_length (gnu_outputs
);
8357 gnu_inputs
= nreverse (gnu_inputs
);
8358 ninputs
= list_length (gnu_inputs
);
8359 oconstraints
= XALLOCAVEC (const char *, noutputs
);
8361 for (i
= 0, tail
= gnu_outputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
8363 tree output
= TREE_VALUE (tail
);
8365 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
8366 oconstraints
[i
] = constraint
;
8368 if (parse_output_constraint (&constraint
, i
, ninputs
, noutputs
,
8369 &allows_mem
, &allows_reg
, &fake
))
8371 /* If the operand is going to end up in memory,
8372 mark it addressable. Note that we don't test
8373 allows_mem like in the input case below; this
8374 is modelled on the C front-end. */
8377 output
= remove_conversions (output
, false);
8378 if (TREE_CODE (output
) == CONST_DECL
8379 && DECL_CONST_CORRESPONDING_VAR (output
))
8380 output
= DECL_CONST_CORRESPONDING_VAR (output
);
8381 if (!gnat_mark_addressable (output
))
8382 output
= error_mark_node
;
8386 output
= error_mark_node
;
8388 TREE_VALUE (tail
) = output
;
8391 for (i
= 0, tail
= gnu_inputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
8393 tree input
= TREE_VALUE (tail
);
8395 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
8397 if (parse_input_constraint (&constraint
, i
, ninputs
, noutputs
,
8399 &allows_mem
, &allows_reg
))
8401 /* If the operand is going to end up in memory,
8402 mark it addressable. */
8403 if (!allows_reg
&& allows_mem
)
8405 input
= remove_conversions (input
, false);
8406 if (TREE_CODE (input
) == CONST_DECL
8407 && DECL_CONST_CORRESPONDING_VAR (input
))
8408 input
= DECL_CONST_CORRESPONDING_VAR (input
);
8409 if (!gnat_mark_addressable (input
))
8410 input
= error_mark_node
;
8414 input
= error_mark_node
;
8416 TREE_VALUE (tail
) = input
;
8419 gnu_result
= build5 (ASM_EXPR
, void_type_node
,
8420 gnu_template
, gnu_outputs
,
8421 gnu_inputs
, gnu_clobbers
, NULL_TREE
);
8422 ASM_VOLATILE_P (gnu_result
) = Is_Asm_Volatile (gnat_node
);
8425 gnu_result
= alloc_stmt_list ();
8433 /* Markers are created by the ABE mechanism to capture information which
8434 is either unavailable of expensive to recompute. Markers do not have
8435 and runtime semantics, and should be ignored. */
8438 case N_Variable_Reference_Marker
:
8439 gnu_result
= alloc_stmt_list ();
8442 case N_Expression_With_Actions
:
8443 /* This construct doesn't define a scope so we don't push a binding
8444 level around the statement list, but we wrap it in a SAVE_EXPR to
8445 protect it from unsharing. Elaborate the expression as part of the
8446 same statement group as the actions so that the type declaration
8447 gets inserted there as well. This ensures that the type elaboration
8448 code is issued past the actions computing values on which it might
8450 start_stmt_group ();
8451 add_stmt_list (Actions (gnat_node
));
8452 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
8453 gnu_result
= end_stmt_group ();
8455 gnu_result
= build1 (SAVE_EXPR
, void_type_node
, gnu_result
);
8456 TREE_SIDE_EFFECTS (gnu_result
) = 1;
8459 = build_compound_expr (TREE_TYPE (gnu_expr
), gnu_result
, gnu_expr
);
8460 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
8463 case N_Freeze_Entity
:
8464 start_stmt_group ();
8465 process_freeze_entity (gnat_node
);
8466 process_decls (Actions (gnat_node
), Empty
, Empty
, true, true);
8467 gnu_result
= end_stmt_group ();
8470 case N_Freeze_Generic_Entity
:
8471 gnu_result
= alloc_stmt_list ();
8474 case N_Itype_Reference
:
8475 if (!present_gnu_tree (Itype (gnat_node
)))
8476 process_type (Itype (gnat_node
));
8477 gnu_result
= alloc_stmt_list ();
8480 case N_Free_Statement
:
8481 if (!type_annotate_only
)
8484 = gnat_to_gnu (adjust_for_implicit_deref (Expression (gnat_node
)));
8485 tree gnu_ptr_type
= TREE_TYPE (gnu_ptr
);
8486 tree gnu_obj_type
, gnu_actual_obj_type
;
8488 /* If this is a thin pointer, we must first dereference it to create
8489 a fat pointer, then go back below to a thin pointer. The reason
8490 for this is that we need to have a fat pointer someplace in order
8491 to properly compute the size. */
8492 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
8493 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
8494 build_unary_op (INDIRECT_REF
, NULL_TREE
,
8497 /* If this is a fat pointer, the object must have been allocated with
8498 the template in front of the array. So pass the template address,
8499 and get the total size; do it by converting to a thin pointer. */
8500 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
8502 = convert (build_pointer_type
8503 (TYPE_OBJECT_RECORD_TYPE
8504 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
8507 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
8509 /* If this is a thin pointer, the object must have been allocated with
8510 the template in front of the array. So pass the template address,
8511 and get the total size. */
8512 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
8514 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
8516 fold_build1 (NEGATE_EXPR
, sizetype
,
8519 TYPE_FIELDS ((gnu_obj_type
)))));
8521 /* If we have a special dynamic constrained subtype on the node, use
8522 it to compute the size; otherwise, use the designated subtype. */
8523 if (Present (Actual_Designated_Subtype (gnat_node
)))
8526 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node
));
8528 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
))
8530 = build_unc_object_type_from_ptr (gnu_ptr_type
,
8531 gnu_actual_obj_type
,
8532 get_identifier ("DEALLOC"),
8536 gnu_actual_obj_type
= gnu_obj_type
;
8538 tree gnu_size
= TYPE_SIZE_UNIT (gnu_actual_obj_type
);
8539 gnu_size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size
, gnu_ptr
);
8542 = build_call_alloc_dealloc (gnu_ptr
, gnu_size
, gnu_obj_type
,
8543 Procedure_To_Call (gnat_node
),
8544 Storage_Pool (gnat_node
),
8549 case N_Raise_Constraint_Error
:
8550 case N_Raise_Program_Error
:
8551 case N_Raise_Storage_Error
:
8552 if (type_annotate_only
)
8553 gnu_result
= alloc_stmt_list ();
8555 gnu_result
= Raise_Error_to_gnu (gnat_node
, &gnu_result_type
);
8558 case N_Validate_Unchecked_Conversion
:
8559 /* The only validation we currently do on an unchecked conversion is
8560 that of aliasing assumptions. */
8561 if (flag_strict_aliasing
)
8562 gnat_validate_uc_list
.safe_push (gnat_node
);
8563 gnu_result
= alloc_stmt_list ();
8566 case N_Function_Specification
:
8567 case N_Procedure_Specification
:
8569 case N_Component_Association
:
8570 /* These nodes should only be present when annotating types. */
8571 gcc_assert (type_annotate_only
);
8572 gnu_result
= alloc_stmt_list ();
8576 /* Other nodes are not supposed to reach here. */
8580 /* If we pushed the processing of the elaboration routine, pop it back. */
8581 if (went_into_elab_proc
)
8582 current_function_decl
= NULL_TREE
;
8584 /* When not optimizing, turn boolean rvalues B into B != false tests
8585 so that we can put the location information of the reference to B on
8586 the inequality operator for better debug info. */
8588 && TREE_CODE (gnu_result
) != INTEGER_CST
8589 && TREE_CODE (gnu_result
) != TYPE_DECL
8590 && (kind
== N_Identifier
8591 || kind
== N_Expanded_Name
8592 || kind
== N_Explicit_Dereference
8593 || kind
== N_Indexed_Component
8594 || kind
== N_Selected_Component
)
8595 && TREE_CODE (get_base_type (gnu_result_type
)) == BOOLEAN_TYPE
8596 && !lvalue_required_p (gnat_node
, gnu_result_type
, false, false)
8597 && Nkind (Parent (gnat_node
)) != N_Variant_Part
)
8600 = build_binary_op (NE_EXPR
, gnu_result_type
,
8601 convert (gnu_result_type
, gnu_result
),
8602 convert (gnu_result_type
, boolean_false_node
));
8603 if (TREE_CODE (gnu_result
) != INTEGER_CST
)
8604 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
8607 /* Set the location information on the result if it's not a simple name.
8608 Note that we may have no result if we tried to build a CALL_EXPR node
8609 to a procedure with no side-effects and optimization is enabled. */
8610 else if (kind
!= N_Identifier
&& gnu_result
&& EXPR_P (gnu_result
))
8611 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
8613 /* If we're supposed to return something of void_type, it means we have
8614 something we're elaborating for effect, so just return. */
8615 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
8618 /* If the result is a constant that overflowed, raise Constraint_Error. */
8619 if (TREE_CODE (gnu_result
) == INTEGER_CST
&& TREE_OVERFLOW (gnu_result
))
8621 post_error ("?`Constraint_Error` will be raised at run time", gnat_node
);
8623 = build1 (NULL_EXPR
, gnu_result_type
,
8624 build_call_raise (CE_Overflow_Check_Failed
, gnat_node
,
8625 N_Raise_Constraint_Error
));
8628 /* If the result has side-effects and is of an unconstrained type, protect
8629 the expression in case it will be referenced multiple times, i.e. for
8630 its value and to compute the size of an object. But do it neither for
8631 an object nor a renaming declaration, nor a return statement of a call
8632 to a function that returns an unconstrained record type with default
8633 discriminant, because there is no size to be computed in these cases
8634 and this will create a useless temporary. We must do this before any
8636 if (TREE_SIDE_EFFECTS (gnu_result
)
8637 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
8638 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
)))
8639 && !(TREE_CODE (gnu_result
) == CALL_EXPR
8640 && type_is_padding_self_referential (TREE_TYPE (gnu_result
))
8641 && (Nkind (Parent (gnat_node
)) == N_Object_Declaration
8642 || Nkind (Parent (gnat_node
)) == N_Object_Renaming_Declaration
8643 || Nkind (Parent (gnat_node
)) == N_Simple_Return_Statement
)))
8644 gnu_result
= gnat_protect_expr (gnu_result
);
8646 /* Now convert the result to the result type, unless we are in one of the
8649 1. If this is the LHS of an assignment or an actual parameter of a
8650 call, return the result almost unmodified since the RHS will have
8651 to be converted to our type in that case, unless the result type
8652 has a simpler size. Likewise if there is just a no-op unchecked
8653 conversion in-between. Similarly, don't convert integral types
8654 that are the operands of an unchecked conversion since we need
8655 to ignore those conversions (for 'Valid).
8657 2. If we have a label (which doesn't have any well-defined type), a
8658 field or an error, return the result almost unmodified. Similarly,
8659 if the two types are record types with the same name, don't convert.
8660 This will be the case when we are converting from a packable version
8661 of a type to its original type and we need those conversions to be
8662 NOPs in order for assignments into these types to work properly.
8664 3. If the type is void or if we have no result, return error_mark_node
8665 to show we have no result.
8667 4. If this is a call to a function that returns with variable size and
8668 the call is used as the expression in either an object or a renaming
8669 declaration, return the result unmodified because we want to use the
8670 return slot optimization in this case.
8672 5. Finally, if the type of the result is already correct. */
8674 if (Present (Parent (gnat_node
))
8675 && (lhs_or_actual_p (gnat_node
)
8676 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
8677 && unchecked_conversion_nop (Parent (gnat_node
)))
8678 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
8679 && !AGGREGATE_TYPE_P (gnu_result_type
)
8680 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))))
8681 && !(TYPE_SIZE (gnu_result_type
)
8682 && TYPE_SIZE (TREE_TYPE (gnu_result
))
8683 && (AGGREGATE_TYPE_P (gnu_result_type
)
8684 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
8685 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
8686 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
8688 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
8689 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
8690 && (CONTAINS_PLACEHOLDER_P
8691 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
8692 && !(TREE_CODE (gnu_result_type
) == RECORD_TYPE
8693 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type
))))
8695 /* Remove padding only if the inner object is of self-referential
8696 size: in that case it must be an object of unconstrained type
8697 with a default discriminant and we want to avoid copying too
8699 if (type_is_padding_self_referential (TREE_TYPE (gnu_result
)))
8700 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
8704 else if (TREE_CODE (gnu_result
) == LABEL_DECL
8705 || TREE_CODE (gnu_result
) == FIELD_DECL
8706 || TREE_CODE (gnu_result
) == ERROR_MARK
8707 || (TYPE_NAME (gnu_result_type
)
8708 == TYPE_NAME (TREE_TYPE (gnu_result
))
8709 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
8710 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
))
8712 /* Remove any padding. */
8713 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
8714 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
8718 else if (gnu_result
== error_mark_node
|| gnu_result_type
== void_type_node
)
8719 gnu_result
= error_mark_node
;
8721 else if (Present (Parent (gnat_node
))
8722 && (Nkind (Parent (gnat_node
)) == N_Object_Declaration
8723 || Nkind (Parent (gnat_node
)) == N_Object_Renaming_Declaration
)
8724 && TREE_CODE (gnu_result
) == CALL_EXPR
8725 && return_type_with_variable_size_p (TREE_TYPE (gnu_result
)))
8728 else if (TREE_TYPE (gnu_result
) != gnu_result_type
)
8729 gnu_result
= convert (gnu_result_type
, gnu_result
);
8731 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
8732 while ((TREE_CODE (gnu_result
) == NOP_EXPR
8733 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
8734 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
8735 gnu_result
= TREE_OPERAND (gnu_result
, 0);
8740 /* Similar to gnat_to_gnu, but discard any object that might be created in
8741 the course of the translation of GNAT_NODE, which must be an "external"
8742 expression in the sense that it will be elaborated elsewhere. */
8745 gnat_to_gnu_external (Node_Id gnat_node
)
8747 const int save_force_global
= force_global
;
8748 bool went_into_elab_proc
= false;
8750 /* Force the local context and create a fake scope that we zap
8751 at the end so declarations will not be stuck either in the
8752 global varpool or in the current scope. */
8753 if (!current_function_decl
)
8755 current_function_decl
= get_elaboration_procedure ();
8756 went_into_elab_proc
= true;
8761 tree gnu_result
= gnat_to_gnu (gnat_node
);
8764 force_global
= save_force_global
;
8765 if (went_into_elab_proc
)
8766 current_function_decl
= NULL_TREE
;
8768 /* Do not import locations from external units. */
8769 if (gnu_result
&& EXPR_P (gnu_result
))
8770 SET_EXPR_LOCATION (gnu_result
, UNKNOWN_LOCATION
);
8775 /* Return true if the statement list STMT_LIST is empty. */
8778 empty_stmt_list_p (tree stmt_list
)
8780 tree_stmt_iterator tsi
;
8782 for (tsi
= tsi_start (stmt_list
); !tsi_end_p (tsi
); tsi_next (&tsi
))
8784 tree stmt
= tsi_stmt (tsi
);
8786 /* Anything else than an empty STMT_STMT counts as something. */
8787 if (TREE_CODE (stmt
) != STMT_STMT
|| STMT_STMT_STMT (stmt
))
8794 /* Record the current code position in GNAT_NODE. */
8797 record_code_position (Node_Id gnat_node
)
8799 tree stmt_stmt
= build1 (STMT_STMT
, void_type_node
, NULL_TREE
);
8801 add_stmt_with_node (stmt_stmt
, gnat_node
);
8802 save_gnu_tree (gnat_node
, stmt_stmt
, true);
8805 /* Insert the code for GNAT_NODE at the position saved for that node. */
8808 insert_code_for (Node_Id gnat_node
)
8810 tree code
= gnat_to_gnu (gnat_node
);
8812 /* It's too late to remove the STMT_STMT itself at this point. */
8813 if (!empty_stmt_list_p (code
))
8814 STMT_STMT_STMT (get_gnu_tree (gnat_node
)) = code
;
8816 save_gnu_tree (gnat_node
, NULL_TREE
, true);
8819 /* Start a new statement group chained to the previous group. */
8822 start_stmt_group (void)
8824 struct stmt_group
*group
= stmt_group_free_list
;
8826 /* First see if we can get one from the free list. */
8828 stmt_group_free_list
= group
->previous
;
8830 group
= ggc_alloc
<stmt_group
> ();
8832 group
->previous
= current_stmt_group
;
8833 group
->stmt_list
= group
->block
= group
->cleanups
= NULL_TREE
;
8834 current_stmt_group
= group
;
8837 /* Add GNU_STMT to the current statement group. If it is an expression with
8838 no effects, it is ignored. */
8841 add_stmt (tree gnu_stmt
)
8843 append_to_statement_list (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
8846 /* Similar, but the statement is always added, regardless of side-effects. */
8849 add_stmt_force (tree gnu_stmt
)
8851 append_to_statement_list_force (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
8854 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
8857 add_stmt_with_node (tree gnu_stmt
, Node_Id gnat_node
)
8859 if (Present (gnat_node
))
8860 set_expr_location_from_node (gnu_stmt
, gnat_node
);
8861 add_stmt (gnu_stmt
);
8864 /* Similar, but the statement is always added, regardless of side-effects. */
8867 add_stmt_with_node_force (tree gnu_stmt
, Node_Id gnat_node
)
8869 if (Present (gnat_node
))
8870 set_expr_location_from_node (gnu_stmt
, gnat_node
);
8871 add_stmt_force (gnu_stmt
);
8874 /* Add a declaration statement for GNU_DECL to the current statement group.
8875 Get the SLOC to be put onto the statement from GNAT_NODE. */
8878 add_decl_expr (tree gnu_decl
, Node_Id gnat_node
)
8880 tree type
= TREE_TYPE (gnu_decl
);
8881 tree gnu_stmt
, gnu_init
;
8883 /* If this is a variable that Gigi is to ignore, we may have been given
8884 an ERROR_MARK. So test for it. We also might have been given a
8885 reference for a renaming. So only do something for a decl. Also
8886 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
8887 if (!DECL_P (gnu_decl
)
8888 || (TREE_CODE (gnu_decl
) == TYPE_DECL
8889 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
))
8892 gnu_stmt
= build1 (DECL_EXPR
, void_type_node
, gnu_decl
);
8894 /* If we are external or global, we don't want to output the DECL_EXPR for
8895 this DECL node since we already have evaluated the expressions in the
8896 sizes and positions as globals and doing it again would be wrong. */
8897 if (DECL_EXTERNAL (gnu_decl
) || global_bindings_p ())
8899 /* Mark everything as used to prevent node sharing with subprograms.
8900 Note that walk_tree knows how to deal with TYPE_DECL, but neither
8901 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
8902 MARK_VISITED (gnu_stmt
);
8903 if (TREE_CODE (gnu_decl
) == VAR_DECL
8904 || TREE_CODE (gnu_decl
) == CONST_DECL
)
8906 MARK_VISITED (DECL_SIZE (gnu_decl
));
8907 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl
));
8908 MARK_VISITED (DECL_INITIAL (gnu_decl
));
8910 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
8911 else if (TREE_CODE (gnu_decl
) == TYPE_DECL
8912 && RECORD_OR_UNION_TYPE_P (type
)
8913 && !TYPE_FAT_POINTER_P (type
))
8914 MARK_VISITED (TYPE_ADA_SIZE (type
));
8917 add_stmt_with_node (gnu_stmt
, gnat_node
);
8919 /* If this is a variable and an initializer is attached to it, it must be
8920 valid for the context. Similar to init_const in create_var_decl. */
8921 if (TREE_CODE (gnu_decl
) == VAR_DECL
8922 && (gnu_init
= DECL_INITIAL (gnu_decl
))
8923 && (!gnat_types_compatible_p (type
, TREE_TYPE (gnu_init
))
8924 || (TREE_STATIC (gnu_decl
)
8925 && !initializer_constant_valid_p (gnu_init
,
8926 TREE_TYPE (gnu_init
)))))
8928 DECL_INITIAL (gnu_decl
) = NULL_TREE
;
8929 if (TREE_READONLY (gnu_decl
))
8931 TREE_READONLY (gnu_decl
) = 0;
8932 DECL_READONLY_ONCE_ELAB (gnu_decl
) = 1;
8935 /* If GNU_DECL has a padded type, convert it to the unpadded
8936 type so the assignment is done properly. */
8937 if (TYPE_IS_PADDING_P (type
))
8938 gnu_decl
= convert (TREE_TYPE (TYPE_FIELDS (type
)), gnu_decl
);
8940 gnu_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_decl
, gnu_init
);
8941 add_stmt_with_node (gnu_stmt
, gnat_node
);
8945 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
8948 mark_visited_r (tree
*tp
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
8952 if (TREE_VISITED (t
))
8955 /* Don't mark a dummy type as visited because we want to mark its sizes
8956 and fields once it's filled in. */
8957 else if (!TYPE_IS_DUMMY_P (t
))
8958 TREE_VISITED (t
) = 1;
8961 TYPE_SIZES_GIMPLIFIED (t
) = 1;
8966 /* Mark nodes rooted at T with TREE_VISITED and types as having their
8967 sized gimplified. We use this to indicate all variable sizes and
8968 positions in global types may not be shared by any subprogram. */
8971 mark_visited (tree t
)
8973 walk_tree (&t
, mark_visited_r
, NULL
, NULL
);
8976 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
8977 set its location to that of GNAT_NODE if present, but with column info
8978 cleared so that conditional branches generated as part of the cleanup
8979 code do not interfere with coverage analysis tools. */
8982 add_cleanup (tree gnu_cleanup
, Node_Id gnat_node
)
8984 if (Present (gnat_node
))
8985 set_expr_location_from_node (gnu_cleanup
, gnat_node
, true);
8986 append_to_statement_list (gnu_cleanup
, ¤t_stmt_group
->cleanups
);
8989 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
8992 set_block_for_group (tree gnu_block
)
8994 gcc_assert (!current_stmt_group
->block
);
8995 current_stmt_group
->block
= gnu_block
;
8998 /* Return code corresponding to the current code group. It is normally
8999 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
9000 BLOCK or cleanups were set. */
9003 end_stmt_group (void)
9005 struct stmt_group
*group
= current_stmt_group
;
9006 tree gnu_retval
= group
->stmt_list
;
9008 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
9009 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
9010 make a BIND_EXPR. Note that we nest in that because the cleanup may
9011 reference variables in the block. */
9013 gnu_retval
= alloc_stmt_list ();
9015 if (group
->cleanups
)
9016 gnu_retval
= build2 (TRY_FINALLY_EXPR
, void_type_node
, gnu_retval
,
9019 if (current_stmt_group
->block
)
9020 gnu_retval
= build3 (BIND_EXPR
, void_type_node
, BLOCK_VARS (group
->block
),
9021 gnu_retval
, group
->block
);
9023 /* Remove this group from the stack and add it to the free list. */
9024 current_stmt_group
= group
->previous
;
9025 group
->previous
= stmt_group_free_list
;
9026 stmt_group_free_list
= group
;
9031 /* Return whether the current statement group may fall through. */
9034 stmt_group_may_fallthru (void)
9036 if (current_stmt_group
->stmt_list
)
9037 return block_may_fallthru (current_stmt_group
->stmt_list
);
9042 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
9046 add_stmt_list (List_Id gnat_list
)
9050 if (Present (gnat_list
))
9051 for (gnat_node
= First (gnat_list
); Present (gnat_node
);
9052 gnat_node
= Next (gnat_node
))
9053 add_stmt (gnat_to_gnu (gnat_node
));
9056 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
9057 If BINDING_P is true, push and pop a binding level around the list. */
9060 build_stmt_group (List_Id gnat_list
, bool binding_p
)
9062 start_stmt_group ();
9067 add_stmt_list (gnat_list
);
9072 return end_stmt_group ();
9075 /* Generate GIMPLE in place for the expression at *EXPR_P. */
9078 gnat_gimplify_expr (tree
*expr_p
, gimple_seq
*pre_p
,
9079 gimple_seq
*post_p ATTRIBUTE_UNUSED
)
9081 tree expr
= *expr_p
;
9082 tree type
= TREE_TYPE (expr
);
9085 if (IS_ADA_STMT (expr
))
9086 return gnat_gimplify_stmt (expr_p
);
9088 switch (TREE_CODE (expr
))
9091 /* If this is an aggregate type, build a null pointer of the appropriate
9092 type and dereference it. */
9093 if (AGGREGATE_TYPE_P (type
)
9094 || TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
9095 *expr_p
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
9096 convert (build_pointer_type (type
),
9097 integer_zero_node
));
9098 /* Otherwise, just make a VAR_DECL. */
9101 *expr_p
= create_tmp_var (type
, NULL
);
9102 TREE_NO_WARNING (*expr_p
) = 1;
9105 gimplify_and_add (TREE_OPERAND (expr
, 0), pre_p
);
9108 case UNCONSTRAINED_ARRAY_REF
:
9109 /* We should only do this if we are just elaborating for side-effects,
9110 but we can't know that yet. */
9111 *expr_p
= TREE_OPERAND (*expr_p
, 0);
9115 op
= TREE_OPERAND (expr
, 0);
9117 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
9118 is put into static memory. We know that it's going to be read-only
9119 given the semantics we have and it must be in static memory when the
9120 reference is in an elaboration procedure. */
9121 if (TREE_CODE (op
) == CONSTRUCTOR
&& TREE_CONSTANT (op
))
9123 tree addr
= build_fold_addr_expr (tree_output_constant_def (op
));
9124 *expr_p
= fold_convert (type
, addr
);
9128 /* Replace atomic loads with their first argument. That's necessary
9129 because the gimplifier would create a temporary otherwise. */
9130 if (TREE_SIDE_EFFECTS (op
))
9131 while (handled_component_p (op
) || CONVERT_EXPR_P (op
))
9133 tree inner
= TREE_OPERAND (op
, 0);
9134 if (TREE_CODE (inner
) == CALL_EXPR
&& call_is_atomic_load (inner
))
9136 tree t
= CALL_EXPR_ARG (inner
, 0);
9137 if (TREE_CODE (t
) == NOP_EXPR
)
9138 t
= TREE_OPERAND (t
, 0);
9139 if (TREE_CODE (t
) == ADDR_EXPR
)
9140 TREE_OPERAND (op
, 0) = TREE_OPERAND (t
, 0);
9142 TREE_OPERAND (op
, 0) = build_fold_indirect_ref (t
);
9148 return GS_UNHANDLED
;
9150 case VIEW_CONVERT_EXPR
:
9151 op
= TREE_OPERAND (expr
, 0);
9153 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
9154 type to a scalar one, explicitly create the local temporary. That's
9155 required if the type is passed by reference. */
9156 if ((TREE_CODE (op
) == CONSTRUCTOR
|| TREE_CODE (op
) == CALL_EXPR
)
9157 && AGGREGATE_TYPE_P (TREE_TYPE (op
))
9158 && !AGGREGATE_TYPE_P (type
))
9160 tree mod
, new_var
= create_tmp_var_raw (TREE_TYPE (op
), "C");
9161 gimple_add_tmp_var (new_var
);
9163 mod
= build2 (INIT_EXPR
, TREE_TYPE (new_var
), new_var
, op
);
9164 gimplify_and_add (mod
, pre_p
);
9166 TREE_OPERAND (expr
, 0) = new_var
;
9170 return GS_UNHANDLED
;
9173 op
= DECL_EXPR_DECL (expr
);
9175 /* The expressions for the RM bounds must be gimplified to ensure that
9176 they are properly elaborated. See gimplify_decl_expr. */
9177 if ((TREE_CODE (op
) == TYPE_DECL
|| TREE_CODE (op
) == VAR_DECL
)
9178 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op
)))
9179 switch (TREE_CODE (TREE_TYPE (op
)))
9186 tree type
= TYPE_MAIN_VARIANT (TREE_TYPE (op
)), t
, val
;
9188 val
= TYPE_RM_MIN_VALUE (type
);
9191 gimplify_one_sizepos (&val
, pre_p
);
9192 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
9193 SET_TYPE_RM_MIN_VALUE (t
, val
);
9196 val
= TYPE_RM_MAX_VALUE (type
);
9199 gimplify_one_sizepos (&val
, pre_p
);
9200 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
9201 SET_TYPE_RM_MAX_VALUE (t
, val
);
9211 /* ... fall through ... */
9214 return GS_UNHANDLED
;
9218 /* Generate GIMPLE in place for the statement at *STMT_P. */
9220 static enum gimplify_status
9221 gnat_gimplify_stmt (tree
*stmt_p
)
9223 tree stmt
= *stmt_p
;
9225 switch (TREE_CODE (stmt
))
9228 *stmt_p
= STMT_STMT_STMT (stmt
);
9233 tree gnu_start_label
= create_artificial_label (input_location
);
9234 tree gnu_cond
= LOOP_STMT_COND (stmt
);
9235 tree gnu_update
= LOOP_STMT_UPDATE (stmt
);
9236 tree gnu_end_label
= LOOP_STMT_LABEL (stmt
);
9238 /* Build the condition expression from the test, if any. */
9241 /* Deal with the optimization hints. */
9242 if (LOOP_STMT_IVDEP (stmt
))
9243 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
9244 build_int_cst (integer_type_node
,
9245 annot_expr_ivdep_kind
),
9247 if (LOOP_STMT_NO_UNROLL (stmt
))
9248 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
9249 build_int_cst (integer_type_node
,
9250 annot_expr_unroll_kind
),
9252 if (LOOP_STMT_UNROLL (stmt
))
9253 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
9254 build_int_cst (integer_type_node
,
9255 annot_expr_unroll_kind
),
9256 build_int_cst (NULL_TREE
, USHRT_MAX
));
9257 if (LOOP_STMT_NO_VECTOR (stmt
))
9258 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
9259 build_int_cst (integer_type_node
,
9260 annot_expr_no_vector_kind
),
9262 if (LOOP_STMT_VECTOR (stmt
))
9263 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
9264 build_int_cst (integer_type_node
,
9265 annot_expr_vector_kind
),
9269 = build3 (COND_EXPR
, void_type_node
, gnu_cond
, NULL_TREE
,
9270 build1 (GOTO_EXPR
, void_type_node
, gnu_end_label
));
9273 /* Set to emit the statements of the loop. */
9274 *stmt_p
= NULL_TREE
;
9276 /* We first emit the start label and then a conditional jump to the
9277 end label if there's a top condition, then the update if it's at
9278 the top, then the body of the loop, then a conditional jump to
9279 the end label if there's a bottom condition, then the update if
9280 it's at the bottom, and finally a jump to the start label and the
9281 definition of the end label. */
9282 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
9286 if (gnu_cond
&& !LOOP_STMT_BOTTOM_COND_P (stmt
))
9287 append_to_statement_list (gnu_cond
, stmt_p
);
9289 if (gnu_update
&& LOOP_STMT_TOP_UPDATE_P (stmt
))
9290 append_to_statement_list (gnu_update
, stmt_p
);
9292 append_to_statement_list (LOOP_STMT_BODY (stmt
), stmt_p
);
9294 if (gnu_cond
&& LOOP_STMT_BOTTOM_COND_P (stmt
))
9295 append_to_statement_list (gnu_cond
, stmt_p
);
9297 if (gnu_update
&& !LOOP_STMT_TOP_UPDATE_P (stmt
))
9298 append_to_statement_list (gnu_update
, stmt_p
);
9300 tree t
= build1 (GOTO_EXPR
, void_type_node
, gnu_start_label
);
9301 SET_EXPR_LOCATION (t
, DECL_SOURCE_LOCATION (gnu_end_label
));
9302 append_to_statement_list (t
, stmt_p
);
9304 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
9311 /* Build a statement to jump to the corresponding end label, then
9312 see if it needs to be conditional. */
9313 *stmt_p
= build1 (GOTO_EXPR
, void_type_node
, EXIT_STMT_LABEL (stmt
));
9314 if (EXIT_STMT_COND (stmt
))
9315 *stmt_p
= build3 (COND_EXPR
, void_type_node
,
9316 EXIT_STMT_COND (stmt
), *stmt_p
, alloc_stmt_list ());
9324 /* Force a reference to each of the entities in GNAT_PACKAGE recursively.
9326 This routine is exclusively called in type_annotate mode, to compute DDA
9327 information for types in withed units, for ASIS use. */
9330 elaborate_all_entities_for_package (Entity_Id gnat_package
)
9332 Entity_Id gnat_entity
;
9334 for (gnat_entity
= First_Entity (gnat_package
);
9335 Present (gnat_entity
);
9336 gnat_entity
= Next_Entity (gnat_entity
))
9338 const Entity_Kind kind
= Ekind (gnat_entity
);
9340 /* We are interested only in entities visible from the main unit. */
9341 if (!Is_Public (gnat_entity
))
9344 /* Skip stuff internal to the compiler. */
9345 if (Convention (gnat_entity
) == Convention_Intrinsic
)
9347 if (kind
== E_Operator
)
9349 if (IN (kind
, Subprogram_Kind
)
9350 && (Present (Alias (gnat_entity
))
9351 || Is_Intrinsic_Subprogram (gnat_entity
)))
9353 if (Is_Itype (gnat_entity
))
9356 /* Skip named numbers. */
9357 if (IN (kind
, Named_Kind
))
9360 /* Skip generic declarations. */
9361 if (IN (kind
, Generic_Unit_Kind
))
9364 /* Skip formal objects. */
9365 if (IN (kind
, Formal_Object_Kind
))
9368 /* Skip package bodies. */
9369 if (kind
== E_Package_Body
)
9372 /* Skip limited views that point back to the main unit. */
9373 if (IN (kind
, Incomplete_Kind
)
9374 && From_Limited_With (gnat_entity
)
9375 && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_entity
)))
9378 /* Skip types that aren't frozen. */
9379 if (IN (kind
, Type_Kind
) && !Is_Frozen (gnat_entity
))
9382 /* Recurse on real packages that aren't in the main unit. */
9383 if (kind
== E_Package
)
9385 if (No (Renamed_Entity (gnat_entity
))
9386 && !In_Extended_Main_Code_Unit (gnat_entity
))
9387 elaborate_all_entities_for_package (gnat_entity
);
9390 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
9394 /* Force a reference to each of the entities in packages withed by GNAT_NODE.
9395 Operate recursively but check that we aren't elaborating something more
9398 This routine is exclusively called in type_annotate mode, to compute DDA
9399 information for types in withed units, for ASIS use. */
9402 elaborate_all_entities (Node_Id gnat_node
)
9404 Entity_Id gnat_with_clause
;
9406 /* Process each unit only once. As we trace the context of all relevant
9407 units transitively, including generic bodies, we may encounter the
9408 same generic unit repeatedly. */
9409 if (!present_gnu_tree (gnat_node
))
9410 save_gnu_tree (gnat_node
, integer_zero_node
, true);
9412 /* Save entities in all context units. A body may have an implicit_with
9413 on its own spec, if the context includes a child unit, so don't save
9415 for (gnat_with_clause
= First (Context_Items (gnat_node
));
9416 Present (gnat_with_clause
);
9417 gnat_with_clause
= Next (gnat_with_clause
))
9418 if (Nkind (gnat_with_clause
) == N_With_Clause
9419 && !present_gnu_tree (Library_Unit (gnat_with_clause
))
9420 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
9422 Node_Id gnat_unit
= Library_Unit (gnat_with_clause
);
9423 Entity_Id gnat_entity
= Entity (Name (gnat_with_clause
));
9425 elaborate_all_entities (gnat_unit
);
9427 if (Ekind (gnat_entity
) == E_Package
9428 && No (Renamed_Entity (gnat_entity
)))
9429 elaborate_all_entities_for_package (gnat_entity
);
9431 else if (Ekind (gnat_entity
) == E_Generic_Package
)
9433 Node_Id gnat_body
= Corresponding_Body (Unit (gnat_unit
));
9435 /* Retrieve compilation unit node of generic body. */
9436 while (Present (gnat_body
)
9437 && Nkind (gnat_body
) != N_Compilation_Unit
)
9438 gnat_body
= Parent (gnat_body
);
9440 /* If body is available, elaborate its context. */
9441 if (Present (gnat_body
))
9442 elaborate_all_entities (gnat_body
);
9446 if (Nkind (Unit (gnat_node
)) == N_Package_Body
)
9447 elaborate_all_entities (Library_Unit (gnat_node
));
9450 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
9453 process_freeze_entity (Node_Id gnat_node
)
9455 const Entity_Id gnat_entity
= Entity (gnat_node
);
9456 const Entity_Kind kind
= Ekind (gnat_entity
);
9457 tree gnu_old
, gnu_new
;
9459 /* If this is a package, generate code for the package body, if any. */
9460 if (kind
== E_Package
)
9462 const Node_Id gnat_decl
= Parent (Declaration_Node (gnat_entity
));
9463 if (Present (Corresponding_Body (gnat_decl
)))
9464 insert_code_for (Parent (Corresponding_Body (gnat_decl
)));
9468 /* Don't do anything for class-wide types as they are always transformed
9469 into their root type. */
9470 if (kind
== E_Class_Wide_Type
)
9473 /* Check for an old definition if this isn't an object with address clause,
9474 since the saved GCC tree is the address expression in that case. */
9476 = present_gnu_tree (gnat_entity
) && No (Address_Clause (gnat_entity
))
9477 ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
9479 /* Don't do anything for subprograms that may have been elaborated before
9480 their freeze nodes. This can happen, for example, because of an inner
9481 call in an instance body or because of previous compilation of a spec
9482 for inlining purposes. */
9484 && ((TREE_CODE (gnu_old
) == FUNCTION_DECL
9485 && (kind
== E_Function
|| kind
== E_Procedure
))
9486 || (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_old
))
9487 && kind
== E_Subprogram_Type
)))
9490 /* If we have a non-dummy type old tree, we have nothing to do, except for
9491 aborting, since this node was never delayed as it should have been. We
9492 let this happen for concurrent types and their Corresponding_Record_Type,
9493 however, because each might legitimately be elaborated before its own
9494 freeze node, e.g. while processing the other. */
9496 && !(TREE_CODE (gnu_old
) == TYPE_DECL
9497 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
9499 gcc_assert (Is_Concurrent_Type (gnat_entity
)
9500 || (Is_Record_Type (gnat_entity
)
9501 && Is_Concurrent_Record_Type (gnat_entity
)));
9505 /* Reset the saved tree, if any, and elaborate the object or type for real.
9506 If there is a full view, elaborate it and use the result. And, if this
9507 is the root type of a class-wide type, reuse it for the latter. */
9510 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
9512 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9513 && Present (Full_View (gnat_entity
)))
9515 Entity_Id full_view
= Full_View (gnat_entity
);
9517 save_gnu_tree (full_view
, NULL_TREE
, false);
9519 if (Is_Private_Type (full_view
)
9520 && Present (Underlying_Full_View (full_view
)))
9522 full_view
= Underlying_Full_View (full_view
);
9523 save_gnu_tree (full_view
, NULL_TREE
, false);
9527 if (Is_Type (gnat_entity
)
9528 && Present (Class_Wide_Type (gnat_entity
))
9529 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
9530 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, false);
9533 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9534 && Present (Full_View (gnat_entity
)))
9536 Entity_Id full_view
= Full_View (gnat_entity
);
9538 if (Is_Private_Type (full_view
)
9539 && Present (Underlying_Full_View (full_view
)))
9540 full_view
= Underlying_Full_View (full_view
);
9542 gnu_new
= gnat_to_gnu_entity (full_view
, NULL_TREE
, true);
9544 /* Propagate back-annotations from full view to partial view. */
9545 if (Unknown_Alignment (gnat_entity
))
9546 Set_Alignment (gnat_entity
, Alignment (full_view
));
9548 if (Unknown_Esize (gnat_entity
))
9549 Set_Esize (gnat_entity
, Esize (full_view
));
9551 if (Unknown_RM_Size (gnat_entity
))
9552 Set_RM_Size (gnat_entity
, RM_Size (full_view
));
9554 /* The above call may have defined this entity (the simplest example
9555 of this is when we have a private enumeral type since the bounds
9556 will have the public view). */
9557 if (!present_gnu_tree (gnat_entity
))
9558 save_gnu_tree (gnat_entity
, gnu_new
, false);
9563 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
9564 && present_gnu_tree (Declaration_Node (gnat_entity
)))
9565 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
9567 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, true);
9570 if (Is_Type (gnat_entity
)
9571 && Present (Class_Wide_Type (gnat_entity
))
9572 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
9573 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, false);
9575 /* If we have an old type and we've made pointers to this type, update those
9576 pointers. If this is a Taft amendment type in the main unit, we need to
9577 mark the type as used since other units referencing it don't see the full
9578 declaration and, therefore, cannot mark it as used themselves. */
9581 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
9582 TREE_TYPE (gnu_new
));
9583 if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old
)))
9584 update_profiles_with (TREE_TYPE (gnu_old
));
9585 if (DECL_TAFT_TYPE_P (gnu_old
))
9586 used_types_insert (TREE_TYPE (gnu_new
));
9590 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
9591 We make two passes, one to elaborate anything other than bodies (but
9592 we declare a function if there was no spec). The second pass
9593 elaborates the bodies.
9595 GNAT_END_LIST gives the element in the list past the end. Normally,
9596 this is Empty, but can be First_Real_Statement for a
9597 Handled_Sequence_Of_Statements.
9599 We make a complete pass through both lists if PASS1P is true, then make
9600 the second pass over both lists if PASS2P is true. The lists usually
9601 correspond to the public and private parts of a package. */
9604 process_decls (List_Id gnat_decls
, List_Id gnat_decls2
,
9605 Node_Id gnat_end_list
, bool pass1p
, bool pass2p
)
9607 List_Id gnat_decl_array
[2];
9611 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
9614 for (i
= 0; i
<= 1; i
++)
9615 if (Present (gnat_decl_array
[i
]))
9616 for (gnat_decl
= First (gnat_decl_array
[i
]);
9617 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
9619 /* For package specs, we recurse inside the declarations,
9620 thus taking the two pass approach inside the boundary. */
9621 if (Nkind (gnat_decl
) == N_Package_Declaration
9622 && (Nkind (Specification (gnat_decl
)
9623 == N_Package_Specification
)))
9624 process_decls (Visible_Declarations (Specification (gnat_decl
)),
9625 Private_Declarations (Specification (gnat_decl
)),
9626 Empty
, true, false);
9628 /* Similarly for any declarations in the actions of a
9630 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
9632 process_freeze_entity (gnat_decl
);
9633 process_decls (Actions (gnat_decl
), Empty
, Empty
, true, false);
9636 /* Package bodies with freeze nodes get their elaboration deferred
9637 until the freeze node, but the code must be placed in the right
9638 place, so record the code position now. */
9639 else if (Nkind (gnat_decl
) == N_Package_Body
9640 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
9641 record_code_position (gnat_decl
);
9643 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
9644 && Present (Library_Unit (gnat_decl
))
9645 && Present (Freeze_Node
9648 (Library_Unit (gnat_decl
)))))))
9649 record_code_position
9650 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
9652 /* We defer most subprogram bodies to the second pass. */
9653 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
9655 if (Acts_As_Spec (gnat_decl
))
9657 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
9659 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
9660 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
9661 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, true);
9665 /* For bodies and stubs that act as their own specs, the entity
9666 itself must be elaborated in the first pass, because it may
9667 be used in other declarations. */
9668 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
9670 Node_Id gnat_subprog_id
9671 = Defining_Entity (Specification (gnat_decl
));
9673 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
9674 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
9675 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
9676 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, true);
9679 /* Concurrent stubs stand for the corresponding subprogram bodies,
9680 which are deferred like other bodies. */
9681 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
9682 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
9685 /* Renamed subprograms may not be elaborated yet at this point
9686 since renamings do not trigger freezing. Wait for the second
9687 pass to take care of them. */
9688 else if (Nkind (gnat_decl
) == N_Subprogram_Renaming_Declaration
)
9692 add_stmt (gnat_to_gnu (gnat_decl
));
9695 /* Here we elaborate everything we deferred above except for package bodies,
9696 which are elaborated at their freeze nodes. Note that we must also
9697 go inside things (package specs and freeze nodes) the first pass did. */
9699 for (i
= 0; i
<= 1; i
++)
9700 if (Present (gnat_decl_array
[i
]))
9701 for (gnat_decl
= First (gnat_decl_array
[i
]);
9702 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
9704 if (Nkind (gnat_decl
) == N_Subprogram_Body
9705 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
9706 || Nkind (gnat_decl
) == N_Task_Body_Stub
9707 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
9708 add_stmt (gnat_to_gnu (gnat_decl
));
9710 else if (Nkind (gnat_decl
) == N_Package_Declaration
9711 && (Nkind (Specification (gnat_decl
)
9712 == N_Package_Specification
)))
9713 process_decls (Visible_Declarations (Specification (gnat_decl
)),
9714 Private_Declarations (Specification (gnat_decl
)),
9715 Empty
, false, true);
9717 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
9718 process_decls (Actions (gnat_decl
), Empty
, Empty
, false, true);
9720 else if (Nkind (gnat_decl
) == N_Subprogram_Renaming_Declaration
)
9721 add_stmt (gnat_to_gnu (gnat_decl
));
9725 /* Make a unary operation of kind CODE using build_unary_op, but guard
9726 the operation by an overflow check. CODE can be one of NEGATE_EXPR
9727 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
9728 the operation is to be performed in that type. GNAT_NODE is the gnat
9729 node conveying the source location for which the error should be
9733 build_unary_op_trapv (enum tree_code code
, tree gnu_type
, tree operand
,
9736 gcc_assert (code
== NEGATE_EXPR
|| code
== ABS_EXPR
);
9738 operand
= gnat_protect_expr (operand
);
9740 return emit_check (build_binary_op (EQ_EXPR
, boolean_type_node
,
9741 operand
, TYPE_MIN_VALUE (gnu_type
)),
9742 build_unary_op (code
, gnu_type
, operand
),
9743 CE_Overflow_Check_Failed
, gnat_node
);
9746 /* Make a binary operation of kind CODE using build_binary_op, but guard
9747 the operation by an overflow check. CODE can be one of PLUS_EXPR,
9748 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
9749 Usually the operation is to be performed in that type. GNAT_NODE is
9750 the GNAT node conveying the source location for which the error should
9754 build_binary_op_trapv (enum tree_code code
, tree gnu_type
, tree left
,
9755 tree right
, Node_Id gnat_node
)
9757 const unsigned int precision
= TYPE_PRECISION (gnu_type
);
9758 tree lhs
= gnat_protect_expr (left
);
9759 tree rhs
= gnat_protect_expr (right
);
9760 tree type_max
= TYPE_MAX_VALUE (gnu_type
);
9761 tree type_min
= TYPE_MIN_VALUE (gnu_type
);
9762 tree gnu_expr
, check
;
9765 /* Assert that the precision is a power of 2. */
9766 gcc_assert ((precision
& (precision
- 1)) == 0);
9768 /* Prefer a constant on the RHS to simplify checks. */
9769 if (TREE_CODE (rhs
) != INTEGER_CST
9770 && TREE_CODE (lhs
) == INTEGER_CST
9771 && (code
== PLUS_EXPR
|| code
== MULT_EXPR
))
9778 gnu_expr
= build_binary_op (code
, gnu_type
, lhs
, rhs
);
9780 /* If we can fold the expression to a constant, just return it.
9781 The caller will deal with overflow, no need to generate a check. */
9782 if (TREE_CODE (gnu_expr
) == INTEGER_CST
)
9785 /* If no operand is a constant, we use the generic implementation. */
9786 if (TREE_CODE (lhs
) != INTEGER_CST
&& TREE_CODE (rhs
) != INTEGER_CST
)
9788 /* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
9789 if (code
== MULT_EXPR
&& precision
== 64 && BITS_PER_WORD
< 64)
9791 tree int64
= gnat_type_for_size (64, 0);
9792 return convert (gnu_type
, build_call_n_expr (mulv64_decl
, 2,
9793 convert (int64
, lhs
),
9794 convert (int64
, rhs
)));
9797 enum internal_fn icode
;
9802 icode
= IFN_ADD_OVERFLOW
;
9805 icode
= IFN_SUB_OVERFLOW
;
9808 icode
= IFN_MUL_OVERFLOW
;
9814 tree gnu_ctype
= build_complex_type (gnu_type
);
9816 = build_call_expr_internal_loc (UNKNOWN_LOCATION
, icode
, gnu_ctype
, 2,
9818 tree tgt
= save_expr (call
);
9819 gnu_expr
= build1 (REALPART_EXPR
, gnu_type
, tgt
);
9820 check
= fold_build2 (NE_EXPR
, boolean_type_node
,
9821 build1 (IMAGPART_EXPR
, gnu_type
, tgt
),
9822 build_int_cst (gnu_type
, 0));
9824 emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
9827 /* If one operand is a constant, we expose the overflow condition to enable
9828 a subsequent simplication or even elimination. */
9832 sgn
= tree_int_cst_sgn (rhs
);
9834 /* When rhs > 0, overflow when lhs > type_max - rhs. */
9835 check
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
9836 build_binary_op (MINUS_EXPR
, gnu_type
,
9839 /* When rhs < 0, overflow when lhs < type_min - rhs. */
9840 check
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
9841 build_binary_op (MINUS_EXPR
, gnu_type
,
9848 if (TREE_CODE (lhs
) == INTEGER_CST
)
9850 sgn
= tree_int_cst_sgn (lhs
);
9852 /* When lhs > 0, overflow when rhs < lhs - type_max. */
9853 check
= build_binary_op (LT_EXPR
, boolean_type_node
, rhs
,
9854 build_binary_op (MINUS_EXPR
, gnu_type
,
9857 /* When lhs < 0, overflow when rhs > lhs - type_min. */
9858 check
= build_binary_op (GT_EXPR
, boolean_type_node
, rhs
,
9859 build_binary_op (MINUS_EXPR
, gnu_type
,
9866 sgn
= tree_int_cst_sgn (rhs
);
9868 /* When rhs > 0, overflow when lhs < type_min + rhs. */
9869 check
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
9870 build_binary_op (PLUS_EXPR
, gnu_type
,
9873 /* When rhs < 0, overflow when lhs > type_max + rhs. */
9874 check
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
9875 build_binary_op (PLUS_EXPR
, gnu_type
,
9883 sgn
= tree_int_cst_sgn (rhs
);
9886 if (integer_onep (rhs
))
9889 tree lb
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
9890 tree ub
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
9892 /* When rhs > 1, overflow outside [type_min/rhs; type_max/rhs]. */
9894 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
9895 build_binary_op (LT_EXPR
, boolean_type_node
,
9897 build_binary_op (GT_EXPR
, boolean_type_node
,
9902 tree lb
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
9903 tree ub
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
9905 if (integer_minus_onep (rhs
))
9906 /* When rhs == -1, overflow if lhs == type_min. */
9908 = build_binary_op (EQ_EXPR
, boolean_type_node
, lhs
, type_min
);
9910 /* When rhs < -1, overflow outside [type_max/rhs; type_min/rhs]. */
9912 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
9913 build_binary_op (LT_EXPR
, boolean_type_node
,
9915 build_binary_op (GT_EXPR
, boolean_type_node
,
9926 return emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
9929 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
9930 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
9931 which we have to check. GNAT_NODE is the GNAT node conveying the source
9932 location for which the error should be signaled. */
9935 emit_range_check (tree gnu_expr
, Entity_Id gnat_range_type
, Node_Id gnat_node
)
9937 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
9938 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
9940 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
9941 This can for example happen when translating 'Val or 'Value. */
9942 if (gnu_compare_type
== gnu_range_type
)
9945 /* Range checks can only be applied to types with ranges. */
9946 gcc_assert (INTEGRAL_TYPE_P (gnu_range_type
)
9947 || SCALAR_FLOAT_TYPE_P (gnu_range_type
));
9949 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
9950 we can't do anything since we might be truncating the bounds. No
9951 check is needed in this case. */
9952 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
9953 && (TYPE_PRECISION (gnu_compare_type
)
9954 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
9957 /* Checked expressions must be evaluated only once. */
9958 gnu_expr
= gnat_protect_expr (gnu_expr
);
9960 /* Note that the form of the check is
9961 (not (expr >= lo)) or (not (expr <= hi))
9962 the reason for this slightly convoluted form is that NaNs
9963 are not considered to be in range in the float case. */
9965 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
9967 (build_binary_op (GE_EXPR
, boolean_type_node
,
9968 convert (gnu_compare_type
, gnu_expr
),
9969 convert (gnu_compare_type
,
9971 (gnu_range_type
)))),
9973 (build_binary_op (LE_EXPR
, boolean_type_node
,
9974 convert (gnu_compare_type
, gnu_expr
),
9975 convert (gnu_compare_type
,
9977 (gnu_range_type
))))),
9978 gnu_expr
, CE_Range_Check_Failed
, gnat_node
);
9981 /* GNU_COND contains the condition corresponding to an index, overflow or
9982 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
9983 if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
9984 REASON is the code that says why the exception is raised. GNAT_NODE is
9985 the node conveying the source location for which the error should be
9988 We used to propagate TREE_SIDE_EFFECTS from GNU_EXPR to the COND_EXPR,
9989 overwriting the setting inherited from the call statement, on the ground
9990 that the expression need not be evaluated just for the check. However
9991 that's incorrect because, in the GCC type system, its value is presumed
9992 to be valid so its comparison against the type bounds always yields true
9993 and, therefore, could be done without evaluating it; given that it can
9994 be a computation that overflows the bounds, the language may require the
9995 check to fail and thus the expression to be evaluated in this case. */
9998 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
, Node_Id gnat_node
)
10001 = build_call_raise (reason
, gnat_node
, N_Raise_Constraint_Error
);
10003 fold_build3 (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
10004 build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_call
,
10005 SCALAR_FLOAT_TYPE_P (TREE_TYPE (gnu_expr
))
10006 ? build_real (TREE_TYPE (gnu_expr
), dconst0
)
10007 : build_int_cst (TREE_TYPE (gnu_expr
), 0)),
10011 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
10012 checks if OVERFLOW_P is true and range checks if RANGE_P is true.
10013 If TRUNCATE_P true, do a float-to-integer conversion with truncation,
10014 otherwise round. GNAT_NODE is the GNAT node conveying the source location
10015 for which the error should be signaled. */
10018 convert_with_check (Entity_Id gnat_type
, tree gnu_expr
, bool overflow_p
,
10019 bool range_p
, bool truncate_p
, Node_Id gnat_node
)
10021 tree gnu_type
= get_unpadded_type (gnat_type
);
10022 tree gnu_base_type
= get_base_type (gnu_type
);
10023 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
10024 tree gnu_in_base_type
= get_base_type (gnu_in_type
);
10025 tree gnu_result
= gnu_expr
;
10027 /* If we are not doing any checks, the output is an integral type and the
10028 input is not a floating-point type, just do the conversion. This is
10029 required for packed array types and is simpler in all cases anyway. */
10032 && INTEGRAL_TYPE_P (gnu_base_type
)
10033 && !FLOAT_TYPE_P (gnu_in_base_type
))
10034 return convert (gnu_type
, gnu_expr
);
10036 /* If the mode of the input base type is larger, then converting to it below
10037 may pessimize the final conversion step, for example generate a libcall
10038 instead of a simple instruction, so use a narrower type in this case. */
10039 if (TYPE_MODE (gnu_in_base_type
) != TYPE_MODE (gnu_in_type
)
10040 && !(TREE_CODE (gnu_in_type
) == INTEGER_TYPE
10041 && TYPE_BIASED_REPRESENTATION_P (gnu_in_type
)))
10042 gnu_in_base_type
= gnat_type_for_mode (TYPE_MODE (gnu_in_type
),
10043 TYPE_UNSIGNED (gnu_in_type
));
10045 /* First convert the expression to the base type. This will never generate
10046 code, but makes the tests below simpler. But don't do this if converting
10047 from an integer type to an unconstrained array type since then we need to
10048 get the bounds from the original (unpacked) type. */
10049 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
10050 gnu_result
= convert (gnu_in_base_type
, gnu_result
);
10052 /* If overflow checks are requested, we need to be sure the result will fit
10053 in the output base type. But don't do this if the input is integer and
10054 the output floating-point. */
10056 && !(FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_base_type
)))
10058 /* Ensure GNU_EXPR only gets evaluated once. */
10059 tree gnu_input
= gnat_protect_expr (gnu_result
);
10060 tree gnu_cond
= boolean_false_node
;
10061 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_base_type
);
10062 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_base_type
);
10063 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
10064 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
10066 /* Convert the lower bounds to signed types, so we're sure we're
10067 comparing them properly. Likewise, convert the upper bounds
10068 to unsigned types. */
10069 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
10070 && TYPE_UNSIGNED (gnu_in_base_type
))
10072 = convert (gnat_signed_type_for (gnu_in_base_type
), gnu_in_lb
);
10074 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
10075 && !TYPE_UNSIGNED (gnu_in_base_type
))
10077 = convert (gnat_unsigned_type_for (gnu_in_base_type
), gnu_in_ub
);
10079 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
10081 = convert (gnat_signed_type_for (gnu_base_type
), gnu_out_lb
);
10083 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
10085 = convert (gnat_unsigned_type_for (gnu_base_type
), gnu_out_ub
);
10087 /* Check each bound separately and only if the result bound
10088 is tighter than the bound on the input type. Note that all the
10089 types are base types, so the bounds must be constant. Also,
10090 the comparison is done in the base type of the input, which
10091 always has the proper signedness. First check for input
10092 integer (which means output integer), output float (which means
10093 both float), or mixed, in which case we always compare.
10094 Note that we have to do the comparison which would *fail* in the
10095 case of an error since if it's an FP comparison and one of the
10096 values is a NaN or Inf, the comparison will fail. */
10097 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
10098 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
10099 : (FLOAT_TYPE_P (gnu_base_type
)
10100 ? real_less (&TREE_REAL_CST (gnu_in_lb
),
10101 &TREE_REAL_CST (gnu_out_lb
))
10104 = invert_truthvalue
10105 (build_binary_op (GE_EXPR
, boolean_type_node
,
10106 gnu_input
, convert (gnu_in_base_type
,
10109 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
10110 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
10111 : (FLOAT_TYPE_P (gnu_base_type
)
10112 ? real_less (&TREE_REAL_CST (gnu_out_ub
),
10113 &TREE_REAL_CST (gnu_in_ub
))
10116 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, gnu_cond
,
10118 (build_binary_op (LE_EXPR
, boolean_type_node
,
10120 convert (gnu_in_base_type
,
10123 if (!integer_zerop (gnu_cond
))
10124 gnu_result
= emit_check (gnu_cond
, gnu_input
,
10125 CE_Overflow_Check_Failed
, gnat_node
);
10128 /* Now convert to the result base type. If this is a non-truncating
10129 float-to-integer conversion, round. */
10130 if (INTEGRAL_TYPE_P (gnu_base_type
)
10131 && FLOAT_TYPE_P (gnu_in_base_type
)
10134 REAL_VALUE_TYPE half_minus_pred_half
, pred_half
;
10135 tree gnu_conv
, gnu_zero
, gnu_comp
, calc_type
;
10136 tree gnu_pred_half
, gnu_add_pred_half
, gnu_subtract_pred_half
;
10137 const struct real_format
*fmt
;
10139 /* The following calculations depend on proper rounding to even
10140 of each arithmetic operation. In order to prevent excess
10141 precision from spoiling this property, use the widest hardware
10142 floating-point type if FP_ARITH_MAY_WIDEN is true. */
10144 = fp_arith_may_widen
? longest_float_type_node
: gnu_in_base_type
;
10146 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
10147 fmt
= REAL_MODE_FORMAT (TYPE_MODE (calc_type
));
10148 real_2expN (&half_minus_pred_half
, -(fmt
->p
) - 1, TYPE_MODE (calc_type
));
10149 real_arithmetic (&pred_half
, MINUS_EXPR
, &dconsthalf
,
10150 &half_minus_pred_half
);
10151 gnu_pred_half
= build_real (calc_type
, pred_half
);
10153 /* If the input is strictly negative, subtract this value
10154 and otherwise add it from the input. For 0.5, the result
10155 is exactly between 1.0 and the machine number preceding 1.0
10156 (for calc_type). Since the last bit of 1.0 is even, this 0.5
10157 will round to 1.0, while all other number with an absolute
10158 value less than 0.5 round to 0.0. For larger numbers exactly
10159 halfway between integers, rounding will always be correct as
10160 the true mathematical result will be closer to the higher
10161 integer compared to the lower one. So, this constant works
10162 for all floating-point numbers.
10164 The reason to use the same constant with subtract/add instead
10165 of a positive and negative constant is to allow the comparison
10166 to be scheduled in parallel with retrieval of the constant and
10167 conversion of the input to the calc_type (if necessary). */
10169 gnu_zero
= build_real (gnu_in_base_type
, dconst0
);
10170 gnu_result
= gnat_protect_expr (gnu_result
);
10171 gnu_conv
= convert (calc_type
, gnu_result
);
10173 = fold_build2 (GE_EXPR
, boolean_type_node
, gnu_result
, gnu_zero
);
10175 = fold_build2 (PLUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
10176 gnu_subtract_pred_half
10177 = fold_build2 (MINUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
10178 gnu_result
= fold_build3 (COND_EXPR
, calc_type
, gnu_comp
,
10179 gnu_add_pred_half
, gnu_subtract_pred_half
);
10182 if (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
10183 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type
)
10184 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
10185 gnu_result
= unchecked_convert (gnu_base_type
, gnu_result
, false);
10187 gnu_result
= convert (gnu_base_type
, gnu_result
);
10189 /* Finally, do the range check if requested. Note that if the result type
10190 is a modular type, the range check is actually an overflow check. */
10193 && TREE_CODE (gnu_base_type
) == INTEGER_TYPE
10194 && TYPE_MODULAR_P (gnu_base_type
)))
10195 gnu_result
= emit_range_check (gnu_result
, gnat_type
, gnat_node
);
10197 return convert (gnu_type
, gnu_result
);
10200 /* Return true if GNU_EXPR can be directly addressed. This is the case
10201 unless it is an expression involving computation or if it involves a
10202 reference to a bitfield or to an object not sufficiently aligned for
10203 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
10204 be directly addressed as an object of this type.
10206 *** Notes on addressability issues in the Ada compiler ***
10208 This predicate is necessary in order to bridge the gap between Gigi
10209 and the middle-end about addressability of GENERIC trees. A tree
10210 is said to be addressable if it can be directly addressed, i.e. if
10211 its address can be taken, is a multiple of the type's alignment on
10212 strict-alignment architectures and returns the first storage unit
10213 assigned to the object represented by the tree.
10215 In the C family of languages, everything is in practice addressable
10216 at the language level, except for bit-fields. This means that these
10217 compilers will take the address of any tree that doesn't represent
10218 a bit-field reference and expect the result to be the first storage
10219 unit assigned to the object. Even in cases where this will result
10220 in unaligned accesses at run time, nothing is supposed to be done
10221 and the program is considered as erroneous instead (see PR c/18287).
10223 The implicit assumptions made in the middle-end are in keeping with
10224 the C viewpoint described above:
10225 - the address of a bit-field reference is supposed to be never
10226 taken; the compiler (generally) will stop on such a construct,
10227 - any other tree is addressable if it is formally addressable,
10228 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
10230 In Ada, the viewpoint is the opposite one: nothing is addressable
10231 at the language level unless explicitly declared so. This means
10232 that the compiler will both make sure that the trees representing
10233 references to addressable ("aliased" in Ada parlance) objects are
10234 addressable and make no real attempts at ensuring that the trees
10235 representing references to non-addressable objects are addressable.
10237 In the first case, Ada is effectively equivalent to C and handing
10238 down the direct result of applying ADDR_EXPR to these trees to the
10239 middle-end works flawlessly. In the second case, Ada cannot afford
10240 to consider the program as erroneous if the address of trees that
10241 are not addressable is requested for technical reasons, unlike C;
10242 as a consequence, the Ada compiler must arrange for either making
10243 sure that this address is not requested in the middle-end or for
10244 compensating by inserting temporaries if it is requested in Gigi.
10246 The first goal can be achieved because the middle-end should not
10247 request the address of non-addressable trees on its own; the only
10248 exception is for the invocation of low-level block operations like
10249 memcpy, for which the addressability requirements are lower since
10250 the type's alignment can be disregarded. In practice, this means
10251 that Gigi must make sure that such operations cannot be applied to
10252 non-BLKmode bit-fields.
10254 The second goal is achieved by means of the addressable_p predicate,
10255 which computes whether a temporary must be inserted by Gigi when the
10256 address of a tree is requested; if so, the address of the temporary
10257 will be used in lieu of that of the original tree and some glue code
10258 generated to connect everything together. */
10261 addressable_p (tree gnu_expr
, tree gnu_type
)
10263 /* For an integral type, the size of the actual type of the object may not
10264 be greater than that of the expected type, otherwise an indirect access
10265 in the latter type wouldn't correctly set all the bits of the object. */
10267 && INTEGRAL_TYPE_P (gnu_type
)
10268 && smaller_form_type_p (gnu_type
, TREE_TYPE (gnu_expr
)))
10271 /* The size of the actual type of the object may not be smaller than that
10272 of the expected type, otherwise an indirect access in the latter type
10273 would be larger than the object. But only record types need to be
10274 considered in practice for this case. */
10276 && TREE_CODE (gnu_type
) == RECORD_TYPE
10277 && smaller_form_type_p (TREE_TYPE (gnu_expr
), gnu_type
))
10280 switch (TREE_CODE (gnu_expr
))
10284 case FUNCTION_DECL
:
10286 /* All DECLs are addressable: if they are in a register, we can force
10290 case UNCONSTRAINED_ARRAY_REF
:
10292 /* Taking the address of a dereference yields the original pointer. */
10297 /* Taking the address yields a pointer to the constant pool. */
10301 /* Taking the address of a static constructor yields a pointer to the
10302 tree constant pool. */
10303 return TREE_STATIC (gnu_expr
) ? true : false;
10314 /* All rvalues are deemed addressable since taking their address will
10315 force a temporary to be created by the middle-end. */
10318 case COMPOUND_EXPR
:
10319 /* The address of a compound expression is that of its 2nd operand. */
10320 return addressable_p (TREE_OPERAND (gnu_expr
, 1), gnu_type
);
10323 /* We accept &COND_EXPR as soon as both operands are addressable and
10324 expect the outcome to be the address of the selected operand. */
10325 return (addressable_p (TREE_OPERAND (gnu_expr
, 1), NULL_TREE
)
10326 && addressable_p (TREE_OPERAND (gnu_expr
, 2), NULL_TREE
));
10328 case COMPONENT_REF
:
10329 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
10330 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
10331 the field is sufficiently aligned, in case it is subject
10332 to a pragma Component_Alignment. But we don't need to
10333 check the alignment of the containing record, as it is
10334 guaranteed to be not smaller than that of its most
10335 aligned field that is not a bit-field. */
10336 && (!STRICT_ALIGNMENT
10337 || DECL_ALIGN (TREE_OPERAND (gnu_expr
, 1))
10338 >= TYPE_ALIGN (TREE_TYPE (gnu_expr
))))
10339 /* The field of a padding record is always addressable. */
10340 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
10341 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
10343 case ARRAY_REF
: case ARRAY_RANGE_REF
:
10344 case REALPART_EXPR
: case IMAGPART_EXPR
:
10346 return addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
);
10349 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
10350 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
10352 case VIEW_CONVERT_EXPR
:
10354 /* This is addressable if we can avoid a copy. */
10355 tree type
= TREE_TYPE (gnu_expr
);
10356 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
10357 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
10358 && (!STRICT_ALIGNMENT
10359 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
10360 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
10361 || ((TYPE_MODE (type
) == BLKmode
10362 || TYPE_MODE (inner_type
) == BLKmode
)
10363 && (!STRICT_ALIGNMENT
10364 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
10365 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
10366 || TYPE_ALIGN_OK (type
)
10367 || TYPE_ALIGN_OK (inner_type
))))
10368 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
10376 /* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
10377 If a Freeze node exists for the entity, delay the bulk of the processing.
10378 Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
10381 process_type (Entity_Id gnat_entity
)
10384 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
10386 /* If we are to delay elaboration of this type, just do any elaboration
10387 needed for expressions within the declaration and make a dummy node
10388 for it and its Full_View (if any), in case something points to it.
10389 Do not do this if it has already been done (the only way that can
10390 happen is if the private completion is also delayed). */
10391 if (Present (Freeze_Node (gnat_entity
)))
10393 elaborate_entity (gnat_entity
);
10397 tree gnu_decl
= TYPE_STUB_DECL (make_dummy_type (gnat_entity
));
10398 save_gnu_tree (gnat_entity
, gnu_decl
, false);
10399 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
10400 && Present (Full_View (gnat_entity
)))
10402 if (Has_Completion_In_Body (gnat_entity
))
10403 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
10404 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, false);
10411 /* If we saved away a dummy type for this node, it means that this made the
10412 type that corresponds to the full type of an incomplete type. Clear that
10413 type for now and then update the type in the pointers below. But, if the
10414 saved type is not dummy, it very likely means that we have a use before
10415 declaration for the type in the tree, what we really cannot handle. */
10418 gcc_assert (TREE_CODE (gnu_old
) == TYPE_DECL
10419 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)));
10421 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
10424 /* Now fully elaborate the type. */
10425 tree gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, true);
10426 gcc_assert (TREE_CODE (gnu_new
) == TYPE_DECL
);
10428 /* If we have an old type and we've made pointers to this type, update those
10429 pointers. If this is a Taft amendment type in the main unit, we need to
10430 mark the type as used since other units referencing it don't see the full
10431 declaration and, therefore, cannot mark it as used themselves. */
10434 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
10435 TREE_TYPE (gnu_new
));
10436 if (DECL_TAFT_TYPE_P (gnu_old
))
10437 used_types_insert (TREE_TYPE (gnu_new
));
10440 /* If this is a record type corresponding to a task or protected type
10441 that is a completion of an incomplete type, perform a similar update
10442 on the type. ??? Including protected types here is a guess. */
10443 if (Is_Record_Type (gnat_entity
)
10444 && Is_Concurrent_Record_Type (gnat_entity
)
10445 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
10448 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
10450 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
10452 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
10455 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
10456 TREE_TYPE (gnu_new
));
10460 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
10461 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
10462 associations that are from RECORD_TYPE. If we see an internal record, make
10463 a recursive call to fill it in as well. */
10466 extract_values (tree values
, tree record_type
)
10468 vec
<constructor_elt
, va_gc
> *v
= NULL
;
10471 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
10473 tree tem
, value
= NULL_TREE
;
10475 /* _Parent is an internal field, but may have values in the aggregate,
10476 so check for values first. */
10477 if ((tem
= purpose_member (field
, values
)))
10479 value
= TREE_VALUE (tem
);
10480 TREE_ADDRESSABLE (tem
) = 1;
10483 else if (DECL_INTERNAL_P (field
))
10485 value
= extract_values (values
, TREE_TYPE (field
));
10486 if (TREE_CODE (value
) == CONSTRUCTOR
10487 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value
)))
10491 /* If we have a record subtype, the names will match, but not the
10492 actual FIELD_DECLs. */
10493 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
10494 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
10496 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
10497 TREE_ADDRESSABLE (tem
) = 1;
10503 CONSTRUCTOR_APPEND_ELT (v
, field
, value
);
10506 return gnat_build_constructor (record_type
, v
);
10509 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
10510 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
10511 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
10514 assoc_to_constructor (Entity_Id gnat_entity
, Node_Id gnat_assoc
, tree gnu_type
)
10516 tree gnu_list
= NULL_TREE
, gnu_result
;
10518 /* We test for GNU_FIELD being empty in the case where a variant
10519 was the last thing since we don't take things off GNAT_ASSOC in
10520 that case. We check GNAT_ASSOC in case we have a variant, but it
10523 for (; Present (gnat_assoc
); gnat_assoc
= Next (gnat_assoc
))
10525 Node_Id gnat_field
= First (Choices (gnat_assoc
));
10526 tree gnu_field
= gnat_to_gnu_field_decl (Entity (gnat_field
));
10527 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
10529 /* The expander is supposed to put a single component selector name
10530 in every record component association. */
10531 gcc_assert (No (Next (gnat_field
)));
10533 /* Ignore discriminants that have Corresponding_Discriminants in tagged
10534 types since we'll be setting those fields in the parent subtype. */
10535 if (Ekind (Entity (gnat_field
)) == E_Discriminant
10536 && Present (Corresponding_Discriminant (Entity (gnat_field
)))
10537 && Is_Tagged_Type (Scope (Entity (gnat_field
))))
10540 /* Also ignore discriminants of Unchecked_Unions. */
10541 if (Ekind (Entity (gnat_field
)) == E_Discriminant
10542 && Is_Unchecked_Union (gnat_entity
))
10545 /* Before assigning a value in an aggregate make sure range checks
10546 are done if required. Then convert to the type of the field. */
10547 if (Do_Range_Check (Expression (gnat_assoc
)))
10548 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
), Empty
);
10550 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
10552 /* Add the field and expression to the list. */
10553 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
10556 gnu_result
= extract_values (gnu_list
, gnu_type
);
10560 /* Verify that every entry in GNU_LIST was used. */
10561 for (; gnu_list
; gnu_list
= TREE_CHAIN (gnu_list
))
10562 gcc_assert (TREE_ADDRESSABLE (gnu_list
));
10568 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
10569 the first element of an array aggregate. It may itself be an aggregate.
10570 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
10571 GNAT_COMPONENT_TYPE is the type of the array component; it is needed
10572 for range checking. */
10575 pos_to_constructor (Node_Id gnat_expr
, tree gnu_array_type
,
10576 Entity_Id gnat_component_type
)
10578 tree gnu_index
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type
));
10579 vec
<constructor_elt
, va_gc
> *gnu_expr_vec
= NULL
;
10581 for (; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
10585 /* If the expression is itself an array aggregate then first build the
10586 innermost constructor if it is part of our array (multi-dimensional
10588 if (Nkind (gnat_expr
) == N_Aggregate
10589 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
10590 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
10591 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
10592 TREE_TYPE (gnu_array_type
),
10593 gnat_component_type
);
10596 /* If the expression is a conversion to an unconstrained array type,
10597 skip it to avoid spilling to memory. */
10598 if (Nkind (gnat_expr
) == N_Type_Conversion
10599 && Is_Array_Type (Etype (gnat_expr
))
10600 && !Is_Constrained (Etype (gnat_expr
)))
10601 gnu_expr
= gnat_to_gnu (Expression (gnat_expr
));
10603 gnu_expr
= gnat_to_gnu (gnat_expr
);
10605 /* Before assigning the element to the array, make sure it is
10607 if (Do_Range_Check (gnat_expr
))
10608 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
, Empty
);
10611 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec
, gnu_index
,
10612 convert (TREE_TYPE (gnu_array_type
), gnu_expr
));
10614 gnu_index
= int_const_binop (PLUS_EXPR
, gnu_index
,
10615 convert (TREE_TYPE (gnu_index
),
10616 integer_one_node
));
10619 return gnat_build_constructor (gnu_array_type
, gnu_expr_vec
);
10622 /* Process a N_Validate_Unchecked_Conversion node. */
10625 validate_unchecked_conversion (Node_Id gnat_node
)
10627 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
10628 tree gnu_target_type
= gnat_to_gnu_type (Target_Type (gnat_node
));
10630 /* If the target is a pointer type, see if we are either converting from a
10631 non-pointer or from a pointer to a type with a different alias set and
10632 warn if so, unless the pointer has been marked to alias everything. */
10633 if (POINTER_TYPE_P (gnu_target_type
)
10634 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type
))
10636 tree gnu_source_desig_type
= POINTER_TYPE_P (gnu_source_type
)
10637 ? TREE_TYPE (gnu_source_type
)
10639 tree gnu_target_desig_type
= TREE_TYPE (gnu_target_type
);
10640 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
10642 if (target_alias_set
!= 0
10643 && (!POINTER_TYPE_P (gnu_source_type
)
10644 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
10645 target_alias_set
)))
10647 post_error_ne ("?possible aliasing problem for type&",
10648 gnat_node
, Target_Type (gnat_node
));
10649 post_error ("\\?use -fno-strict-aliasing switch for references",
10651 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
10652 gnat_node
, Target_Type (gnat_node
));
10656 /* Likewise if the target is a fat pointer type, but we have no mechanism to
10657 mitigate the problem in this case, so we unconditionally warn. */
10658 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type
))
10660 tree gnu_source_desig_type
10661 = TYPE_IS_FAT_POINTER_P (gnu_source_type
)
10662 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type
)))
10664 tree gnu_target_desig_type
10665 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type
)));
10666 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
10668 if (target_alias_set
!= 0
10669 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type
)
10670 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
10671 target_alias_set
)))
10673 post_error_ne ("?possible aliasing problem for type&",
10674 gnat_node
, Target_Type (gnat_node
));
10675 post_error ("\\?use -fno-strict-aliasing switch for references",
10681 /* EXP is to be used in a context where access objects are implicitly
10682 dereferenced. Handle the cases when it is an access object. */
10685 adjust_for_implicit_deref (Node_Id exp
)
10687 Entity_Id type
= Underlying_Type (Etype (exp
));
10689 /* Make sure the designated type is complete before dereferencing. */
10690 if (Is_Access_Type (type
))
10691 gnat_to_gnu_entity (Designated_Type (type
), NULL_TREE
, false);
10696 /* EXP is to be treated as an array or record. Handle the cases when it is
10697 an access object and perform the required dereferences. */
10700 maybe_implicit_deref (tree exp
)
10702 /* If the type is a pointer, dereference it. */
10703 if (POINTER_TYPE_P (TREE_TYPE (exp
))
10704 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp
)))
10705 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
10707 /* If we got a padded type, remove it too. */
10708 if (TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
10709 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
10714 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a
10715 source code location and false if it doesn't. If CLEAR_COLUMN is
10716 true, set the column information to 0. If DECL is given and SLOC
10717 refers to a File with an instance, map DECL to that instance. */
10720 Sloc_to_locus (Source_Ptr Sloc
, location_t
*locus
, bool clear_column
,
10723 if (Sloc
== No_Location
)
10726 if (Sloc
<= Standard_Location
)
10728 *locus
= BUILTINS_LOCATION
;
10732 Source_File_Index file
= Get_Source_File_Index (Sloc
);
10733 Logical_Line_Number line
= Get_Logical_Line_Number (Sloc
);
10734 Column_Number column
= (clear_column
? 0 : Get_Column_Number (Sloc
));
10735 line_map_ordinary
*map
= LINEMAPS_ORDINARY_MAP_AT (line_table
, file
- 1);
10737 /* We can have zero if pragma Source_Reference is in effect. */
10741 /* Translate the location. */
10743 = linemap_position_for_line_and_column (line_table
, map
, line
, column
);
10745 if (file_map
&& file_map
[file
- 1].Instance
)
10746 decl_to_instance_map
->put (decl
, file_map
[file
- 1].Instance
);
10751 /* Return whether GNAT_NODE is a defining identifier for a renaming that comes
10752 from the parameter association for the instantiation of a generic. We do
10753 not want to emit source location for them: the code generated for their
10754 initialization is likely to disturb debugging. */
10757 renaming_from_instantiation_p (Node_Id gnat_node
)
10759 if (Nkind (gnat_node
) != N_Defining_Identifier
10760 || !Is_Object (gnat_node
)
10761 || Comes_From_Source (gnat_node
)
10762 || !Present (Renamed_Object (gnat_node
)))
10765 /* Get the object declaration of the renamed object, if any and if the
10766 renamed object is a mere identifier. */
10767 gnat_node
= Renamed_Object (gnat_node
);
10768 if (Nkind (gnat_node
) != N_Identifier
)
10771 gnat_node
= Parent (Entity (gnat_node
));
10772 return (Present (gnat_node
)
10773 && Nkind (gnat_node
) == N_Object_Declaration
10774 && Present (Corresponding_Generic_Association (gnat_node
)));
10777 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
10778 don't do anything if it doesn't correspond to a source location. And,
10779 if CLEAR_COLUMN is true, set the column information to 0. */
10782 set_expr_location_from_node (tree node
, Node_Id gnat_node
, bool clear_column
)
10786 /* Do not set a location for constructs likely to disturb debugging. */
10787 if (Nkind (gnat_node
) == N_Defining_Identifier
)
10789 if (Is_Type (gnat_node
) && Is_Actual_Subtype (gnat_node
))
10792 if (renaming_from_instantiation_p (gnat_node
))
10796 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
, clear_column
))
10799 SET_EXPR_LOCATION (node
, locus
);
10802 /* More elaborate version of set_expr_location_from_node to be used in more
10803 general contexts, for example the result of the translation of a generic
10807 set_gnu_expr_location_from_node (tree node
, Node_Id gnat_node
)
10809 /* Set the location information on the node if it is a real expression.
10810 References can be reused for multiple GNAT nodes and they would get
10811 the location information of their last use. Also make sure not to
10812 overwrite an existing location as it is probably more precise. */
10814 switch (TREE_CODE (node
))
10817 case NON_LVALUE_EXPR
:
10821 case COMPOUND_EXPR
:
10822 if (EXPR_P (TREE_OPERAND (node
, 1)))
10823 set_gnu_expr_location_from_node (TREE_OPERAND (node
, 1), gnat_node
);
10825 /* ... fall through ... */
10828 if (!REFERENCE_CLASS_P (node
) && !EXPR_HAS_LOCATION (node
))
10830 set_expr_location_from_node (node
, gnat_node
);
10831 set_end_locus_from_node (node
, gnat_node
);
10837 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
10838 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
10839 most sense. Return true if a sensible assignment was performed. */
10842 set_end_locus_from_node (tree gnu_node
, Node_Id gnat_node
)
10844 Node_Id gnat_end_label
;
10845 location_t end_locus
;
10847 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
10848 end_locus when there is one. We consider only GNAT nodes with a possible
10849 End_Label attached. If the End_Label actually was unassigned, fallback
10850 on the original node. We'd better assign an explicit sloc associated with
10851 the outer construct in any case. */
10853 switch (Nkind (gnat_node
))
10855 case N_Package_Body
:
10856 case N_Subprogram_Body
:
10857 case N_Block_Statement
:
10858 gnat_end_label
= End_Label (Handled_Statement_Sequence (gnat_node
));
10861 case N_Package_Declaration
:
10862 gnat_end_label
= End_Label (Specification (gnat_node
));
10869 if (Present (gnat_end_label
))
10870 gnat_node
= gnat_end_label
;
10872 /* Some expanded subprograms have neither an End_Label nor a Sloc
10873 attached. Notify that to callers. For a block statement with no
10874 End_Label, clear column information, so that the tree for a
10875 transient block does not receive the sloc of a source condition. */
10876 if (!Sloc_to_locus (Sloc (gnat_node
), &end_locus
,
10877 No (gnat_end_label
)
10878 && (Nkind (gnat_node
) == N_Block_Statement
)))
10881 switch (TREE_CODE (gnu_node
))
10884 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node
)) = end_locus
;
10887 case FUNCTION_DECL
:
10888 DECL_STRUCT_FUNCTION (gnu_node
)->function_end_locus
= end_locus
;
10896 /* Return a colon-separated list of encodings contained in encoded Ada
10899 static const char *
10900 extract_encoding (const char *name
)
10902 char *encoding
= (char *) ggc_alloc_atomic (strlen (name
));
10903 get_encoding (name
, encoding
);
10907 /* Extract the Ada name from an encoded name. */
10909 static const char *
10910 decode_name (const char *name
)
10912 char *decoded
= (char *) ggc_alloc_atomic (strlen (name
) * 2 + 60);
10913 __gnat_decode (name
, decoded
, 0);
10917 /* Post an error message. MSG is the error message, properly annotated.
10918 NODE is the node at which to post the error and the node to use for the
10919 '&' substitution. */
10922 post_error (const char *msg
, Node_Id node
)
10924 String_Template temp
;
10930 temp
.Low_Bound
= 1;
10931 temp
.High_Bound
= strlen (msg
);
10934 Error_Msg_N (sp
, node
);
10937 /* Similar to post_error, but NODE is the node at which to post the error and
10938 ENT is the node to use for the '&' substitution. */
10941 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
10943 String_Template temp
;
10949 temp
.Low_Bound
= 1;
10950 temp
.High_Bound
= strlen (msg
);
10953 Error_Msg_NE (sp
, node
, ent
);
10956 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
10959 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int num
)
10961 Error_Msg_Uint_1
= UI_From_Int (num
);
10962 post_error_ne (msg
, node
, ent
);
10965 /* Similar to post_error_ne, but T is a GCC tree representing the number to
10966 write. If T represents a constant, the text inside curly brackets in
10967 MSG will be output (presumably including a '^'). Otherwise it will not
10968 be output and the text inside square brackets will be output instead. */
10971 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
10973 char *new_msg
= XALLOCAVEC (char, strlen (msg
) + 1);
10974 char start_yes
, end_yes
, start_no
, end_no
;
10978 if (TREE_CODE (t
) == INTEGER_CST
)
10980 Error_Msg_Uint_1
= UI_From_gnu (t
);
10981 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
10984 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
10986 for (p
= msg
, q
= new_msg
; *p
; p
++)
10988 if (*p
== start_yes
)
10989 for (p
++; *p
!= end_yes
; p
++)
10991 else if (*p
== start_no
)
10992 for (p
++; *p
!= end_no
; p
++)
11000 post_error_ne (new_msg
, node
, ent
);
11003 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
11006 post_error_ne_tree_2 (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
,
11009 Error_Msg_Uint_2
= UI_From_Int (num
);
11010 post_error_ne_tree (msg
, node
, ent
, t
);
11013 /* Return a label to branch to for the exception type in KIND or Empty
11017 get_exception_label (char kind
)
11021 case N_Raise_Constraint_Error
:
11022 return gnu_constraint_error_label_stack
.last ();
11024 case N_Raise_Storage_Error
:
11025 return gnu_storage_error_label_stack
.last ();
11027 case N_Raise_Program_Error
:
11028 return gnu_program_error_label_stack
.last ();
11034 gcc_unreachable ();
11037 /* Return the decl for the current elaboration procedure. */
11040 get_elaboration_procedure (void)
11042 return gnu_elab_proc_stack
->last ();
11045 /* Return the controlling type of a dispatching subprogram. */
11048 get_controlling_type (Entity_Id subprog
)
11050 /* This is modelled on Expand_Interface_Thunk. */
11051 Entity_Id controlling_type
= Etype (First_Formal (subprog
));
11052 if (Is_Access_Type (controlling_type
))
11053 controlling_type
= Directly_Designated_Type (controlling_type
);
11054 controlling_type
= Underlying_Type (controlling_type
);
11055 if (Is_Concurrent_Type (controlling_type
))
11056 controlling_type
= Corresponding_Record_Type (controlling_type
);
11057 controlling_type
= Base_Type (controlling_type
);
11058 return controlling_type
;
11061 /* Return whether we should use an alias for the TARGET of a thunk
11062 in order to make the call generated in the thunk local. */
11065 use_alias_for_thunk_p (tree target
)
11067 /* We cannot generate a local call in this case. */
11068 if (DECL_EXTERNAL (target
))
11071 /* The call is already local in this case. */
11072 if (TREE_CODE (DECL_CONTEXT (target
)) == FUNCTION_DECL
)
11075 return TARGET_USE_LOCAL_THUNK_ALIAS_P (target
);
11078 static GTY(()) unsigned long thunk_labelno
= 0;
11080 /* Create an alias for TARGET to be used as the target of a thunk. */
11083 make_alias_for_thunk (tree target
)
11086 targetm
.asm_out
.generate_internal_label (buf
, "LTHUNK", thunk_labelno
++);
11088 tree alias
= build_decl (DECL_SOURCE_LOCATION (target
), TREE_CODE (target
),
11089 get_identifier (buf
), TREE_TYPE (target
));
11091 DECL_LANG_SPECIFIC (alias
) = DECL_LANG_SPECIFIC (target
);
11092 DECL_CONTEXT (alias
) = DECL_CONTEXT (target
);
11093 TREE_READONLY (alias
) = TREE_READONLY (target
);
11094 TREE_THIS_VOLATILE (alias
) = TREE_THIS_VOLATILE (target
);
11095 DECL_ARTIFICIAL (alias
) = 1;
11096 DECL_INITIAL (alias
) = error_mark_node
;
11097 DECL_ARGUMENTS (alias
) = copy_list (DECL_ARGUMENTS (target
));
11098 TREE_ADDRESSABLE (alias
) = 1;
11099 SET_DECL_ASSEMBLER_NAME (alias
, DECL_NAME (alias
));
11101 cgraph_node
*n
= cgraph_node::create_same_body_alias (alias
, target
);
11107 /* Create the covariant part of the {GNAT,GNU}_THUNK. */
11110 make_covariant_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
)
11112 tree gnu_name
= create_concat_name (gnat_thunk
, "CV");
11114 = build_decl (DECL_SOURCE_LOCATION (gnu_thunk
), TREE_CODE (gnu_thunk
),
11115 gnu_name
, TREE_TYPE (gnu_thunk
));
11117 DECL_ARGUMENTS (gnu_cv_thunk
) = copy_list (DECL_ARGUMENTS (gnu_thunk
));
11118 DECL_RESULT (gnu_cv_thunk
) = copy_node (DECL_RESULT (gnu_thunk
));
11119 DECL_CONTEXT (DECL_RESULT (gnu_cv_thunk
)) = gnu_cv_thunk
;
11121 DECL_LANG_SPECIFIC (gnu_cv_thunk
) = DECL_LANG_SPECIFIC (gnu_thunk
);
11122 DECL_CONTEXT (gnu_cv_thunk
) = DECL_CONTEXT (gnu_thunk
);
11123 TREE_READONLY (gnu_cv_thunk
) = TREE_READONLY (gnu_thunk
);
11124 TREE_THIS_VOLATILE (gnu_cv_thunk
) = TREE_THIS_VOLATILE (gnu_thunk
);
11125 TREE_PUBLIC (gnu_cv_thunk
) = TREE_PUBLIC (gnu_thunk
);
11126 DECL_ARTIFICIAL (gnu_cv_thunk
) = 1;
11128 return gnu_cv_thunk
;
11131 /* Try to create a GNU thunk for {GNAT,GNU}_THUNK and return true on success.
11133 GNU thunks are more efficient than GNAT thunks because they don't call into
11134 the runtime to retrieve the offset used in the displacement operation, but
11135 they are tailored to C++ and thus too limited to support the full range of
11136 thunks generated in Ada. Here's the complete list of limitations:
11138 1. Multi-controlling thunks, i.e thunks with more than one controlling
11139 parameter, are simply not supported.
11141 2. Covariant thunks, i.e. thunks for which the result is also controlling,
11142 are split into a pair of (this, covariant-only) thunks.
11144 3. Variable-offset thunks, i.e. thunks for which the offset depends on the
11145 object and not only on its type, are supported as 2nd class citizens.
11147 4. External thunks, i.e. thunks for which the target is not declared in
11148 the same unit as the thunk, are supported as 2nd class citizens.
11150 5. Local thunks, i.e. thunks generated for a local type, are supported as
11151 2nd class citizens. */
11154 maybe_make_gnu_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
)
11156 const Entity_Id gnat_target
= Thunk_Entity (gnat_thunk
);
11158 /* Check that the first formal of the target is the only controlling one. */
11159 Entity_Id gnat_formal
= First_Formal (gnat_target
);
11160 if (!Is_Controlling_Formal (gnat_formal
))
11162 for (gnat_formal
= Next_Formal (gnat_formal
);
11163 Present (gnat_formal
);
11164 gnat_formal
= Next_Formal (gnat_formal
))
11165 if (Is_Controlling_Formal (gnat_formal
))
11168 /* Look for the types that control the target and the thunk. */
11169 const Entity_Id gnat_controlling_type
= get_controlling_type (gnat_target
);
11170 const Entity_Id gnat_interface_type
= get_controlling_type (gnat_thunk
);
11172 /* Now compute whether the former covers the latter. */
11173 const Entity_Id gnat_interface_tag
11174 = Is_Interface (gnat_interface_type
)
11175 ? Find_Interface_Tag (gnat_controlling_type
, gnat_interface_type
)
11177 tree gnu_interface_tag
11178 = Present (gnat_interface_tag
)
11179 ? gnat_to_gnu_field_decl (gnat_interface_tag
)
11181 tree gnu_interface_offset
11182 = gnu_interface_tag
? byte_position (gnu_interface_tag
) : NULL_TREE
;
11184 /* There are three ways to retrieve the offset between the interface view
11185 and the base object. Either the controlling type covers the interface
11186 type and the offset of the corresponding tag is fixed, in which case it
11187 can be statically encoded in the thunk (see FIXED_OFFSET below). Or the
11188 controlling type doesn't cover the interface type but is of fixed size,
11189 in which case the offset is stored in the dispatch table, two pointers
11190 above the dispatch table address (see VIRTUAL_VALUE below). Otherwise,
11191 the offset is variable and is stored right after the tag in every object
11192 (see INDIRECT_OFFSET below). See also a-tags.ads for more details. */
11193 HOST_WIDE_INT fixed_offset
, virtual_value
, indirect_offset
;
11194 tree virtual_offset
;
11196 if (gnu_interface_offset
&& TREE_CODE (gnu_interface_offset
) == INTEGER_CST
)
11198 fixed_offset
= - tree_to_shwi (gnu_interface_offset
);
11200 virtual_offset
= NULL_TREE
;
11201 indirect_offset
= 0;
11203 else if (!gnu_interface_offset
11204 && !Is_Variable_Size_Record (gnat_controlling_type
))
11207 virtual_value
= - 2 * (HOST_WIDE_INT
) (POINTER_SIZE
/ BITS_PER_UNIT
);
11208 virtual_offset
= build_int_cst (integer_type_node
, virtual_value
);
11209 indirect_offset
= 0;
11213 /* Covariant thunks with variable offset are not supported. */
11214 if (Has_Controlling_Result (gnat_target
))
11219 virtual_offset
= NULL_TREE
;
11220 indirect_offset
= (HOST_WIDE_INT
) (POINTER_SIZE
/ BITS_PER_UNIT
);
11223 tree gnu_target
= gnat_to_gnu_entity (gnat_target
, NULL_TREE
, false);
11225 /* Thunk and target must have the same nesting level, if any. */
11226 gcc_assert (DECL_CONTEXT (gnu_thunk
) == DECL_CONTEXT (gnu_target
));
11228 /* If the target returns by invisible reference and is external, apply the
11229 same transformation as Subprogram_Body_to_gnu here. */
11230 if (TREE_ADDRESSABLE (TREE_TYPE (gnu_target
))
11231 && DECL_EXTERNAL (gnu_target
)
11232 && !POINTER_TYPE_P (TREE_TYPE (DECL_RESULT (gnu_target
))))
11234 TREE_TYPE (DECL_RESULT (gnu_target
))
11235 = build_reference_type (TREE_TYPE (DECL_RESULT (gnu_target
)));
11236 relayout_decl (DECL_RESULT (gnu_target
));
11239 /* The thunk expander requires the return types of thunk and target to be
11240 compatible, which is not fully the case with the CICO mechanism. */
11241 if (TYPE_CI_CO_LIST (TREE_TYPE (gnu_thunk
)))
11243 tree gnu_target_type
= TREE_TYPE (gnu_target
);
11244 gcc_assert (TYPE_CI_CO_LIST (gnu_target_type
));
11245 TYPE_CANONICAL (TREE_TYPE (TREE_TYPE (gnu_thunk
)))
11246 = TYPE_CANONICAL (TREE_TYPE (gnu_target_type
));
11249 cgraph_node
*target_node
= cgraph_node::get_create (gnu_target
);
11251 /* If the return type of the target is a controlling type, then we need
11252 both an usual this thunk and a covariant thunk in this order:
11254 this thunk --> covariant thunk --> target
11256 For covariant thunks, we can only handle a fixed offset. */
11257 if (Has_Controlling_Result (gnat_target
))
11259 gcc_assert (fixed_offset
< 0);
11260 tree gnu_cv_thunk
= make_covariant_thunk (gnat_thunk
, gnu_thunk
);
11261 target_node
->create_thunk (gnu_cv_thunk
, gnu_target
, false,
11262 - fixed_offset
, 0, 0,
11263 NULL_TREE
, gnu_target
);
11265 gnu_target
= gnu_cv_thunk
;
11268 /* We may also need to create an alias for the target in order to make
11269 the call local, depending on the linkage of the target. */
11270 tree gnu_alias
= use_alias_for_thunk_p (gnu_target
)
11271 ? make_alias_for_thunk (gnu_target
)
11274 target_node
->create_thunk (gnu_thunk
, gnu_target
, true,
11275 fixed_offset
, virtual_value
, indirect_offset
,
11276 virtual_offset
, gnu_alias
);
11281 /* Initialize the table that maps GNAT codes to GCC codes for simple
11282 binary and unary operations. */
11285 init_code_table (void)
11287 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
11288 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
11289 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
11290 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
11291 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
11292 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
11293 gnu_codes
[N_Op_Le
] = LE_EXPR
;
11294 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
11295 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
11296 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
11297 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
11298 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
11299 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
11300 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
11301 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
11302 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
11303 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
11304 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
11305 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
11306 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
11307 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
11308 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
11309 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
11310 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
11313 #include "gt-ada-trans.h"