1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2020, 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"
53 #include "tree-nested.h"
56 #include "adadecode.h"
72 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
73 for fear of running out of stack space. If we need more, we use xmalloc
75 #define ALLOCA_THRESHOLD 1000
77 /* Pointers to front-end tables accessed through macros. */
78 struct Node
*Nodes_Ptr
;
79 struct Flags
*Flags_Ptr
;
80 Node_Id
*Next_Node_Ptr
;
81 Node_Id
*Prev_Node_Ptr
;
82 struct Elist_Header
*Elists_Ptr
;
83 struct Elmt_Item
*Elmts_Ptr
;
84 struct String_Entry
*Strings_Ptr
;
85 Char_Code
*String_Chars_Ptr
;
86 struct List_Header
*List_Headers_Ptr
;
88 /* Highest number in the front-end node table. */
91 /* True when gigi is being called on an analyzed but unexpanded
92 tree, and the only purpose of the call is to properly annotate
93 types with representation information. */
94 bool type_annotate_only
;
96 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
97 static vec
<Node_Id
> gnat_validate_uc_list
;
99 /* List of expressions of pragma Compile_Time_{Error|Warning} in the unit. */
100 static vec
<Node_Id
> gnat_compile_time_expr_list
;
102 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
103 of unconstrained array IN parameters to avoid emitting a great deal of
104 redundant instructions to recompute them each time. */
105 struct GTY (()) parm_attr_d
{
106 int id
; /* GTY doesn't like Entity_Id. */
113 typedef struct parm_attr_d
*parm_attr
;
116 struct GTY(()) language_function
{
117 vec
<parm_attr
, va_gc
> *parm_attr_cache
;
118 bitmap named_ret_val
;
119 vec
<tree
, va_gc
> *other_ret_val
;
123 #define f_parm_attr_cache \
124 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
126 #define f_named_ret_val \
127 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
129 #define f_other_ret_val \
130 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
133 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
135 /* A structure used to gather together information about a statement group.
136 We use this to gather related statements, for example the "then" part
137 of a IF. In the case where it represents a lexical scope, we may also
138 have a BLOCK node corresponding to it and/or cleanups. */
140 struct GTY((chain_next ("%h.previous"))) stmt_group
{
141 struct stmt_group
*previous
; /* Previous code group. */
142 tree stmt_list
; /* List of statements for this code group. */
143 tree block
; /* BLOCK for this code group, if any. */
144 tree cleanups
; /* Cleanups for this code group, if any. */
147 static GTY(()) struct stmt_group
*current_stmt_group
;
149 /* List of unused struct stmt_group nodes. */
150 static GTY((deletable
)) struct stmt_group
*stmt_group_free_list
;
152 /* A structure used to record information on elaboration procedures
153 we've made and need to process.
155 ??? gnat_node should be Node_Id, but gengtype gets confused. */
157 struct GTY((chain_next ("%h.next"))) elab_info
{
158 struct elab_info
*next
; /* Pointer to next in chain. */
159 tree elab_proc
; /* Elaboration procedure. */
160 int gnat_node
; /* The N_Compilation_Unit. */
163 static GTY(()) struct elab_info
*elab_info_list
;
165 /* Stack of exception pointer variables. Each entry is the VAR_DECL
166 that stores the address of the raised exception. Nonzero means we
167 are in an exception handler. Not used in the zero-cost case. */
168 static GTY(()) vec
<tree
, va_gc
> *gnu_except_ptr_stack
;
170 /* In ZCX case, current exception pointer. Used to re-raise it. */
171 static GTY(()) tree gnu_incoming_exc_ptr
;
173 /* Stack for storing the current elaboration procedure decl. */
174 static GTY(()) vec
<tree
, va_gc
> *gnu_elab_proc_stack
;
176 /* Stack of labels to be used as a goto target instead of a return in
177 some functions. See processing for N_Subprogram_Body. */
178 static GTY(()) vec
<tree
, va_gc
> *gnu_return_label_stack
;
180 /* Stack of variable for the return value of a function with copy-in/copy-out
181 parameters. See processing for N_Subprogram_Body. */
182 static GTY(()) vec
<tree
, va_gc
> *gnu_return_var_stack
;
184 /* Structure used to record information for a range check. */
185 struct GTY(()) range_check_info_d
{
195 typedef struct range_check_info_d
*range_check_info
;
198 /* Structure used to record information for a loop. */
199 struct GTY(()) loop_info_d
{
204 tree omp_loop_clauses
;
205 tree omp_construct_clauses
;
206 enum tree_code omp_code
;
207 vec
<range_check_info
, va_gc
> *checks
;
210 typedef struct loop_info_d
*loop_info
;
213 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
214 static GTY(()) vec
<loop_info
, va_gc
> *gnu_loop_stack
;
216 /* The stacks for N_{Push,Pop}_*_Label. */
217 static vec
<Entity_Id
> gnu_constraint_error_label_stack
;
218 static vec
<Entity_Id
> gnu_storage_error_label_stack
;
219 static vec
<Entity_Id
> gnu_program_error_label_stack
;
221 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
222 static enum tree_code gnu_codes
[Number_Node_Kinds
];
224 static void init_code_table (void);
225 static tree
get_elaboration_procedure (void);
226 static void Compilation_Unit_to_gnu (Node_Id
);
227 static bool empty_stmt_list_p (tree
);
228 static void record_code_position (Node_Id
);
229 static void insert_code_for (Node_Id
);
230 static void add_cleanup (tree
, Node_Id
);
231 static void add_stmt_list (List_Id
);
232 static tree
build_stmt_group (List_Id
, bool);
233 static inline bool stmt_group_may_fallthru (void);
234 static enum gimplify_status
gnat_gimplify_stmt (tree
*);
235 static void elaborate_all_entities (Node_Id
);
236 static void process_freeze_entity (Node_Id
);
237 static void process_decls (List_Id
, List_Id
, Node_Id
, bool, bool);
238 static tree
emit_check (tree
, tree
, int, Node_Id
);
239 static tree
build_unary_op_trapv (enum tree_code
, tree
, tree
, Node_Id
);
240 static tree
build_binary_op_trapv (enum tree_code
, tree
, tree
, tree
, Node_Id
);
241 static tree
convert_with_check (Entity_Id
, tree
, bool, bool, Node_Id
);
242 static bool addressable_p (tree
, tree
);
243 static tree
assoc_to_constructor (Entity_Id
, Node_Id
, tree
);
244 static tree
pos_to_constructor (Node_Id
, tree
);
245 static void validate_unchecked_conversion (Node_Id
);
246 static void set_expr_location_from_node (tree
, Node_Id
, bool = false);
247 static void set_gnu_expr_location_from_node (tree
, Node_Id
);
248 static bool set_end_locus_from_node (tree
, Node_Id
);
249 static int lvalue_required_p (Node_Id
, tree
, bool, bool);
250 static tree
build_raise_check (int, enum exception_info_kind
);
251 static tree
create_init_temporary (const char *, tree
, tree
*, Node_Id
);
252 static bool maybe_make_gnu_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
);
254 /* Hooks for debug info back-ends, only supported and used in a restricted set
255 of configurations. */
256 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED
;
257 static const char *decode_name (const char *) ATTRIBUTE_UNUSED
;
259 /* This makes gigi's file_info_ptr visible in this translation unit,
260 so that Sloc_to_locus can look it up when deciding whether to map
261 decls to instances. */
263 static struct File_Info_Type
*file_map
;
265 /* This is the main program of the back-end. It sets up all the table
266 structures and then generates code. */
269 gigi (Node_Id gnat_root
,
271 int number_name ATTRIBUTE_UNUSED
,
272 struct Node
*nodes_ptr
,
273 struct Flags
*flags_ptr
,
274 Node_Id
*next_node_ptr
,
275 Node_Id
*prev_node_ptr
,
276 struct Elist_Header
*elists_ptr
,
277 struct Elmt_Item
*elmts_ptr
,
278 struct String_Entry
*strings_ptr
,
279 Char_Code
*string_chars_ptr
,
280 struct List_Header
*list_headers_ptr
,
282 struct File_Info_Type
*file_info_ptr
,
283 Entity_Id standard_boolean
,
284 Entity_Id standard_integer
,
285 Entity_Id standard_character
,
286 Entity_Id standard_long_long_float
,
287 Entity_Id standard_exception_type
,
288 Int gigi_operating_mode
)
291 Entity_Id gnat_literal
;
292 tree t
, ftype
, int64_type
;
293 struct elab_info
*info
;
296 max_gnat_nodes
= max_gnat_node
;
298 Nodes_Ptr
= nodes_ptr
;
299 Flags_Ptr
= flags_ptr
;
300 Next_Node_Ptr
= next_node_ptr
;
301 Prev_Node_Ptr
= prev_node_ptr
;
302 Elists_Ptr
= elists_ptr
;
303 Elmts_Ptr
= elmts_ptr
;
304 Strings_Ptr
= strings_ptr
;
305 String_Chars_Ptr
= string_chars_ptr
;
306 List_Headers_Ptr
= list_headers_ptr
;
308 type_annotate_only
= (gigi_operating_mode
== 1);
310 if (Generate_SCO_Instance_Table
!= 0)
312 file_map
= file_info_ptr
;
313 maybe_create_decl_to_instance_map (number_file
);
316 for (i
= 0; i
< number_file
; i
++)
318 /* Use the identifier table to make a permanent copy of the filename as
319 the name table gets reallocated after Gigi returns but before all the
320 debugging information is output. The __gnat_to_canonical_file_spec
321 call translates filenames from pragmas Source_Reference that contain
322 host style syntax not understood by gdb. */
326 (__gnat_to_canonical_file_spec
327 (Get_Name_String (file_info_ptr
[i
].File_Name
))));
329 /* We rely on the order isomorphism between files and line maps. */
330 gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table
) == i
);
332 /* We create the line map for a source file at once, with a fixed number
333 of columns chosen to avoid jumping over the next power of 2. */
334 linemap_add (line_table
, LC_ENTER
, 0, filename
, 1);
335 linemap_line_start (line_table
, file_info_ptr
[i
].Num_Source_Lines
, 252);
336 linemap_position_for_column (line_table
, 252 - 1);
337 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
340 gcc_assert (Nkind (gnat_root
) == N_Compilation_Unit
);
342 /* Declare the name of the compilation unit as the first global
343 name in order to make the middle-end fully deterministic. */
344 t
= create_concat_name (Defining_Entity (Unit (gnat_root
)), NULL
);
345 first_global_object_name
= ggc_strdup (IDENTIFIER_POINTER (t
));
347 /* Initialize ourselves. */
352 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
354 if (type_annotate_only
)
356 TYPE_SIZE (void_type_node
) = bitsize_zero_node
;
357 TYPE_SIZE_UNIT (void_type_node
) = size_zero_node
;
360 /* Enable GNAT stack checking method if needed */
361 if (!Stack_Check_Probes_On_Target
)
362 set_stack_check_libfunc ("_gnat_stack_check");
364 /* Retrieve alignment settings. */
365 double_float_alignment
= get_target_double_float_alignment ();
366 double_scalar_alignment
= get_target_double_scalar_alignment ();
368 /* Record the builtin types. Define `integer' and `character' first so that
369 dbx will output them first. */
370 record_builtin_type ("integer", integer_type_node
, false);
371 record_builtin_type ("character", char_type_node
, false);
372 record_builtin_type ("boolean", boolean_type_node
, false);
373 record_builtin_type ("void", void_type_node
, false);
375 /* Save the type we made for integer as the type for Standard.Integer. */
376 save_gnu_tree (Base_Type (standard_integer
),
377 TYPE_NAME (integer_type_node
),
380 /* Likewise for character as the type for Standard.Character. */
381 finish_character_type (char_type_node
);
382 save_gnu_tree (Base_Type (standard_character
),
383 TYPE_NAME (char_type_node
),
386 /* Likewise for boolean as the type for Standard.Boolean. */
387 save_gnu_tree (Base_Type (standard_boolean
),
388 TYPE_NAME (boolean_type_node
),
390 gnat_literal
= First_Literal (Base_Type (standard_boolean
));
391 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
392 gcc_assert (t
== boolean_false_node
);
393 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
394 boolean_type_node
, t
, true, false, false, false, false,
395 true, false, NULL
, gnat_literal
);
396 save_gnu_tree (gnat_literal
, t
, false);
397 gnat_literal
= Next_Literal (gnat_literal
);
398 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
399 gcc_assert (t
== boolean_true_node
);
400 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
401 boolean_type_node
, t
, true, false, false, false, false,
402 true, false, NULL
, gnat_literal
);
403 save_gnu_tree (gnat_literal
, t
, false);
405 /* Declare the building blocks of function nodes. */
406 void_list_node
= build_tree_list (NULL_TREE
, void_type_node
);
407 void_ftype
= build_function_type_list (void_type_node
, NULL_TREE
);
408 ptr_void_ftype
= build_pointer_type (void_ftype
);
410 /* Now declare run-time functions. */
412 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE
,
413 build_function_type_list (ptr_type_node
, sizetype
,
415 NULL_TREE
, is_default
, true, true, true, false,
417 DECL_IS_MALLOC (malloc_decl
) = 1;
420 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
421 build_function_type_list (void_type_node
,
422 ptr_type_node
, NULL_TREE
),
423 NULL_TREE
, is_default
, true, true, true, false,
427 = create_subprog_decl (get_identifier ("__gnat_realloc"), NULL_TREE
,
428 build_function_type_list (ptr_type_node
,
429 ptr_type_node
, sizetype
,
431 NULL_TREE
, is_default
, true, true, true, false,
434 /* This is used for 64-bit multiplication with overflow checking. */
435 int64_type
= gnat_type_for_size (64, 0);
437 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE
,
438 build_function_type_list (int64_type
, int64_type
,
439 int64_type
, NULL_TREE
),
440 NULL_TREE
, is_default
, true, true, true, false,
443 if (Enable_128bit_Types
)
445 tree int128_type
= gnat_type_for_size (128, 0);
447 = create_subprog_decl (get_identifier ("__gnat_mulv128"), NULL_TREE
,
448 build_function_type_list (int128_type
,
452 NULL_TREE
, is_default
, true, true, true, false,
456 /* Name of the _Parent field in tagged record types. */
457 parent_name_id
= get_identifier (Get_Name_String (Name_uParent
));
459 /* Name of the Exception_Data type defined in System.Standard_Library. */
460 exception_data_name_id
461 = get_identifier ("system__standard_library__exception_data");
463 /* Make the types and functions used for exception processing. */
464 except_type_node
= gnat_to_gnu_type (Base_Type (standard_exception_type
));
467 = build_array_type (gnat_type_for_mode (Pmode
, 0),
468 build_index_type (size_int (5)));
469 record_builtin_type ("JMPBUF_T", jmpbuf_type
, true);
470 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
472 /* Functions to get and set the jumpbuf pointer for the current thread. */
474 = create_subprog_decl
475 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
476 NULL_TREE
, build_function_type_list (jmpbuf_ptr_type
, NULL_TREE
),
477 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
480 = create_subprog_decl
481 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
482 NULL_TREE
, build_function_type_list (void_type_node
, jmpbuf_ptr_type
,
484 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
487 = create_subprog_decl
488 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE
,
489 build_function_type_list (build_pointer_type (except_type_node
),
491 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
493 not_handled_by_others_decl
= get_identifier ("not_handled_by_others");
494 for (t
= TYPE_FIELDS (except_type_node
); t
; t
= DECL_CHAIN (t
))
495 if (DECL_NAME (t
) == not_handled_by_others_decl
)
497 not_handled_by_others_decl
= t
;
500 gcc_assert (DECL_P (not_handled_by_others_decl
));
502 /* setjmp returns an integer and has one operand, which is a pointer to
505 = create_subprog_decl
506 (get_identifier ("__builtin_setjmp"), NULL_TREE
,
507 build_function_type_list (integer_type_node
, jmpbuf_ptr_type
,
509 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
510 set_decl_built_in_function (setjmp_decl
, BUILT_IN_NORMAL
, BUILT_IN_SETJMP
);
512 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
514 update_setjmp_buf_decl
515 = create_subprog_decl
516 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE
,
517 build_function_type_list (void_type_node
, jmpbuf_ptr_type
, NULL_TREE
),
518 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
519 set_decl_built_in_function (update_setjmp_buf_decl
, BUILT_IN_NORMAL
,
520 BUILT_IN_UPDATE_SETJMP_BUF
);
522 /* Indicate that it never returns. */
523 ftype
= build_function_type_list (void_type_node
,
524 build_pointer_type (except_type_node
),
526 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
528 = create_subprog_decl
529 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
, ftype
,
530 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
532 set_exception_parameter_decl
533 = create_subprog_decl
534 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE
,
535 build_function_type_list (void_type_node
, ptr_type_node
, ptr_type_node
,
537 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
539 /* Hooks to call when entering/leaving an exception handler. */
540 ftype
= build_function_type_list (ptr_type_node
,
541 ptr_type_node
, NULL_TREE
);
543 = create_subprog_decl (get_identifier ("__gnat_begin_handler_v1"),
544 NULL_TREE
, ftype
, NULL_TREE
,
545 is_default
, true, true, true, false, false, NULL
,
547 /* __gnat_begin_handler_v1 is not a dummy procedure, but we arrange
548 for it not to throw. */
549 TREE_NOTHROW (begin_handler_decl
) = 1;
551 ftype
= build_function_type_list (ptr_type_node
,
552 ptr_type_node
, ptr_type_node
,
553 ptr_type_node
, NULL_TREE
);
555 = create_subprog_decl (get_identifier ("__gnat_end_handler_v1"), NULL_TREE
,
557 is_default
, true, true, true, false, false, NULL
,
560 ftype
= build_function_type_list (void_type_node
, ptr_type_node
, NULL_TREE
);
561 unhandled_except_decl
562 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
563 NULL_TREE
, ftype
, NULL_TREE
,
564 is_default
, true, true, true, false, false, NULL
,
567 /* Indicate that it never returns. */
568 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
570 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE
,
572 is_default
, true, true, true, false, false, NULL
,
575 /* Dummy objects to materialize "others" and "all others" in the exception
576 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
579 = create_var_decl (get_identifier ("OTHERS"),
580 get_identifier ("__gnat_others_value"),
581 char_type_node
, NULL_TREE
,
582 true, false, true, false, false, true, false,
586 = create_var_decl (get_identifier ("ALL_OTHERS"),
587 get_identifier ("__gnat_all_others_value"),
588 char_type_node
, NULL_TREE
,
589 true, false, true, false, false, true, false,
592 unhandled_others_decl
593 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
594 get_identifier ("__gnat_unhandled_others_value"),
595 char_type_node
, NULL_TREE
,
596 true, false, true, false, false, true, false,
599 /* If in no exception handlers mode, all raise statements are redirected to
600 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
601 this procedure will never be called in this mode. */
602 if (No_Exception_Handlers_Set ())
604 /* Indicate that it never returns. */
605 ftype
= build_function_type_list (void_type_node
,
606 build_pointer_type (char_type_node
),
607 integer_type_node
, NULL_TREE
);
608 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
610 = create_subprog_decl
611 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
, ftype
,
612 NULL_TREE
, is_default
, true, true, true, false, false, NULL
,
614 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
615 gnat_raise_decls
[i
] = decl
;
619 /* Otherwise, make one decl for each exception reason. */
620 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
621 gnat_raise_decls
[i
] = build_raise_check (i
, exception_simple
);
622 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls_ext
); i
++)
623 gnat_raise_decls_ext
[i
]
624 = build_raise_check (i
,
625 i
== CE_Index_Check_Failed
626 || i
== CE_Range_Check_Failed
627 || i
== CE_Invalid_Data
628 ? exception_range
: exception_column
);
631 /* Build the special descriptor type and its null node if needed. */
632 if (TARGET_VTABLE_USES_DESCRIPTORS
)
634 tree null_node
= fold_convert (ptr_void_ftype
, null_pointer_node
);
635 tree field_list
= NULL_TREE
;
637 vec
<constructor_elt
, va_gc
> *null_vec
= NULL
;
638 constructor_elt
*elt
;
640 fdesc_type_node
= make_node (RECORD_TYPE
);
641 vec_safe_grow (null_vec
, TARGET_VTABLE_USES_DESCRIPTORS
, true);
642 elt
= (null_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
644 for (j
= 0; j
< TARGET_VTABLE_USES_DESCRIPTORS
; j
++)
647 = create_field_decl (NULL_TREE
, ptr_void_ftype
, fdesc_type_node
,
648 NULL_TREE
, NULL_TREE
, 0, 1);
649 DECL_CHAIN (field
) = field_list
;
652 elt
->value
= null_node
;
656 finish_record_type (fdesc_type_node
, nreverse (field_list
), 0, false);
657 record_builtin_type ("descriptor", fdesc_type_node
, true);
658 null_fdesc_node
= gnat_build_constructor (fdesc_type_node
, null_vec
);
661 longest_float_type_node
662 = get_unpadded_type (Base_Type (standard_long_long_float
));
664 main_identifier_node
= get_identifier ("main");
666 /* If we are using the GCC exception mechanism, let GCC know. */
667 if (Back_End_Exceptions ())
670 /* Initialize the GCC support for FP operations. */
673 /* Install the builtins we might need, either internally or as user-available
674 facilities for Intrinsic imports. Note that this must be done after the
675 GCC exception mechanism is initialized. */
676 gnat_install_builtins ();
678 vec_safe_push (gnu_except_ptr_stack
, NULL_TREE
);
680 gnu_constraint_error_label_stack
.safe_push (Empty
);
681 gnu_storage_error_label_stack
.safe_push (Empty
);
682 gnu_program_error_label_stack
.safe_push (Empty
);
684 /* Process any Pragma Ident for the main unit. */
685 if (Present (Ident_String (Main_Unit
)))
686 targetm
.asm_out
.output_ident
687 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
689 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
690 if (No_Strict_Aliasing_CP
)
691 flag_strict_aliasing
= 0;
693 /* Save the current optimization options again after the above possible
694 global_options changes. */
695 optimization_default_node
696 = build_optimization_node (&global_options
, &global_options_set
);
697 optimization_current_node
= optimization_default_node
;
699 /* Now translate the compilation unit proper. */
700 Compilation_Unit_to_gnu (gnat_root
);
702 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
703 the very end to avoid having to second-guess the front-end when we run
704 into dummy nodes during the regular processing. */
705 for (i
= 0; gnat_validate_uc_list
.iterate (i
, &gnat_iter
); i
++)
706 validate_unchecked_conversion (gnat_iter
);
707 gnat_validate_uc_list
.release ();
709 /* Finally see if we have any elaboration procedures to deal with. */
710 for (info
= elab_info_list
; info
; info
= info
->next
)
712 tree gnu_body
= DECL_SAVED_TREE (info
->elab_proc
);
714 /* We should have a BIND_EXPR but it may not have any statements in it.
715 If it doesn't have any, we have nothing to do except for setting the
716 flag on the GNAT node. Otherwise, process the function as others. */
717 tree gnu_stmts
= gnu_body
;
718 if (TREE_CODE (gnu_stmts
) == BIND_EXPR
)
719 gnu_stmts
= BIND_EXPR_BODY (gnu_stmts
);
720 if (!gnu_stmts
|| empty_stmt_list_p (gnu_stmts
))
721 Set_Has_No_Elaboration_Code (info
->gnat_node
, 1);
724 begin_subprog_body (info
->elab_proc
);
725 end_subprog_body (gnu_body
);
726 rest_of_subprog_body_compilation (info
->elab_proc
);
730 /* Destroy ourselves. */
732 destroy_gnat_decl ();
733 destroy_gnat_utils ();
735 /* We cannot track the location of errors past this point. */
736 Current_Error_Node
= Empty
;
739 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
740 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
743 build_raise_check (int check
, enum exception_info_kind kind
)
746 const char pfx
[] = "__gnat_rcheck_";
748 strcpy (Name_Buffer
, pfx
);
749 Name_Len
= sizeof (pfx
) - 1;
750 Get_RT_Exception_Name (check
);
752 if (kind
== exception_simple
)
754 Name_Buffer
[Name_Len
] = 0;
756 = build_function_type_list (void_type_node
,
757 build_pointer_type (char_type_node
),
758 integer_type_node
, NULL_TREE
);
762 tree t
= (kind
== exception_column
? NULL_TREE
: integer_type_node
);
764 strcpy (Name_Buffer
+ Name_Len
, "_ext");
765 Name_Buffer
[Name_Len
+ 4] = 0;
767 = build_function_type_list (void_type_node
,
768 build_pointer_type (char_type_node
),
769 integer_type_node
, integer_type_node
,
773 /* Indicate that it never returns. */
774 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
776 = create_subprog_decl (get_identifier (Name_Buffer
), NULL_TREE
, ftype
,
777 NULL_TREE
, is_default
, true, true, true, false,
783 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
784 an N_Attribute_Reference. */
787 lvalue_required_for_attribute_p (Node_Id gnat_node
)
789 switch (Get_Attribute_Id (Attribute_Name (gnat_node
)))
795 case Attr_Range_Length
:
797 case Attr_Object_Size
:
799 case Attr_Value_Size
:
800 case Attr_Component_Size
:
801 case Attr_Descriptor_Size
:
802 case Attr_Max_Size_In_Storage_Elements
:
805 case Attr_Null_Parameter
:
806 case Attr_Passed_By_Reference
:
807 case Attr_Mechanism_Code
:
814 case Attr_Unchecked_Access
:
815 case Attr_Unrestricted_Access
:
816 case Attr_Code_Address
:
817 case Attr_Pool_Address
:
819 case Attr_Bit_Position
:
825 case Attr_Asm_Output
:
831 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
832 is the type that will be used for GNAT_NODE in the translated GNU tree.
833 CONSTANT indicates whether the underlying object represented by GNAT_NODE
834 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
835 whether its value is the address of another constant. If it isn't, then
836 ADDRESS_OF_CONSTANT is ignored.
838 The function climbs up the GNAT tree starting from the node and returns 1
839 upon encountering a node that effectively requires an lvalue downstream.
840 It returns int instead of bool to facilitate usage in non-purely binary
844 lvalue_required_p (Node_Id gnat_node
, tree gnu_type
, bool constant
,
845 bool address_of_constant
)
847 Node_Id gnat_parent
= Parent (gnat_node
), gnat_temp
;
849 switch (Nkind (gnat_parent
))
854 case N_Attribute_Reference
:
855 return lvalue_required_for_attribute_p (gnat_parent
);
857 case N_Parameter_Association
:
858 case N_Function_Call
:
859 case N_Procedure_Call_Statement
:
860 /* If the parameter is by reference, an lvalue is required. */
862 || must_pass_by_ref (gnu_type
)
863 || default_pass_by_ref (gnu_type
));
865 case N_Indexed_Component
:
866 /* Only the array expression can require an lvalue. */
867 if (Prefix (gnat_parent
) != gnat_node
)
870 /* ??? Consider that referencing an indexed component with a variable
871 index forces the whole aggregate to memory. Note that testing only
872 for literals is conservative, any static expression in the RM sense
873 could probably be accepted with some additional work. */
874 for (gnat_temp
= First (Expressions (gnat_parent
));
876 gnat_temp
= Next (gnat_temp
))
877 if (Nkind (gnat_temp
) != N_Character_Literal
878 && Nkind (gnat_temp
) != N_Integer_Literal
879 && !(Is_Entity_Name (gnat_temp
)
880 && Ekind (Entity (gnat_temp
)) == E_Enumeration_Literal
))
883 /* ... fall through ... */
885 case N_Selected_Component
:
887 /* Only the prefix expression can require an lvalue. */
888 if (Prefix (gnat_parent
) != gnat_node
)
891 return lvalue_required_p (gnat_parent
,
892 get_unpadded_type (Etype (gnat_parent
)),
893 constant
, address_of_constant
);
895 case N_Object_Renaming_Declaration
:
896 /* We need to preserve addresses through a renaming. */
899 case N_Object_Declaration
:
900 /* We cannot use a constructor if this is an atomic object because
901 the actual assignment might end up being done component-wise. */
903 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
904 && Is_Full_Access (Defining_Entity (gnat_parent
)))
905 /* We don't use a constructor if this is a class-wide object
906 because the effective type of the object is the equivalent
907 type of the class-wide subtype and it smashes most of the
908 data into an array of bytes to which we cannot convert. */
909 || Ekind ((Etype (Defining_Entity (gnat_parent
))))
910 == E_Class_Wide_Subtype
);
912 case N_Assignment_Statement
:
913 /* We cannot use a constructor if the LHS is an atomic object because
914 the actual assignment might end up being done component-wise. */
916 || Name (gnat_parent
) == gnat_node
917 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
918 && Is_Entity_Name (Name (gnat_parent
))
919 && Is_Full_Access (Entity (Name (gnat_parent
)))));
921 case N_Unchecked_Type_Conversion
:
925 /* ... fall through ... */
927 case N_Type_Conversion
:
928 case N_Qualified_Expression
:
929 /* We must look through all conversions because we may need to bypass
930 an intermediate conversion that is meant to be purely formal. */
931 return lvalue_required_p (gnat_parent
,
932 get_unpadded_type (Etype (gnat_parent
)),
933 constant
, address_of_constant
);
935 case N_Explicit_Dereference
:
936 /* We look through dereferences for address of constant because we need
937 to handle the special cases listed above. */
938 if (constant
&& address_of_constant
)
939 return lvalue_required_p (gnat_parent
,
940 get_unpadded_type (Etype (gnat_parent
)),
943 /* ... fall through ... */
952 /* Return true if an lvalue should be used for GNAT_NODE. GNU_TYPE is the type
953 that will be used for GNAT_NODE in the translated GNU tree and is assumed to
954 be an aggregate type.
956 The function climbs up the GNAT tree starting from the node and returns true
957 upon encountering a node that makes it doable to decide. lvalue_required_p
958 should have been previously invoked on the arguments and returned false. */
961 lvalue_for_aggregate_p (Node_Id gnat_node
, tree gnu_type
)
963 Node_Id gnat_parent
= Parent (gnat_node
);
965 switch (Nkind (gnat_parent
))
967 case N_Parameter_Association
:
968 case N_Function_Call
:
969 case N_Procedure_Call_Statement
:
970 /* Even if the parameter is by copy, prefer an lvalue. */
973 case N_Simple_Return_Statement
:
974 /* Likewise for a return value. */
977 case N_Indexed_Component
:
978 case N_Selected_Component
:
979 /* If an elementary component is used, take it from the constant. */
980 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_parent
))))
983 /* ... fall through ... */
986 return lvalue_for_aggregate_p (gnat_parent
,
987 get_unpadded_type (Etype (gnat_parent
)));
989 case N_Object_Declaration
:
990 /* For an aggregate object declaration, return false consistently. */
993 case N_Assignment_Statement
:
994 /* For an aggregate assignment, decide based on the size. */
996 const HOST_WIDE_INT size
= int_size_in_bytes (gnu_type
);
997 return size
< 0 || size
>= param_large_stack_frame
/ 4;
1000 case N_Unchecked_Type_Conversion
:
1001 case N_Type_Conversion
:
1002 case N_Qualified_Expression
:
1003 return lvalue_for_aggregate_p (gnat_parent
,
1004 get_unpadded_type (Etype (gnat_parent
)));
1007 /* We should only reach here through the N_Qualified_Expression case.
1008 Force an lvalue for aggregate types since a block-copy to the newly
1009 allocated area of memory is made. */
1020 /* Return true if T is a constant DECL node that can be safely replaced
1021 by its initializer. */
1024 constant_decl_with_initializer_p (tree t
)
1026 if (!TREE_CONSTANT (t
) || !DECL_P (t
) || !DECL_INITIAL (t
))
1029 /* Return false for aggregate types that contain a placeholder since
1030 their initializers cannot be manipulated easily. */
1031 if (AGGREGATE_TYPE_P (TREE_TYPE (t
))
1032 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t
))
1033 && type_contains_placeholder_p (TREE_TYPE (t
)))
1039 /* Return an expression equivalent to EXP but where constant DECL nodes
1040 have been replaced by their initializer. */
1043 fold_constant_decl_in_expr (tree exp
)
1045 enum tree_code code
= TREE_CODE (exp
);
1052 if (!constant_decl_with_initializer_p (exp
))
1055 return DECL_INITIAL (exp
);
1058 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1059 if (op0
== TREE_OPERAND (exp
, 0))
1062 return fold_build3 (COMPONENT_REF
, TREE_TYPE (exp
), op0
,
1063 TREE_OPERAND (exp
, 1), NULL_TREE
);
1066 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1067 if (op0
== TREE_OPERAND (exp
, 0))
1070 return fold_build3 (BIT_FIELD_REF
, TREE_TYPE (exp
), op0
,
1071 TREE_OPERAND (exp
, 1), TREE_OPERAND (exp
, 2));
1074 case ARRAY_RANGE_REF
:
1075 /* If the index is not itself constant, then nothing can be folded. */
1076 if (!TREE_CONSTANT (TREE_OPERAND (exp
, 1)))
1078 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1079 if (op0
== TREE_OPERAND (exp
, 0))
1082 return fold (build4 (code
, TREE_TYPE (exp
), op0
, TREE_OPERAND (exp
, 1),
1083 TREE_OPERAND (exp
, 2), NULL_TREE
));
1087 case VIEW_CONVERT_EXPR
:
1088 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1089 if (op0
== TREE_OPERAND (exp
, 0))
1092 return fold_build1 (code
, TREE_TYPE (exp
), op0
);
1101 /* Return true if TYPE and DEF_TYPE are compatible GNAT types for Gigi. */
1104 Gigi_Types_Compatible (Entity_Id type
, Entity_Id def_type
)
1106 /* The trivial case. */
1107 if (type
== def_type
)
1110 /* A class-wide type is equivalent to a subtype of itself. */
1111 if (Is_Class_Wide_Type (type
))
1114 /* A packed array type is compatible with its implementation type. */
1115 if (Is_Packed (def_type
) && type
== Packed_Array_Impl_Type (def_type
))
1118 /* If both types are Itypes, one may be a copy of the other. */
1119 if (Is_Itype (def_type
) && Is_Itype (type
))
1122 /* If the type is incomplete and comes from a limited context, then also
1123 consider its non-limited view. */
1124 if (Is_Incomplete_Type (def_type
)
1125 && From_Limited_With (def_type
)
1126 && Present (Non_Limited_View (def_type
)))
1127 return Gigi_Types_Compatible (type
, Non_Limited_View (def_type
));
1129 /* If the type is incomplete/private, then also consider its full view. */
1130 if (Is_Incomplete_Or_Private_Type (def_type
)
1131 && Present (Full_View (def_type
)))
1132 return Gigi_Types_Compatible (type
, Full_View (def_type
));
1137 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
1138 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
1139 to where we should place the result type. */
1142 Identifier_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
1144 /* The entity of GNAT_NODE and its type. */
1145 Node_Id gnat_entity
= (Nkind (gnat_node
) == N_Defining_Identifier
1146 || Nkind (gnat_node
) == N_Defining_Operator_Symbol
)
1147 ? gnat_node
: Entity (gnat_node
);
1148 Node_Id gnat_entity_type
= Etype (gnat_entity
);
1149 /* If GNAT_NODE is a constant, whether we should use the initialization
1150 value instead of the constant entity, typically for scalars with an
1151 address clause when the parent doesn't require an lvalue. */
1152 bool use_constant_initializer
= false;
1153 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1154 specific circumstances only, so evaluated lazily. < 0 means
1155 unknown, > 0 means known true, 0 means known false. */
1156 int require_lvalue
= -1;
1157 Node_Id gnat_result_type
;
1158 tree gnu_result
, gnu_result_type
;
1160 /* If the Etype of this node is not the same as that of the Entity, then
1161 something went wrong, probably in generic instantiation. However, this
1162 does not apply to types. Since we sometime have strange Ekind's, just
1163 do this test for objects, except for discriminants because their type
1164 may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */
1165 gcc_assert (!Is_Object (gnat_entity
)
1166 || Ekind (gnat_entity
) == E_Discriminant
1167 || Etype (gnat_node
) == gnat_entity_type
1168 || Gigi_Types_Compatible (Etype (gnat_node
), gnat_entity_type
));
1170 /* If this is a reference to a deferred constant whose partial view is an
1171 unconstrained private type, the proper type is on the full view of the
1172 constant, not on the full view of the type, which may be unconstrained.
1174 This may be a reference to a type, for example in the prefix of the
1175 attribute Position, generated for dispatching code (see Make_DT in
1176 exp_disp,adb). In that case we need the type itself, not is parent,
1177 in particular if it is a derived type */
1178 if (Ekind (gnat_entity
) == E_Constant
1179 && Is_Private_Type (gnat_entity_type
)
1180 && (Has_Unknown_Discriminants (gnat_entity_type
)
1181 || (Present (Full_View (gnat_entity_type
))
1182 && Has_Discriminants (Full_View (gnat_entity_type
))))
1183 && Present (Full_View (gnat_entity
)))
1185 gnat_entity
= Full_View (gnat_entity
);
1186 gnat_result_type
= Etype (gnat_entity
);
1190 /* We use the Actual_Subtype only if it has already been elaborated,
1191 as we may be invoked precisely during its elaboration, otherwise
1192 the Etype. Avoid using it for packed arrays to simplify things,
1193 except in a return statement because we need the actual size and
1194 the front-end does not make it explicit in this case. */
1195 if ((Ekind (gnat_entity
) == E_Constant
1196 || Ekind (gnat_entity
) == E_Variable
1197 || Is_Formal (gnat_entity
))
1198 && !(Is_Array_Type (Etype (gnat_entity
))
1199 && Present (Packed_Array_Impl_Type (Etype (gnat_entity
)))
1200 && Nkind (Parent (gnat_node
)) != N_Simple_Return_Statement
)
1201 && Present (Actual_Subtype (gnat_entity
))
1202 && present_gnu_tree (Actual_Subtype (gnat_entity
)))
1203 gnat_result_type
= Actual_Subtype (gnat_entity
);
1205 gnat_result_type
= Etype (gnat_node
);
1208 /* Expand the type of this identifier first, in case it is an enumeral
1209 literal, which only get made when the type is expanded. There is no
1210 order-of-elaboration issue here. */
1211 gnu_result_type
= get_unpadded_type (gnat_result_type
);
1213 /* If this is a non-imported elementary constant with an address clause,
1214 retrieve the value instead of a pointer to be dereferenced unless
1215 an lvalue is required. This is generally more efficient and actually
1216 required if this is a static expression because it might be used
1217 in a context where a dereference is inappropriate, such as a case
1218 statement alternative or a record discriminant. There is no possible
1219 volatile-ness short-circuit here since Volatile constants must be
1220 imported per C.6. */
1221 if (Ekind (gnat_entity
) == E_Constant
1222 && Is_Elementary_Type (gnat_result_type
)
1223 && !Is_Imported (gnat_entity
)
1224 && Present (Address_Clause (gnat_entity
)))
1227 = lvalue_required_p (gnat_node
, gnu_result_type
, true, false);
1228 use_constant_initializer
= !require_lvalue
;
1231 if (use_constant_initializer
)
1233 /* If this is a deferred constant, the initializer is attached to
1235 if (Present (Full_View (gnat_entity
)))
1236 gnat_entity
= Full_View (gnat_entity
);
1238 gnu_result
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
1241 gnu_result
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
1243 /* Some objects (such as parameters passed by reference, globals of
1244 variable size, and renamed objects) actually represent the address
1245 of the object. In that case, we must do the dereference. Likewise,
1246 deal with parameters to foreign convention subprograms. */
1247 if (DECL_P (gnu_result
)
1248 && (DECL_BY_REF_P (gnu_result
)
1249 || (TREE_CODE (gnu_result
) == PARM_DECL
1250 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
1252 const bool read_only
= DECL_POINTS_TO_READONLY_P (gnu_result
);
1254 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1255 if (TREE_CODE (gnu_result
) == PARM_DECL
1256 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
1258 = convert (build_pointer_type (gnu_result_type
), gnu_result
);
1260 /* If it's a CONST_DECL, return the underlying constant like below. */
1261 else if (TREE_CODE (gnu_result
) == CONST_DECL
1262 && !(DECL_CONST_ADDRESS_P (gnu_result
)
1263 && lvalue_required_p (gnat_node
, gnu_result_type
, true,
1265 gnu_result
= DECL_INITIAL (gnu_result
);
1267 /* Do the final dereference. */
1268 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
1270 if ((TREE_CODE (gnu_result
) == INDIRECT_REF
1271 || TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
1272 && No (Address_Clause (gnat_entity
)))
1273 TREE_THIS_NOTRAP (gnu_result
) = 1;
1276 TREE_READONLY (gnu_result
) = 1;
1279 /* If we have a constant declaration and its initializer, try to return the
1280 latter to avoid the need to call fold in lots of places and the need for
1281 elaboration code if this identifier is used as an initializer itself. */
1282 if (constant_decl_with_initializer_p (gnu_result
))
1284 bool constant_only
= (TREE_CODE (gnu_result
) == CONST_DECL
1285 && !DECL_CONST_CORRESPONDING_VAR (gnu_result
));
1286 bool address_of_constant
= (TREE_CODE (gnu_result
) == CONST_DECL
1287 && DECL_CONST_ADDRESS_P (gnu_result
));
1289 /* If there is a (corresponding) variable or this is the address of a
1290 constant, we only want to return the initializer if an lvalue isn't
1291 required. Evaluate this now if we have not already done so. */
1292 if ((!constant_only
|| address_of_constant
) && require_lvalue
< 0)
1294 = lvalue_required_p (gnat_node
, gnu_result_type
, true,
1295 address_of_constant
)
1296 || (AGGREGATE_TYPE_P (gnu_result_type
)
1297 && lvalue_for_aggregate_p (gnat_node
, gnu_result_type
));
1299 /* Finally retrieve the initializer if this is deemed valid. */
1300 if ((constant_only
&& !address_of_constant
) || !require_lvalue
)
1301 gnu_result
= DECL_INITIAL (gnu_result
);
1304 /* But for a constant renaming we couldn't do that incrementally for its
1305 definition because of the need to return an lvalue so, if the present
1306 context doesn't itself require an lvalue, we try again here. */
1307 else if (Ekind (gnat_entity
) == E_Constant
1308 && Is_Elementary_Type (gnat_result_type
)
1309 && Present (Renamed_Object (gnat_entity
)))
1311 if (require_lvalue
< 0)
1313 = lvalue_required_p (gnat_node
, gnu_result_type
, true, false);
1314 if (!require_lvalue
)
1315 gnu_result
= fold_constant_decl_in_expr (gnu_result
);
1318 /* The GNAT tree has the type of a function set to its result type, so we
1319 adjust here. Also use the type of the result if the Etype is a subtype
1320 that is nominally unconstrained. Likewise if this is a deferred constant
1321 of a discriminated type whose full view can be elaborated statically, to
1322 avoid problematic conversions to the nominal subtype. But remove any
1323 padding from the resulting type. */
1324 if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_result
))
1325 || Is_Constr_Subt_For_UN_Aliased (gnat_result_type
)
1326 || (Ekind (gnat_entity
) == E_Constant
1327 && Present (Full_View (gnat_entity
))
1328 && Has_Discriminants (gnat_result_type
)
1329 && TREE_CODE (gnu_result
) == CONSTRUCTOR
))
1331 gnu_result_type
= TREE_TYPE (gnu_result
);
1332 if (TYPE_IS_PADDING_P (gnu_result_type
))
1333 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
1336 *gnu_result_type_p
= gnu_result_type
;
1341 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1342 any statements we generate. */
1345 Pragma_to_gnu (Node_Id gnat_node
)
1347 tree gnu_result
= alloc_stmt_list ();
1350 /* Check for (and ignore) unrecognized pragmas. */
1351 if (!Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node
))))
1354 const unsigned char id
1355 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)));
1357 /* Save the expression of pragma Compile_Time_{Error|Warning} for later. */
1358 if (id
== Pragma_Compile_Time_Error
|| id
== Pragma_Compile_Time_Warning
)
1360 gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1361 gnat_compile_time_expr_list
.safe_push (Expression (gnat_temp
));
1365 /* Stop there if we are just annotating types. */
1366 if (type_annotate_only
)
1371 case Pragma_Inspection_Point
:
1372 /* Do nothing at top level: all such variables are already viewable. */
1373 if (global_bindings_p ())
1376 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1377 Present (gnat_temp
);
1378 gnat_temp
= Next (gnat_temp
))
1380 Node_Id gnat_expr
= Expression (gnat_temp
);
1381 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1382 tree asm_constraint
= NULL_TREE
;
1383 #ifdef ASM_COMMENT_START
1386 gnu_expr
= maybe_unconstrained_array (gnu_expr
);
1387 gnat_mark_addressable (gnu_expr
);
1389 #ifdef ASM_COMMENT_START
1390 comment
= concat (ASM_COMMENT_START
,
1391 " inspection point: ",
1392 Get_Name_String (Chars (gnat_expr
)),
1395 asm_constraint
= build_string (strlen (comment
), comment
);
1398 gnu_expr
= build5 (ASM_EXPR
, void_type_node
,
1402 (build_tree_list (NULL_TREE
,
1403 build_string (1, "m")),
1404 gnu_expr
, NULL_TREE
),
1405 NULL_TREE
, NULL_TREE
);
1406 ASM_VOLATILE_P (gnu_expr
) = 1;
1407 set_expr_location_from_node (gnu_expr
, gnat_node
);
1408 append_to_statement_list (gnu_expr
, &gnu_result
);
1412 case Pragma_Loop_Optimize
:
1413 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1414 Present (gnat_temp
);
1415 gnat_temp
= Next (gnat_temp
))
1417 tree gnu_loop_stmt
= gnu_loop_stack
->last ()->stmt
;
1419 switch (Chars (Expression (gnat_temp
)))
1422 LOOP_STMT_IVDEP (gnu_loop_stmt
) = 1;
1425 case Name_No_Unroll
:
1426 LOOP_STMT_NO_UNROLL (gnu_loop_stmt
) = 1;
1430 LOOP_STMT_UNROLL (gnu_loop_stmt
) = 1;
1433 case Name_No_Vector
:
1434 LOOP_STMT_NO_VECTOR (gnu_loop_stmt
) = 1;
1438 LOOP_STMT_VECTOR (gnu_loop_stmt
) = 1;
1447 case Pragma_Optimize
:
1448 switch (Chars (Expression
1449 (First (Pragma_Argument_Associations (gnat_node
)))))
1453 post_error ("must specify -O0?", gnat_node
);
1458 post_error ("must specify -Os?", gnat_node
);
1463 post_error ("insufficient -O value?", gnat_node
);
1471 case Pragma_Reviewable
:
1472 if (write_symbols
== NO_DEBUG
)
1473 post_error ("must specify -g?", gnat_node
);
1476 case Pragma_Warning_As_Error
:
1477 case Pragma_Warnings
:
1480 /* Preserve the location of the pragma. */
1481 const location_t location
= input_location
;
1482 struct cl_option_handlers handlers
;
1483 unsigned int option_index
;
1487 gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1489 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1490 if (Nkind (Expression (gnat_temp
)) == N_String_Literal
)
1494 case Pragma_Warning_As_Error
:
1499 case Pragma_Warnings
:
1508 gnat_expr
= Expression (gnat_temp
);
1511 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1512 else if (Nkind (Expression (gnat_temp
)) == N_Identifier
)
1514 switch (Chars (Expression (gnat_temp
)))
1528 /* Deal with optional pattern (but ignore Reason => "..."). */
1529 if (Present (Next (gnat_temp
))
1530 && Chars (Next (gnat_temp
)) != Name_Reason
)
1532 /* pragma Warnings (On | Off, Name) is handled differently. */
1533 if (Nkind (Expression (Next (gnat_temp
))) != N_String_Literal
)
1536 gnat_expr
= Expression (Next (gnat_temp
));
1542 /* For pragma Warnings (Off), we save the current state... */
1543 if (kind
== DK_IGNORED
)
1544 diagnostic_push_diagnostics (global_dc
, location
);
1546 /* ...so that, for pragma Warnings (On), we do not enable all
1547 the warnings but just restore the previous state. */
1550 diagnostic_pop_diagnostics (global_dc
, location
);
1561 /* This is the same implementation as in the C family of compilers. */
1562 const unsigned int lang_mask
= CL_Ada
| CL_COMMON
;
1563 const char *arg
= NULL
;
1564 if (Present (gnat_expr
))
1566 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1567 const char *option_string
= TREE_STRING_POINTER (gnu_expr
);
1568 const int len
= TREE_STRING_LENGTH (gnu_expr
);
1569 if (len
< 3 || option_string
[0] != '-' || option_string
[1] != 'W')
1571 option_index
= find_opt (option_string
+ 1, lang_mask
);
1572 if (option_index
== OPT_SPECIAL_unknown
)
1574 post_error ("?unknown -W switch", gnat_node
);
1577 else if (!(cl_options
[option_index
].flags
& CL_WARNING
))
1579 post_error ("?-W switch does not control warning", gnat_node
);
1582 else if (!(cl_options
[option_index
].flags
& lang_mask
))
1584 post_error ("?-W switch not valid for Ada", gnat_node
);
1587 if (cl_options
[option_index
].flags
& CL_JOINED
)
1588 arg
= option_string
+ 1 + cl_options
[option_index
].opt_len
;
1593 set_default_handlers (&handlers
, NULL
);
1594 control_warning_option (option_index
, (int) kind
, arg
, imply
, location
,
1595 lang_mask
, &handlers
, &global_options
,
1596 &global_options_set
, global_dc
);
1607 /* Check the inline status of nested function FNDECL wrt its parent function.
1609 If a non-inline nested function is referenced from an inline external
1610 function, we cannot honor both requests at the same time without cloning
1611 the nested function in the current unit since it is private to its unit.
1612 We could inline it as well but it's probably better to err on the side
1613 of too little inlining.
1615 This must be done only on nested functions present in the source code
1616 and not on nested functions generated by the compiler, e.g. finalizers,
1617 because they may be not marked inline and we don't want them to block
1618 the inlining of the parent function. */
1621 check_inlining_for_nested_subprog (tree fndecl
)
1623 if (DECL_IGNORED_P (current_function_decl
) || DECL_IGNORED_P (fndecl
))
1626 if (DECL_DECLARED_INLINE_P (fndecl
))
1629 tree parent_decl
= decl_function_context (fndecl
);
1630 if (DECL_EXTERNAL (parent_decl
) && DECL_DECLARED_INLINE_P (parent_decl
))
1632 const location_t loc1
= DECL_SOURCE_LOCATION (fndecl
);
1633 const location_t loc2
= DECL_SOURCE_LOCATION (parent_decl
);
1635 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl
)))
1637 error_at (loc1
, "subprogram %q+F not marked %<Inline_Always%>",
1639 error_at (loc2
, "parent subprogram cannot be inlined");
1643 warning_at (loc1
, OPT_Winline
, "subprogram %q+F not marked %<Inline%>",
1645 warning_at (loc2
, OPT_Winline
, "parent subprogram cannot be inlined");
1648 DECL_DECLARED_INLINE_P (parent_decl
) = 0;
1649 DECL_UNINLINABLE (parent_decl
) = 1;
1653 /* Return an expression for the length of TYPE, an integral type, computed in
1654 RESULT_TYPE, another integral type.
1656 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
1657 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
1658 which would only overflow in much rarer cases, for extremely large arrays
1659 we expect never to encounter in practice. Besides, the former computation
1660 required the use of potentially constraining signed arithmetics while the
1661 latter does not. Note that the comparison must be done in the original
1662 base index type in order to avoid any overflow during the conversion. */
1665 get_type_length (tree type
, tree result_type
)
1667 tree comp_type
= get_base_type (result_type
);
1668 tree base_type
= maybe_character_type (get_base_type (type
));
1669 tree lb
= convert (base_type
, TYPE_MIN_VALUE (type
));
1670 tree hb
= convert (base_type
, TYPE_MAX_VALUE (type
));
1672 = build_binary_op (PLUS_EXPR
, comp_type
,
1673 build_binary_op (MINUS_EXPR
, comp_type
,
1674 convert (comp_type
, hb
),
1675 convert (comp_type
, lb
)),
1676 build_int_cst (comp_type
, 1));
1678 = build_cond_expr (result_type
,
1679 build_binary_op (GE_EXPR
, boolean_type_node
, hb
, lb
),
1680 convert (result_type
, length
),
1681 build_int_cst (result_type
, 0));
1685 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1686 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1687 where we should place the result type. ATTRIBUTE is the attribute ID. */
1690 Attribute_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, int attribute
)
1692 const Node_Id gnat_prefix
= Prefix (gnat_node
);
1693 tree gnu_prefix
= gnat_to_gnu (gnat_prefix
);
1694 tree gnu_type
= TREE_TYPE (gnu_prefix
);
1695 tree gnu_expr
, gnu_result_type
, gnu_result
= error_mark_node
;
1696 bool prefix_unused
= false;
1698 /* If the input is a NULL_EXPR, make a new one. */
1699 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1701 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1702 *gnu_result_type_p
= gnu_result_type
;
1703 return build1 (NULL_EXPR
, gnu_result_type
, TREE_OPERAND (gnu_prefix
, 0));
1710 /* These just add or subtract the constant 1 since representation
1711 clauses for enumeration types are handled in the front-end. */
1712 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1713 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1714 gnu_type
= maybe_character_type (gnu_result_type
);
1715 if (TREE_TYPE (gnu_expr
) != gnu_type
)
1716 gnu_expr
= convert (gnu_type
, gnu_expr
);
1718 = build_binary_op (attribute
== Attr_Pred
? MINUS_EXPR
: PLUS_EXPR
,
1719 gnu_type
, gnu_expr
, build_int_cst (gnu_type
, 1));
1723 case Attr_Unrestricted_Access
:
1724 /* Conversions don't change the address of references but can cause
1725 build_unary_op to miss the references below, so strip them off.
1726 On the contrary, if the address-of operation causes a temporary
1727 to be created, then it must be created with the proper type. */
1728 gnu_expr
= remove_conversions (gnu_prefix
,
1729 !Must_Be_Byte_Aligned (gnat_node
));
1730 if (REFERENCE_CLASS_P (gnu_expr
))
1731 gnu_prefix
= gnu_expr
;
1733 /* If we are taking 'Address of an unconstrained object, this is the
1734 pointer to the underlying array. */
1735 if (attribute
== Attr_Address
)
1736 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1738 /* If we are building a static dispatch table, we have to honor
1739 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1740 with the C++ ABI. We do it in the non-static case as well,
1741 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1742 else if (TARGET_VTABLE_USES_DESCRIPTORS
1743 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
1746 /* Descriptors can only be built here for top-level functions. */
1747 bool build_descriptor
= (global_bindings_p () != 0);
1749 vec
<constructor_elt
, va_gc
> *gnu_vec
= NULL
;
1750 constructor_elt
*elt
;
1752 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1754 /* If we're not going to build the descriptor, we have to retrieve
1755 the one which will be built by the linker (or by the compiler
1756 later if a static chain is requested). */
1757 if (!build_descriptor
)
1759 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_prefix
);
1760 gnu_result
= fold_convert (build_pointer_type (gnu_result_type
),
1762 gnu_result
= build1 (INDIRECT_REF
, gnu_result_type
, gnu_result
);
1765 vec_safe_grow (gnu_vec
, TARGET_VTABLE_USES_DESCRIPTORS
, true);
1766 elt
= (gnu_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
1767 for (gnu_field
= TYPE_FIELDS (gnu_result_type
), i
= 0;
1768 i
< TARGET_VTABLE_USES_DESCRIPTORS
;
1769 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
1771 if (build_descriptor
)
1773 t
= build2 (FDESC_EXPR
, TREE_TYPE (gnu_field
), gnu_prefix
,
1774 build_int_cst (NULL_TREE
, i
));
1775 TREE_CONSTANT (t
) = 1;
1778 t
= build3 (COMPONENT_REF
, ptr_void_ftype
, gnu_result
,
1779 gnu_field
, NULL_TREE
);
1781 elt
->index
= gnu_field
;
1786 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
1790 /* ... fall through ... */
1793 case Attr_Unchecked_Access
:
1794 case Attr_Code_Address
:
1795 /* Taking the address of a type does not make sense. */
1796 gcc_assert (TREE_CODE (gnu_prefix
) != TYPE_DECL
);
1798 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1800 = build_unary_op (((attribute
== Attr_Address
1801 || attribute
== Attr_Unrestricted_Access
)
1802 && !Must_Be_Byte_Aligned (gnat_node
))
1803 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1804 gnu_result_type
, gnu_prefix
);
1806 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1807 don't try to build a trampoline. */
1808 if (attribute
== Attr_Code_Address
)
1810 gnu_expr
= remove_conversions (gnu_result
, false);
1812 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1813 TREE_NO_TRAMPOLINE (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1815 /* On targets for which function symbols denote a descriptor, the
1816 code address is stored within the first slot of the descriptor
1817 so we do an additional dereference:
1818 result = *((result_type *) result)
1819 where we expect result to be of some pointer type already. */
1820 if (targetm
.calls
.custom_function_descriptors
== 0)
1822 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1823 convert (build_pointer_type (gnu_result_type
),
1827 /* For 'Access, issue an error message if the prefix is a C++ method
1828 since it can use a special calling convention on some platforms,
1829 which cannot be propagated to the access type. */
1830 else if (attribute
== Attr_Access
1831 && TREE_CODE (TREE_TYPE (gnu_prefix
)) == METHOD_TYPE
)
1832 post_error ("access to C++ constructor or member function not allowed",
1835 /* For other address attributes applied to a nested function,
1836 find an inner ADDR_EXPR and annotate it so that we can issue
1837 a useful warning with -Wtrampolines. */
1838 else if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_prefix
))
1839 && (gnu_expr
= remove_conversions (gnu_result
, false))
1840 && TREE_CODE (gnu_expr
) == ADDR_EXPR
1841 && decl_function_context (TREE_OPERAND (gnu_expr
, 0)))
1843 set_expr_location_from_node (gnu_expr
, gnat_node
);
1845 /* Also check the inlining status. */
1846 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr
, 0));
1848 /* Moreover, for 'Access or 'Unrestricted_Access with non-
1849 foreign-compatible representation, mark the ADDR_EXPR so
1850 that we can build a descriptor instead of a trampoline. */
1851 if ((attribute
== Attr_Access
1852 || attribute
== Attr_Unrestricted_Access
)
1853 && targetm
.calls
.custom_function_descriptors
> 0
1854 && Can_Use_Internal_Rep (Underlying_Type (Etype (gnat_node
))))
1855 FUNC_ADDR_BY_DESCRIPTOR (gnu_expr
) = 1;
1857 /* Otherwise, we need to check that we are not violating the
1858 No_Implicit_Dynamic_Code restriction. */
1859 else if (targetm
.calls
.custom_function_descriptors
!= 0)
1860 Check_Implicit_Dynamic_Code_Allowed (gnat_node
);
1864 case Attr_Pool_Address
:
1866 tree gnu_ptr
= gnu_prefix
;
1869 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1871 /* If this is fat pointer, the object must have been allocated with the
1872 template in front of the array. So compute the template address; do
1873 it by converting to a thin pointer. */
1874 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
1876 = convert (build_pointer_type
1877 (TYPE_OBJECT_RECORD_TYPE
1878 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
1881 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
1883 /* If this is a thin pointer, the object must have been allocated with
1884 the template in front of the array. So compute the template address
1886 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
1888 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
1890 fold_build1 (NEGATE_EXPR
, sizetype
,
1893 TYPE_FIELDS ((gnu_obj_type
)))));
1895 gnu_result
= convert (gnu_result_type
, gnu_ptr
);
1900 case Attr_Object_Size
:
1901 case Attr_Value_Size
:
1902 case Attr_Max_Size_In_Storage_Elements
:
1903 /* Strip NOPs, conversions between original and packable versions, and
1904 unpadding from GNU_PREFIX. Note that we cannot simply strip every
1905 VIEW_CONVERT_EXPR because some of them may give the actual size, e.g.
1906 for nominally unconstrained packed array. We use GNU_EXPR to see
1907 if a COMPONENT_REF was involved. */
1908 while (CONVERT_EXPR_P (gnu_prefix
)
1909 || TREE_CODE (gnu_prefix
) == NON_LVALUE_EXPR
1910 || (TREE_CODE (gnu_prefix
) == VIEW_CONVERT_EXPR
1911 && TREE_CODE (TREE_TYPE (gnu_prefix
)) == RECORD_TYPE
1912 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1914 && TYPE_NAME (TREE_TYPE (gnu_prefix
))
1915 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1916 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1917 gnu_expr
= gnu_prefix
;
1918 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1919 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
1920 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1921 prefix_unused
= true;
1922 gnu_type
= TREE_TYPE (gnu_prefix
);
1924 /* Replace an unconstrained array type with the type of the underlying
1925 array, except for 'Max_Size_In_Storage_Elements because we need to
1926 return the (maximum) size requested for an allocator. */
1927 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1929 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1930 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1931 gnu_type
= TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
1934 /* The type must be frozen at this point. */
1935 gcc_assert (COMPLETE_TYPE_P (gnu_type
));
1937 /* If we're looking for the size of a field, return the field size. */
1938 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1939 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1941 /* Otherwise, if the prefix is an object, or if we are looking for
1942 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1943 GCC size of the type. We make an exception for padded objects,
1944 as we do not take into account alignment promotions for the size.
1945 This is in keeping with the object case of gnat_to_gnu_entity. */
1946 else if ((TREE_CODE (gnu_prefix
) != TYPE_DECL
1947 && !(TYPE_IS_PADDING_P (gnu_type
)
1948 && TREE_CODE (gnu_expr
) == COMPONENT_REF
1949 && pad_type_has_rm_size (gnu_type
)))
1950 || attribute
== Attr_Object_Size
1951 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1953 /* If this is a dereference and we have a special dynamic constrained
1954 subtype on the prefix, use it to compute the size; otherwise, use
1955 the designated subtype. */
1956 if (Nkind (gnat_prefix
) == N_Explicit_Dereference
)
1958 Node_Id gnat_actual_subtype
1959 = Actual_Designated_Subtype (gnat_prefix
);
1961 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix
)));
1963 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
)
1964 && Present (gnat_actual_subtype
))
1966 tree gnu_actual_obj_type
1967 = gnat_to_gnu_type (gnat_actual_subtype
);
1969 = build_unc_object_type_from_ptr (gnu_ptr_type
,
1970 gnu_actual_obj_type
,
1971 get_identifier ("SIZE"),
1976 gnu_result
= TYPE_SIZE (gnu_type
);
1979 /* Otherwise, the result is the RM size of the type. */
1981 gnu_result
= rm_size (gnu_type
);
1983 /* Deal with a self-referential size by qualifying the size with the
1984 object or returning the maximum size for a type. */
1985 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1986 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
1987 else if (CONTAINS_PLACEHOLDER_P (gnu_result
))
1988 gnu_result
= max_size (gnu_result
, true);
1990 /* If the type contains a template, subtract the padded size of the
1991 template, except for 'Max_Size_In_Storage_Elements because we need
1992 to return the (maximum) size requested for an allocator. */
1993 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1994 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
1995 && attribute
!= Attr_Max_Size_In_Storage_Elements
)
1997 = size_binop (MINUS_EXPR
, gnu_result
,
1998 bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type
))));
2000 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
2001 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
2002 gnu_result
= size_binop (CEIL_DIV_EXPR
, gnu_result
, bitsize_unit_node
);
2004 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2007 case Attr_Alignment
:
2011 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2012 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
2013 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
2015 gnu_type
= TREE_TYPE (gnu_prefix
);
2016 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2017 prefix_unused
= true;
2019 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2020 align
= DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)) / BITS_PER_UNIT
;
2023 Entity_Id gnat_type
= Etype (gnat_prefix
);
2024 unsigned int double_align
;
2025 bool is_capped_double
, align_clause
;
2027 /* If the default alignment of "double" or larger scalar types is
2028 specifically capped and there is an alignment clause neither
2029 on the type nor on the prefix itself, return the cap. */
2030 if ((double_align
= double_float_alignment
) > 0)
2032 = is_double_float_or_array (gnat_type
, &align_clause
);
2033 else if ((double_align
= double_scalar_alignment
) > 0)
2035 = is_double_scalar_or_array (gnat_type
, &align_clause
);
2037 is_capped_double
= align_clause
= false;
2039 if (is_capped_double
2040 && Nkind (gnat_prefix
) == N_Identifier
2041 && Present (Alignment_Clause (Entity (gnat_prefix
))))
2042 align_clause
= true;
2044 if (is_capped_double
&& !align_clause
)
2045 align
= double_align
;
2047 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
2050 gnu_result
= size_int (align
);
2056 case Attr_Range_Length
:
2057 prefix_unused
= true;
2059 if (INTEGRAL_TYPE_P (gnu_type
) || SCALAR_FLOAT_TYPE_P (gnu_type
))
2061 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2063 if (attribute
== Attr_First
)
2064 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
2065 else if (attribute
== Attr_Last
)
2066 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
2068 gnu_result
= get_type_length (gnu_type
, gnu_result_type
);
2072 /* ... fall through ... */
2076 int Dimension
= (Present (Expressions (gnat_node
))
2077 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
2079 struct parm_attr_d
*pa
= NULL
;
2080 Entity_Id gnat_param
= Empty
;
2081 bool unconstrained_ptr_deref
= false;
2083 gnu_prefix
= maybe_padded_object (gnu_prefix
);
2084 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
2086 /* We treat unconstrained array In parameters specially. We also note
2087 whether we are dereferencing a pointer to unconstrained array. */
2088 if (!Is_Constrained (Etype (gnat_prefix
)))
2089 switch (Nkind (gnat_prefix
))
2092 /* This is the direct case. */
2093 if (Ekind (Entity (gnat_prefix
)) == E_In_Parameter
)
2094 gnat_param
= Entity (gnat_prefix
);
2097 case N_Explicit_Dereference
:
2098 /* This is the indirect case. Note that we need to be sure that
2099 the access value cannot be null as we'll hoist the load. */
2100 if (Nkind (Prefix (gnat_prefix
)) == N_Identifier
2101 && Ekind (Entity (Prefix (gnat_prefix
))) == E_In_Parameter
)
2103 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix
))))
2104 gnat_param
= Entity (Prefix (gnat_prefix
));
2107 unconstrained_ptr_deref
= true;
2114 /* If the prefix is the view conversion of a constrained array to an
2115 unconstrained form, we retrieve the constrained array because we
2116 might not be able to substitute the PLACEHOLDER_EXPR coming from
2117 the conversion. This can occur with the 'Old attribute applied
2118 to a parameter with an unconstrained type, which gets rewritten
2119 into a constrained local variable very late in the game. */
2120 if (TREE_CODE (gnu_prefix
) == VIEW_CONVERT_EXPR
2121 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix
)))
2122 && !CONTAINS_PLACEHOLDER_P
2123 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
2124 gnu_type
= TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0));
2126 gnu_type
= TREE_TYPE (gnu_prefix
);
2128 prefix_unused
= true;
2129 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2131 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
2136 for (ndim
= 1, gnu_type_temp
= gnu_type
;
2137 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
2138 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
2139 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
2142 Dimension
= ndim
+ 1 - Dimension
;
2145 for (i
= 1; i
< Dimension
; i
++)
2146 gnu_type
= TREE_TYPE (gnu_type
);
2148 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
2150 /* When not optimizing, look up the slot associated with the parameter
2151 and the dimension in the cache and create a new one on failure.
2152 Don't do this when the actual subtype needs debug info (this happens
2153 with -gnatD): in elaborate_expression_1, we create variables that
2154 hold the bounds, so caching attributes isn't very interesting and
2155 causes dependency issues between these variables and cached
2158 && Present (gnat_param
)
2159 && !(Present (Actual_Subtype (gnat_param
))
2160 && Needs_Debug_Info (Actual_Subtype (gnat_param
))))
2162 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache
, i
, pa
)
2163 if (pa
->id
== gnat_param
&& pa
->dim
== Dimension
)
2168 pa
= ggc_cleared_alloc
<parm_attr_d
> ();
2169 pa
->id
= gnat_param
;
2170 pa
->dim
= Dimension
;
2171 vec_safe_push (f_parm_attr_cache
, pa
);
2175 /* Return the cached expression or build a new one. */
2176 if (attribute
== Attr_First
)
2178 if (pa
&& pa
->first
)
2180 gnu_result
= pa
->first
;
2185 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
2188 else if (attribute
== Attr_Last
)
2192 gnu_result
= pa
->last
;
2197 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
2200 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2202 if (pa
&& pa
->length
)
2204 gnu_result
= pa
->length
;
2209 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)),
2213 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2214 handling. Note that these attributes could not have been used on
2215 an unconstrained array type. */
2216 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
2218 /* Cache the expression we have just computed. Since we want to do it
2219 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2220 create the temporary in the outermost binding level. We will make
2221 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2222 paths by forcing its evaluation on entry of the function. */
2226 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
2230 pa
->first
= gnu_result
;
2234 pa
->last
= gnu_result
;
2238 case Attr_Range_Length
:
2239 pa
->length
= gnu_result
;
2247 /* Otherwise, evaluate it each time it is referenced. */
2253 /* If we are dereferencing a pointer to unconstrained array, we
2254 need to capture the value because the pointed-to bounds may
2255 subsequently be released. */
2256 if (unconstrained_ptr_deref
)
2258 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
2262 case Attr_Range_Length
:
2263 /* Set the source location onto the predicate of the condition
2264 but not if the expression is cached to avoid messing up the
2266 if (TREE_CODE (gnu_result
) == COND_EXPR
2267 && EXPR_P (TREE_OPERAND (gnu_result
, 0)))
2268 set_expr_location_from_node (TREE_OPERAND (gnu_result
, 0),
2279 case Attr_Bit_Position
:
2281 case Attr_First_Bit
:
2288 tree gnu_field_bitpos
;
2289 tree gnu_field_offset
;
2292 int unsignedp
, reversep
, volatilep
;
2294 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2295 gnu_prefix
= remove_conversions (gnu_prefix
, true);
2296 prefix_unused
= true;
2298 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2299 the result is 0. Don't allow 'Bit on a bare component, though. */
2300 if (attribute
== Attr_Bit
2301 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
2302 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
2304 gnu_result
= integer_zero_node
;
2309 gcc_assert (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2310 || (attribute
== Attr_Bit_Position
2311 && TREE_CODE (gnu_prefix
) == FIELD_DECL
));
2313 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
2314 &mode
, &unsignedp
, &reversep
, &volatilep
);
2316 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2318 gnu_field_bitpos
= bit_position (TREE_OPERAND (gnu_prefix
, 1));
2319 gnu_field_offset
= byte_position (TREE_OPERAND (gnu_prefix
, 1));
2321 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
2322 TREE_CODE (gnu_inner
) == COMPONENT_REF
2323 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
2324 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
2327 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
2328 bit_position (TREE_OPERAND (gnu_inner
, 1)));
2330 = size_binop (PLUS_EXPR
, gnu_field_offset
,
2331 byte_position (TREE_OPERAND (gnu_inner
, 1)));
2334 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
2336 gnu_field_bitpos
= bit_position (gnu_prefix
);
2337 gnu_field_offset
= byte_position (gnu_prefix
);
2341 gnu_field_bitpos
= bitsize_zero_node
;
2342 gnu_field_offset
= size_zero_node
;
2348 gnu_result
= gnu_field_offset
;
2351 case Attr_First_Bit
:
2353 gnu_result
= size_int (num_trailing_bits (bitpos
));
2357 gnu_result
= bitsize_int (num_trailing_bits (bitpos
));
2358 gnu_result
= size_binop (PLUS_EXPR
, gnu_result
,
2359 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
2360 /* ??? Avoid a large unsigned result that will overflow when
2361 converted to the signed universal_integer. */
2362 if (integer_zerop (gnu_result
))
2363 gnu_result
= integer_minus_one_node
;
2366 = size_binop (MINUS_EXPR
, gnu_result
, bitsize_one_node
);
2369 case Attr_Bit_Position
:
2370 gnu_result
= gnu_field_bitpos
;
2374 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2376 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
2383 tree gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
2384 tree gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
2386 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2388 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2389 a NaN so we implement the semantics of C99 f{min,max} to make it
2390 predictable in this case: if either operand is a NaN, the other
2391 is returned; if both operands are NaN's, a NaN is returned. */
2392 if (SCALAR_FLOAT_TYPE_P (gnu_result_type
)
2393 && !Machine_Overflows_On_Target
)
2395 const bool lhs_side_effects_p
= TREE_SIDE_EFFECTS (gnu_lhs
);
2396 const bool rhs_side_effects_p
= TREE_SIDE_EFFECTS (gnu_rhs
);
2397 tree t
= builtin_decl_explicit (BUILT_IN_ISNAN
);
2398 tree lhs_is_nan
, rhs_is_nan
;
2400 /* If the operands have side-effects, they need to be evaluated
2401 only once in spite of the multiple references in the result. */
2402 if (lhs_side_effects_p
)
2403 gnu_lhs
= gnat_protect_expr (gnu_lhs
);
2404 if (rhs_side_effects_p
)
2405 gnu_rhs
= gnat_protect_expr (gnu_rhs
);
2407 lhs_is_nan
= fold_build2 (NE_EXPR
, boolean_type_node
,
2408 build_call_expr (t
, 1, gnu_lhs
),
2411 rhs_is_nan
= fold_build2 (NE_EXPR
, boolean_type_node
,
2412 build_call_expr (t
, 1, gnu_rhs
),
2415 gnu_result
= build_binary_op (attribute
== Attr_Min
2416 ? MIN_EXPR
: MAX_EXPR
,
2417 gnu_result_type
, gnu_lhs
, gnu_rhs
);
2418 gnu_result
= fold_build3 (COND_EXPR
, gnu_result_type
,
2419 rhs_is_nan
, gnu_lhs
, gnu_result
);
2420 gnu_result
= fold_build3 (COND_EXPR
, gnu_result_type
,
2421 lhs_is_nan
, gnu_rhs
, gnu_result
);
2423 /* If the operands have side-effects, they need to be evaluated
2424 before doing the tests above since the place they otherwise
2425 would end up being evaluated at run time could be wrong. */
2426 if (lhs_side_effects_p
)
2428 = build2 (COMPOUND_EXPR
, gnu_result_type
, gnu_lhs
, gnu_result
);
2430 if (rhs_side_effects_p
)
2432 = build2 (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs
, gnu_result
);
2435 gnu_result
= build_binary_op (attribute
== Attr_Min
2436 ? MIN_EXPR
: MAX_EXPR
,
2437 gnu_result_type
, gnu_lhs
, gnu_rhs
);
2441 case Attr_Passed_By_Reference
:
2442 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
2443 || must_pass_by_ref (gnu_type
));
2444 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2447 case Attr_Component_Size
:
2448 gnu_prefix
= maybe_padded_object (gnu_prefix
);
2449 gnu_type
= TREE_TYPE (gnu_prefix
);
2451 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
2452 gnu_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
2454 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
2455 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
2456 gnu_type
= TREE_TYPE (gnu_type
);
2458 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
2460 /* Note this size cannot be self-referential. */
2461 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
2462 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2463 prefix_unused
= true;
2466 case Attr_Descriptor_Size
:
2467 gnu_type
= TREE_TYPE (gnu_prefix
);
2468 gcc_assert (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
);
2470 /* Return the padded size of the template in the object record type. */
2471 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
2472 gnu_result
= bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
2473 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2474 prefix_unused
= true;
2477 case Attr_Null_Parameter
:
2478 /* This is just a zero cast to the pointer type for our prefix and
2480 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2482 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
2483 convert (build_pointer_type (gnu_result_type
),
2484 integer_zero_node
));
2487 case Attr_Mechanism_Code
:
2489 Entity_Id gnat_obj
= Entity (gnat_prefix
);
2492 prefix_unused
= true;
2493 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2494 if (Present (Expressions (gnat_node
)))
2496 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
2498 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
2499 i
--, gnat_obj
= Next_Formal (gnat_obj
))
2503 code
= Mechanism (gnat_obj
);
2504 if (code
== Default
)
2505 code
= ((present_gnu_tree (gnat_obj
)
2506 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
2507 || ((TREE_CODE (get_gnu_tree (gnat_obj
))
2509 && (DECL_BY_COMPONENT_PTR_P
2510 (get_gnu_tree (gnat_obj
))))))
2511 ? By_Reference
: By_Copy
);
2512 gnu_result
= convert (gnu_result_type
, size_int (- code
));
2517 /* We treat Model as identical to Machine. This is true for at least
2518 IEEE and some other nice floating-point systems. */
2520 /* ... fall through ... */
2523 /* The trick is to force the compiler to store the result in memory so
2524 that we do not have extra precision used. But do this only when this
2525 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2526 the type is lower than that of the longest floating-point type. */
2527 prefix_unused
= true;
2528 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2529 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2530 gnu_result
= convert (gnu_result_type
, gnu_expr
);
2532 if (TREE_CODE (gnu_result
) != REAL_CST
2533 && fp_arith_may_widen
2534 && TYPE_PRECISION (gnu_result_type
)
2535 < TYPE_PRECISION (longest_float_type_node
))
2537 tree rec_type
= make_node (RECORD_TYPE
);
2539 = create_field_decl (get_identifier ("OBJ"), gnu_result_type
,
2540 rec_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2541 tree rec_val
, asm_expr
;
2543 finish_record_type (rec_type
, field
, 0, false);
2545 rec_val
= build_constructor_single (rec_type
, field
, gnu_result
);
2546 rec_val
= build1 (SAVE_EXPR
, rec_type
, rec_val
);
2549 = build5 (ASM_EXPR
, void_type_node
,
2550 build_string (0, ""),
2551 tree_cons (build_tree_list (NULL_TREE
,
2552 build_string (2, "=m")),
2553 rec_val
, NULL_TREE
),
2554 tree_cons (build_tree_list (NULL_TREE
,
2555 build_string (1, "m")),
2556 rec_val
, NULL_TREE
),
2557 NULL_TREE
, NULL_TREE
);
2558 ASM_VOLATILE_P (asm_expr
) = 1;
2561 = build_compound_expr (gnu_result_type
, asm_expr
,
2562 build_component_ref (rec_val
, field
,
2568 prefix_unused
= true;
2569 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2570 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2571 /* This can be a random address so build an alias-all pointer type. */
2573 = convert (build_pointer_type_for_mode (gnu_result_type
, ptr_mode
,
2576 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_expr
);
2580 /* This abort means that we have an unimplemented attribute. */
2584 /* If this is an attribute where the prefix was unused, force a use of it if
2585 it has a side-effect. But don't do it if the prefix is just an entity
2586 name. However, if an access check is needed, we must do it. See second
2587 example in AARM 11.6(5.e). */
2589 && TREE_SIDE_EFFECTS (gnu_prefix
)
2590 && !Is_Entity_Name (gnat_prefix
))
2592 = build_compound_expr (TREE_TYPE (gnu_result
), gnu_prefix
, gnu_result
);
2594 *gnu_result_type_p
= gnu_result_type
;
2598 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2599 to a GCC tree, which is returned. */
2602 Case_Statement_to_gnu (Node_Id gnat_node
)
2604 tree gnu_result
, gnu_expr
, gnu_type
, gnu_label
;
2606 location_t end_locus
;
2607 bool may_fallthru
= false;
2609 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2610 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2611 gnu_expr
= maybe_character_value (gnu_expr
);
2612 gnu_type
= TREE_TYPE (gnu_expr
);
2614 /* We build a SWITCH_EXPR that contains the code with interspersed
2615 CASE_LABEL_EXPRs for each label. */
2616 if (!Sloc_to_locus (End_Location (gnat_node
), &end_locus
))
2617 end_locus
= input_location
;
2618 gnu_label
= create_artificial_label (end_locus
);
2619 start_stmt_group ();
2621 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2622 Present (gnat_when
);
2623 gnat_when
= Next_Non_Pragma (gnat_when
))
2625 bool choices_added_p
= false;
2626 Node_Id gnat_choice
;
2628 /* First compile all the different case choices for the current WHEN
2630 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2631 Present (gnat_choice
);
2632 gnat_choice
= Next (gnat_choice
))
2634 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2635 tree label
= create_artificial_label (input_location
);
2637 switch (Nkind (gnat_choice
))
2640 gnu_low
= gnat_to_gnu (Low_Bound (gnat_choice
));
2641 gnu_high
= gnat_to_gnu (High_Bound (gnat_choice
));
2644 case N_Subtype_Indication
:
2645 gnu_low
= gnat_to_gnu (Low_Bound (Range_Expression
2646 (Constraint (gnat_choice
))));
2647 gnu_high
= gnat_to_gnu (High_Bound (Range_Expression
2648 (Constraint (gnat_choice
))));
2652 case N_Expanded_Name
:
2653 /* This represents either a subtype range or a static value of
2654 some kind; Ekind says which. */
2655 if (Is_Type (Entity (gnat_choice
)))
2657 tree gnu_type
= get_unpadded_type (Entity (gnat_choice
));
2659 gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2660 gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2664 /* ... fall through ... */
2666 case N_Character_Literal
:
2667 case N_Integer_Literal
:
2668 gnu_low
= gnat_to_gnu (gnat_choice
);
2671 case N_Others_Choice
:
2678 /* Everything should be folded into constants at this point. */
2679 gcc_assert (!gnu_low
|| TREE_CODE (gnu_low
) == INTEGER_CST
);
2680 gcc_assert (!gnu_high
|| TREE_CODE (gnu_high
) == INTEGER_CST
);
2682 if (gnu_low
&& TREE_TYPE (gnu_low
) != gnu_type
)
2683 gnu_low
= convert (gnu_type
, gnu_low
);
2684 if (gnu_high
&& TREE_TYPE (gnu_high
) != gnu_type
)
2685 gnu_high
= convert (gnu_type
, gnu_high
);
2687 add_stmt_with_node (build_case_label (gnu_low
, gnu_high
, label
),
2689 choices_added_p
= true;
2692 /* This construct doesn't define a scope so we shouldn't push a binding
2693 level around the statement list. Except that we have always done so
2694 historically and this makes it possible to reduce stack usage. As a
2695 compromise, we keep doing it for case statements, for which this has
2696 never been problematic, but not for case expressions in Ada 2012. */
2697 if (choices_added_p
)
2699 const bool is_case_expression
2700 = (Nkind (Parent (gnat_node
)) == N_Expression_With_Actions
);
2702 = build_stmt_group (Statements (gnat_when
), !is_case_expression
);
2703 bool group_may_fallthru
= block_may_fallthru (group
);
2705 if (group_may_fallthru
)
2707 tree stmt
= build1 (GOTO_EXPR
, void_type_node
, gnu_label
);
2708 SET_EXPR_LOCATION (stmt
, end_locus
);
2710 may_fallthru
= true;
2715 /* Now emit a definition of the label the cases branch to, if any. */
2717 add_stmt (build1 (LABEL_EXPR
, void_type_node
, gnu_label
));
2718 gnu_result
= build2 (SWITCH_EXPR
, gnu_type
, gnu_expr
, end_stmt_group ());
2723 /* Return true if we are in the body of a loop. */
2726 inside_loop_p (void)
2728 return !vec_safe_is_empty (gnu_loop_stack
);
2731 /* Find out whether EXPR is a simple additive expression based on the iteration
2732 variable of some enclosing loop in the current function. If so, return the
2733 loop and set *DISP to the displacement and *NEG_P to true if this is for a
2734 subtraction; otherwise, return NULL. */
2736 static struct loop_info_d
*
2737 find_loop_for (tree expr
, tree
*disp
, bool *neg_p
)
2741 struct loop_info_d
*iter
= NULL
;
2744 if (is_simple_additive_expression (expr
, &add
, &cst
, &minus_p
))
2761 var
= remove_conversions (var
, false);
2763 if (TREE_CODE (var
) != VAR_DECL
)
2766 if (decl_function_context (var
) != current_function_decl
)
2769 gcc_assert (vec_safe_length (gnu_loop_stack
) > 0);
2771 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack
, i
, iter
)
2772 if (var
== iter
->loop_var
)
2778 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2779 false, or the maximum value if MAX is true, of TYPE. */
2782 can_equal_min_or_max_val_p (tree val
, tree type
, bool max
)
2784 tree min_or_max_val
= (max
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
));
2786 if (TREE_CODE (min_or_max_val
) != INTEGER_CST
)
2789 if (TREE_CODE (val
) == NOP_EXPR
)
2791 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0)))
2792 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0))));
2794 if (TREE_CODE (val
) != INTEGER_CST
)
2798 return tree_int_cst_lt (val
, min_or_max_val
) == 0;
2800 return tree_int_cst_lt (min_or_max_val
, val
) == 0;
2803 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2804 If REVERSE is true, minimum value is taken as maximum value. */
2807 can_equal_min_val_p (tree val
, tree type
, bool reverse
)
2809 return can_equal_min_or_max_val_p (val
, type
, reverse
);
2812 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2813 If REVERSE is true, maximum value is taken as minimum value. */
2816 can_equal_max_val_p (tree val
, tree type
, bool reverse
)
2818 return can_equal_min_or_max_val_p (val
, type
, !reverse
);
2821 /* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
2822 true if both expressions have been replaced and false otherwise. */
2825 make_invariant (tree
*expr1
, tree
*expr2
)
2827 tree inv_expr1
= gnat_invariant_expr (*expr1
);
2828 tree inv_expr2
= gnat_invariant_expr (*expr2
);
2836 return inv_expr1
&& inv_expr2
;
2839 /* Helper function for walk_tree, used by independent_iterations_p below. */
2842 scan_rhs_r (tree
*tp
, int *walk_subtrees
, void *data
)
2844 bitmap
*params
= (bitmap
*)data
;
2847 /* No need to walk into types or decls. */
2848 if (IS_TYPE_OR_DECL_P (t
))
2851 if (TREE_CODE (t
) == PARM_DECL
&& bitmap_bit_p (*params
, DECL_UID (t
)))
2857 /* Return true if STMT_LIST generates independent iterations in a loop. */
2860 independent_iterations_p (tree stmt_list
)
2862 tree_stmt_iterator tsi
;
2863 bitmap params
= BITMAP_GGC_ALLOC();
2864 auto_vec
<tree
, 16> rhs
;
2868 if (TREE_CODE (stmt_list
) == BIND_EXPR
)
2869 stmt_list
= BIND_EXPR_BODY (stmt_list
);
2871 /* Scan the list and return false on anything that is not either a check
2872 or an assignment to a parameter with restricted aliasing. */
2873 for (tsi
= tsi_start (stmt_list
); !tsi_end_p (tsi
); tsi_next (&tsi
))
2875 tree stmt
= tsi_stmt (tsi
);
2877 switch (TREE_CODE (stmt
))
2881 if (COND_EXPR_ELSE (stmt
))
2883 if (TREE_CODE (COND_EXPR_THEN (stmt
)) != CALL_EXPR
)
2885 tree func
= get_callee_fndecl (COND_EXPR_THEN (stmt
));
2886 if (!(func
&& TREE_THIS_VOLATILE (func
)))
2893 tree lhs
= TREE_OPERAND (stmt
, 0);
2894 while (handled_component_p (lhs
))
2895 lhs
= TREE_OPERAND (lhs
, 0);
2896 if (TREE_CODE (lhs
) != INDIRECT_REF
)
2898 lhs
= TREE_OPERAND (lhs
, 0);
2899 if (!(TREE_CODE (lhs
) == PARM_DECL
2900 && DECL_RESTRICTED_ALIASING_P (lhs
)))
2902 bitmap_set_bit (params
, DECL_UID (lhs
));
2903 rhs
.safe_push (TREE_OPERAND (stmt
, 1));
2912 /* At this point we know that the list contains only statements that will
2913 modify parameters with restricted aliasing. Check that the statements
2914 don't at the time read from these parameters. */
2915 FOR_EACH_VEC_ELT (rhs
, i
, iter
)
2916 if (walk_tree_without_duplicates (&iter
, scan_rhs_r
, ¶ms
))
2922 /* Helper for Loop_Statement_to_gnu, to translate the body of a loop not
2923 subject to any sort of parallelization directive or restriction, designated
2926 We expect the top of gnu_loop_stack to hold a pointer to the loop info
2927 setup for the translation, which holds a pointer to the initial gnu loop
2928 stmt node. We return the new gnu loop statement to use.
2930 We might also set *GNU_COND_EXPR_P to request a variant of the translation
2931 scheme in Loop_Statement_to_gnu. */
2934 Regular_Loop_to_gnu (Node_Id gnat_node
, tree
*gnu_cond_expr_p
)
2936 const Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2937 struct loop_info_d
*const gnu_loop_info
= gnu_loop_stack
->last ();
2938 tree gnu_loop_stmt
= gnu_loop_info
->stmt
;
2939 tree gnu_loop_label
= LOOP_STMT_LABEL (gnu_loop_stmt
);
2940 tree gnu_cond_expr
= *gnu_cond_expr_p
;
2941 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2943 /* Set the condition under which the loop must keep going. If we have an
2944 explicit condition, use it to set the location information throughout
2945 the translation of the loop statement to avoid having multiple SLOCs.
2947 For the case "LOOP .... END LOOP;" the condition is always true. */
2948 if (No (gnat_iter_scheme
))
2951 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2952 else if (Present (Condition (gnat_iter_scheme
)))
2954 LOOP_STMT_COND (gnu_loop_stmt
)
2955 = gnat_to_gnu (Condition (gnat_iter_scheme
));
2957 set_expr_location_from_node (gnu_loop_stmt
, gnat_iter_scheme
);
2960 /* Otherwise we have an iteration scheme and the condition is given by the
2961 bounds of the subtype of the iteration variable. */
2964 Node_Id gnat_loop_spec
= Loop_Parameter_Specification (gnat_iter_scheme
);
2965 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2966 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2967 tree gnu_type
= get_unpadded_type (gnat_type
);
2968 tree gnu_base_type
= maybe_character_type (get_base_type (gnu_type
));
2969 tree gnu_one_node
= build_int_cst (gnu_base_type
, 1);
2970 tree gnu_loop_var
, gnu_loop_iv
, gnu_first
, gnu_last
, gnu_stmt
;
2971 enum tree_code update_code
, test_code
, shift_code
;
2972 bool reverse
= Reverse_Present (gnat_loop_spec
), use_iv
= false;
2974 gnu_low
= convert (gnu_base_type
, TYPE_MIN_VALUE (gnu_type
));
2975 gnu_high
= convert (gnu_base_type
, TYPE_MAX_VALUE (gnu_type
));
2977 /* We must disable modulo reduction for the iteration variable, if any,
2978 in order for the loop comparison to be effective. */
2981 gnu_first
= gnu_high
;
2983 update_code
= MINUS_NOMOD_EXPR
;
2984 test_code
= GE_EXPR
;
2985 shift_code
= PLUS_NOMOD_EXPR
;
2989 gnu_first
= gnu_low
;
2990 gnu_last
= gnu_high
;
2991 update_code
= PLUS_NOMOD_EXPR
;
2992 test_code
= LE_EXPR
;
2993 shift_code
= MINUS_NOMOD_EXPR
;
2996 /* We use two different strategies to translate the loop, depending on
2997 whether optimization is enabled.
2999 If it is, we generate the canonical loop form expected by the loop
3000 optimizer and the loop vectorizer, which is the do-while form:
3009 This avoids an implicit dependency on loop header copying and makes
3010 it possible to turn BOTTOM_COND into an inequality test.
3012 If optimization is disabled, loop header copying doesn't come into
3013 play and we try to generate the loop form with the fewer conditional
3014 branches. First, the default form, which is:
3022 It should catch most loops with constant ending point. Then, if we
3023 cannot, we try to generate the shifted form:
3031 which should catch loops with constant starting point. Otherwise, if
3032 we cannot, we generate the fallback form:
3041 which works in all cases. */
3043 if (optimize
&& !optimize_debug
)
3045 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
3047 if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
))
3050 /* Otherwise, use the do-while form with the help of a special
3051 induction variable in the unsigned version of the base type
3052 or the unsigned version of the size type, whichever is the
3053 largest, in order to have wrap-around arithmetics for it. */
3056 if (TYPE_PRECISION (gnu_base_type
)
3057 > TYPE_PRECISION (size_type_node
))
3059 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type
), 1);
3061 gnu_base_type
= size_type_node
;
3063 gnu_first
= convert (gnu_base_type
, gnu_first
);
3064 gnu_last
= convert (gnu_base_type
, gnu_last
);
3065 gnu_one_node
= build_int_cst (gnu_base_type
, 1);
3070 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
3072 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
3073 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
3077 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
3078 if (!can_equal_max_val_p (gnu_last
, gnu_base_type
, reverse
))
3081 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
3083 else if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
)
3084 && !can_equal_min_val_p (gnu_last
, gnu_base_type
, reverse
))
3087 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
3090 = build_binary_op (shift_code
, gnu_base_type
, gnu_last
,
3092 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
3095 /* Otherwise, use the fallback form. */
3097 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
3100 /* If we use the BOTTOM_COND, we can turn the test into an inequality
3101 test but we have to add ENTRY_COND to protect the empty loop. */
3102 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
))
3104 test_code
= NE_EXPR
;
3106 = build3 (COND_EXPR
, void_type_node
,
3107 build_binary_op (LE_EXPR
, boolean_type_node
,
3109 NULL_TREE
, alloc_stmt_list ());
3110 set_expr_location_from_node (gnu_cond_expr
, gnat_iter_scheme
);
3113 /* Open a new nesting level that will surround the loop to declare the
3114 iteration variable. */
3115 start_stmt_group ();
3118 /* If we use the special induction variable, create it and set it to
3119 its initial value. Morever, the regular iteration variable cannot
3120 itself be initialized, lest the initial value wrapped around. */
3124 = create_init_temporary ("I", gnu_first
, &gnu_stmt
, gnat_loop_var
);
3125 add_stmt (gnu_stmt
);
3126 gnu_first
= NULL_TREE
;
3129 gnu_loop_iv
= NULL_TREE
;
3131 /* Declare the iteration variable and set it to its initial value. */
3132 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, true);
3133 if (DECL_BY_REF_P (gnu_loop_var
))
3134 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_loop_var
);
3137 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var
));
3138 SET_DECL_INDUCTION_VAR (gnu_loop_var
, gnu_loop_iv
);
3140 gnu_loop_info
->loop_var
= gnu_loop_var
;
3141 gnu_loop_info
->low_bound
= gnu_low
;
3142 gnu_loop_info
->high_bound
= gnu_high
;
3144 /* Do all the arithmetics in the base type. */
3145 gnu_loop_var
= convert (gnu_base_type
, gnu_loop_var
);
3147 /* Set either the top or bottom exit condition. */
3149 LOOP_STMT_COND (gnu_loop_stmt
)
3150 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_iv
,
3153 LOOP_STMT_COND (gnu_loop_stmt
)
3154 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_var
,
3157 /* Set either the top or bottom update statement and give it the source
3158 location of the iteration for better coverage info. */
3162 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_iv
,
3163 build_binary_op (update_code
, gnu_base_type
,
3164 gnu_loop_iv
, gnu_one_node
));
3165 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3166 append_to_statement_list (gnu_stmt
,
3167 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
3169 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
3171 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3172 append_to_statement_list (gnu_stmt
,
3173 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
3178 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
3179 build_binary_op (update_code
, gnu_base_type
,
3180 gnu_loop_var
, gnu_one_node
));
3181 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3182 LOOP_STMT_UPDATE (gnu_loop_stmt
) = gnu_stmt
;
3185 set_expr_location_from_node (gnu_loop_stmt
, gnat_iter_scheme
);
3188 /* If the loop was named, have the name point to this loop. In this case,
3189 the association is not a DECL node, but the end label of the loop. */
3190 if (Present (Identifier (gnat_node
)))
3191 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_label
, true);
3193 /* Make the loop body into its own block, so any allocated storage will be
3194 released every iteration. This is needed for stack allocation. */
3195 LOOP_STMT_BODY (gnu_loop_stmt
)
3196 = build_stmt_group (Statements (gnat_node
), true);
3197 TREE_SIDE_EFFECTS (gnu_loop_stmt
) = 1;
3199 /* If we have an iteration scheme, then we are in a statement group. Add
3200 the LOOP_STMT to it, finish it and make it the "loop". */
3201 if (Present (gnat_iter_scheme
) && No (Condition (gnat_iter_scheme
)))
3203 /* First, if we have computed invariant conditions for range (or index)
3204 checks applied to the iteration variable, find out whether they can
3205 be evaluated to false at compile time; otherwise, if there are not
3206 too many of them, combine them with the original checks. If loop
3207 unswitching is enabled, do not require the loop bounds to be also
3208 invariant, as their evaluation will still be ahead of the loop. */
3209 if (vec_safe_length (gnu_loop_info
->checks
) > 0
3210 && (make_invariant (&gnu_low
, &gnu_high
) || optimize
>= 3))
3212 struct range_check_info_d
*rci
;
3213 unsigned int i
, n_remaining_checks
= 0;
3215 FOR_EACH_VEC_ELT (*gnu_loop_info
->checks
, i
, rci
)
3217 tree low_ok
, high_ok
;
3221 tree gnu_adjusted_low
= convert (rci
->type
, gnu_low
);
3224 = fold_build2 (rci
->neg_p
? MINUS_EXPR
: PLUS_EXPR
,
3225 rci
->type
, gnu_adjusted_low
, rci
->disp
);
3227 = build_binary_op (GE_EXPR
, boolean_type_node
,
3228 gnu_adjusted_low
, rci
->low_bound
);
3231 low_ok
= boolean_true_node
;
3233 if (rci
->high_bound
)
3235 tree gnu_adjusted_high
= convert (rci
->type
, gnu_high
);
3238 = fold_build2 (rci
->neg_p
? MINUS_EXPR
: PLUS_EXPR
,
3239 rci
->type
, gnu_adjusted_high
, rci
->disp
);
3241 = build_binary_op (LE_EXPR
, boolean_type_node
,
3242 gnu_adjusted_high
, rci
->high_bound
);
3245 high_ok
= boolean_true_node
;
3248 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
3252 = build_unary_op (TRUTH_NOT_EXPR
, boolean_type_node
, range_ok
);
3254 if (rci
->invariant_cond
== boolean_false_node
)
3255 TREE_OPERAND (rci
->inserted_cond
, 0) = rci
->invariant_cond
;
3257 n_remaining_checks
++;
3260 /* Note that loop unswitching can only be applied a small number of
3261 times to a given loop (PARAM_MAX_UNSWITCH_LEVEL default to 3). */
3262 if (IN_RANGE (n_remaining_checks
, 1, 3)
3265 FOR_EACH_VEC_ELT (*gnu_loop_info
->checks
, i
, rci
)
3266 if (rci
->invariant_cond
!= boolean_false_node
)
3268 TREE_OPERAND (rci
->inserted_cond
, 0) = rci
->invariant_cond
;
3271 add_stmt_with_node_force (rci
->inserted_cond
, gnat_node
);
3275 /* Second, if loop vectorization is enabled and the iterations of the
3276 loop can easily be proved as independent, mark the loop. */
3278 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt
)))
3279 LOOP_STMT_IVDEP (gnu_loop_stmt
) = 1;
3281 add_stmt (gnu_loop_stmt
);
3283 gnu_loop_stmt
= end_stmt_group ();
3286 *gnu_cond_expr_p
= gnu_cond_expr
;
3288 return gnu_loop_stmt
;
3291 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
3292 to a GCC tree, which is returned. */
3295 Loop_Statement_to_gnu (Node_Id gnat_node
)
3297 struct loop_info_d
*gnu_loop_info
= ggc_cleared_alloc
<loop_info_d
> ();
3299 tree gnu_loop_stmt
= build4 (LOOP_STMT
, void_type_node
, NULL_TREE
,
3300 NULL_TREE
, NULL_TREE
, NULL_TREE
);
3301 tree gnu_cond_expr
= NULL_TREE
;
3302 tree gnu_loop_label
= create_artificial_label (input_location
);
3305 /* Push the loop_info structure associated with the LOOP_STMT. */
3306 vec_safe_push (gnu_loop_stack
, gnu_loop_info
);
3308 /* Set location information for statement and end label. */
3309 set_expr_location_from_node (gnu_loop_stmt
, gnat_node
);
3310 Sloc_to_locus (Sloc (End_Label (gnat_node
)),
3311 &DECL_SOURCE_LOCATION (gnu_loop_label
));
3312 LOOP_STMT_LABEL (gnu_loop_stmt
) = gnu_loop_label
;
3314 /* Save the statement for later reuse. */
3315 gnu_loop_info
->stmt
= gnu_loop_stmt
;
3317 /* Perform the core loop body translation. */
3318 gnu_loop_stmt
= Regular_Loop_to_gnu (gnat_node
, &gnu_cond_expr
);
3320 /* If we have an outer COND_EXPR, that's our result and this loop is its
3321 "true" statement. Otherwise, the result is the LOOP_STMT. */
3324 COND_EXPR_THEN (gnu_cond_expr
) = gnu_loop_stmt
;
3325 TREE_SIDE_EFFECTS (gnu_cond_expr
) = 1;
3326 gnu_result
= gnu_cond_expr
;
3329 gnu_result
= gnu_loop_stmt
;
3331 gnu_loop_stack
->pop ();
3336 /* This page implements a form of Named Return Value optimization modeled
3337 on the C++ optimization of the same name. The main difference is that
3338 we disregard any semantical considerations when applying it here, the
3339 counterpart being that we don't try to apply it to semantically loaded
3340 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3342 We consider a function body of the following GENERIC form:
3346 RETURN_EXPR [<retval> = ...]
3348 RETURN_EXPR [<retval> = R1]
3352 RETURN_EXPR [<retval> = ...]
3354 RETURN_EXPR [<retval> = Ri]
3357 where the Ri are not addressable and we try to fulfill a simple criterion
3358 that would make it possible to replace one or several Ri variables by the
3359 single RESULT_DECL of the function.
3361 The first observation is that RETURN_EXPRs that don't directly reference
3362 any of the Ri variables on the RHS of their assignment are transparent wrt
3363 the optimization. This is because the Ri variables aren't addressable so
3364 any transformation applied to them doesn't affect the RHS; moreover, the
3365 assignment writes the full <retval> object so existing values are entirely
3368 This property can be extended to some forms of RETURN_EXPRs that reference
3369 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3370 case, in particular when function calls are involved.
3372 Therefore the algorithm is as follows:
3374 1. Collect the list of candidates for a Named Return Value (Ri variables
3375 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3376 other expressions on the RHS of such assignments.
3378 2. Prune the members of the first list (candidates) that are referenced
3379 by a member of the second list (expressions).
3381 3. Extract a set of candidates with non-overlapping live ranges from the
3382 first list. These are the Named Return Values.
3384 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3385 Named Return Values in the function with the RESULT_DECL.
3387 If the function returns an unconstrained type, things are a bit different
3388 because the anonymous return object is allocated on the secondary stack
3389 and RESULT_DECL is only a pointer to it. Each return object can be of a
3390 different size and is allocated separately so we need not care about the
3391 addressability and the aforementioned overlapping issues. Therefore, we
3392 don't collect the other expressions and skip step #2 in the algorithm. */
3399 hash_set
<tree
> *visited
;
3402 /* Return true if T is a Named Return Value. */
3405 is_nrv_p (bitmap nrv
, tree t
)
3407 return TREE_CODE (t
) == VAR_DECL
&& bitmap_bit_p (nrv
, DECL_UID (t
));
3410 /* Helper function for walk_tree, used by finalize_nrv below. */
3413 prune_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
3415 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3418 /* No need to walk into types or decls. */
3419 if (IS_TYPE_OR_DECL_P (t
))
3422 if (is_nrv_p (dp
->nrv
, t
))
3423 bitmap_clear_bit (dp
->nrv
, DECL_UID (t
));
3428 /* Prune Named Return Values in BLOCK and return true if there is still a
3429 Named Return Value in BLOCK or one of its sub-blocks. */
3432 prune_nrv_in_block (bitmap nrv
, tree block
)
3434 bool has_nrv
= false;
3437 /* First recurse on the sub-blocks. */
3438 for (t
= BLOCK_SUBBLOCKS (block
); t
; t
= BLOCK_CHAIN (t
))
3439 has_nrv
|= prune_nrv_in_block (nrv
, t
);
3441 /* Then make sure to keep at most one NRV per block. */
3442 for (t
= BLOCK_VARS (block
); t
; t
= DECL_CHAIN (t
))
3443 if (is_nrv_p (nrv
, t
))
3446 bitmap_clear_bit (nrv
, DECL_UID (t
));
3454 /* Helper function for walk_tree, used by finalize_nrv below. */
3457 finalize_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
3459 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3462 /* No need to walk into types. */
3466 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3467 nop, but differs from using NULL_TREE in that it indicates that we care
3468 about the value of the RESULT_DECL. */
3469 else if (TREE_CODE (t
) == RETURN_EXPR
3470 && TREE_CODE (TREE_OPERAND (t
, 0)) == INIT_EXPR
)
3472 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1);
3474 /* Strip useless conversions around the return value. */
3475 if (gnat_useless_type_conversion (ret_val
))
3476 ret_val
= TREE_OPERAND (ret_val
, 0);
3478 if (is_nrv_p (dp
->nrv
, ret_val
))
3479 TREE_OPERAND (t
, 0) = dp
->result
;
3482 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3484 else if (TREE_CODE (t
) == DECL_EXPR
3485 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
3487 tree var
= DECL_EXPR_DECL (t
), init
;
3489 if (DECL_INITIAL (var
))
3491 init
= build_binary_op (INIT_EXPR
, NULL_TREE
, dp
->result
,
3492 DECL_INITIAL (var
));
3493 SET_EXPR_LOCATION (init
, EXPR_LOCATION (t
));
3494 DECL_INITIAL (var
) = NULL_TREE
;
3497 init
= build_empty_stmt (EXPR_LOCATION (t
));
3500 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3501 SET_DECL_VALUE_EXPR (var
, dp
->result
);
3502 DECL_HAS_VALUE_EXPR_P (var
) = 1;
3503 /* ??? Kludge to avoid an assertion failure during inlining. */
3504 DECL_SIZE (var
) = bitsize_unit_node
;
3505 DECL_SIZE_UNIT (var
) = size_one_node
;
3508 /* And replace all uses of NRVs with the RESULT_DECL. */
3509 else if (is_nrv_p (dp
->nrv
, t
))
3510 *tp
= convert (TREE_TYPE (t
), dp
->result
);
3512 /* Avoid walking into the same tree more than once. Unfortunately, we
3513 can't just use walk_tree_without_duplicates because it would only
3514 call us for the first occurrence of NRVs in the function body. */
3515 if (dp
->visited
->add (*tp
))
3521 /* Likewise, but used when the function returns an unconstrained type. */
3524 finalize_nrv_unc_r (tree
*tp
, int *walk_subtrees
, void *data
)
3526 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3529 /* No need to walk into types. */
3533 /* We need to see the DECL_EXPR of NRVs before any other references so we
3534 walk the body of BIND_EXPR before walking its variables. */
3535 else if (TREE_CODE (t
) == BIND_EXPR
)
3536 walk_tree (&BIND_EXPR_BODY (t
), finalize_nrv_unc_r
, data
, NULL
);
3538 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3539 return value built by the allocator instead of the whole construct. */
3540 else if (TREE_CODE (t
) == RETURN_EXPR
3541 && TREE_CODE (TREE_OPERAND (t
, 0)) == INIT_EXPR
)
3543 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1);
3545 /* This is the construct returned by the allocator. */
3546 if (TREE_CODE (ret_val
) == COMPOUND_EXPR
3547 && TREE_CODE (TREE_OPERAND (ret_val
, 0)) == INIT_EXPR
)
3549 tree rhs
= TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 1);
3551 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val
)))
3552 ret_val
= CONSTRUCTOR_ELT (rhs
, 1)->value
;
3557 /* Strip useless conversions around the return value. */
3558 if (gnat_useless_type_conversion (ret_val
)
3559 || TREE_CODE (ret_val
) == VIEW_CONVERT_EXPR
)
3560 ret_val
= TREE_OPERAND (ret_val
, 0);
3562 /* Strip unpadding around the return value. */
3563 if (TREE_CODE (ret_val
) == COMPONENT_REF
3564 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
3565 ret_val
= TREE_OPERAND (ret_val
, 0);
3567 /* Assign the new return value to the RESULT_DECL. */
3568 if (is_nrv_p (dp
->nrv
, ret_val
))
3569 TREE_OPERAND (TREE_OPERAND (t
, 0), 1)
3570 = TREE_OPERAND (DECL_INITIAL (ret_val
), 0);
3573 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3574 into a new variable. */
3575 else if (TREE_CODE (t
) == DECL_EXPR
3576 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
3578 tree saved_current_function_decl
= current_function_decl
;
3579 tree var
= DECL_EXPR_DECL (t
);
3580 tree alloc
, p_array
, new_var
, new_ret
;
3581 vec
<constructor_elt
, va_gc
> *v
;
3584 /* Create an artificial context to build the allocation. */
3585 current_function_decl
= decl_function_context (var
);
3586 start_stmt_group ();
3589 /* This will return a COMPOUND_EXPR with the allocation in the first
3590 arm and the final return value in the second arm. */
3591 alloc
= build_allocator (TREE_TYPE (var
), DECL_INITIAL (var
),
3592 TREE_TYPE (dp
->result
),
3593 Procedure_To_Call (dp
->gnat_ret
),
3594 Storage_Pool (dp
->gnat_ret
),
3597 /* The new variable is built as a reference to the allocated space. */
3599 = build_decl (DECL_SOURCE_LOCATION (var
), VAR_DECL
, DECL_NAME (var
),
3600 build_reference_type (TREE_TYPE (var
)));
3601 DECL_BY_REFERENCE (new_var
) = 1;
3603 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc
)))
3605 tree cst
= TREE_OPERAND (alloc
, 1);
3607 /* The new initial value is a COMPOUND_EXPR with the allocation in
3608 the first arm and the value of P_ARRAY in the second arm. */
3609 DECL_INITIAL (new_var
)
3610 = build2 (COMPOUND_EXPR
, TREE_TYPE (new_var
),
3611 TREE_OPERAND (alloc
, 0),
3612 CONSTRUCTOR_ELT (cst
, 0)->value
);
3614 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3615 p_array
= TYPE_FIELDS (TREE_TYPE (alloc
));
3616 CONSTRUCTOR_APPEND_ELT (v
, p_array
,
3617 fold_convert (TREE_TYPE (p_array
), new_var
));
3618 CONSTRUCTOR_APPEND_ELT (v
, DECL_CHAIN (p_array
),
3619 CONSTRUCTOR_ELT (cst
, 1)->value
);
3620 new_ret
= build_constructor (TREE_TYPE (alloc
), v
);
3624 /* The new initial value is just the allocation. */
3625 DECL_INITIAL (new_var
) = alloc
;
3626 new_ret
= fold_convert (TREE_TYPE (alloc
), new_var
);
3629 gnat_pushdecl (new_var
, Empty
);
3631 /* Destroy the artificial context and insert the new statements. */
3633 *tp
= end_stmt_group ();
3634 current_function_decl
= saved_current_function_decl
;
3636 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3637 DECL_CHAIN (new_var
) = DECL_CHAIN (var
);
3638 DECL_CHAIN (var
) = new_var
;
3639 DECL_IGNORED_P (var
) = 1;
3641 /* Save the new return value and the dereference of NEW_VAR. */
3643 = build2 (COMPOUND_EXPR
, TREE_TYPE (var
), new_ret
,
3644 build1 (INDIRECT_REF
, TREE_TYPE (var
), new_var
));
3645 /* ??? Kludge to avoid messing up during inlining. */
3646 DECL_CONTEXT (var
) = NULL_TREE
;
3649 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3650 else if (is_nrv_p (dp
->nrv
, t
))
3651 *tp
= TREE_OPERAND (DECL_INITIAL (t
), 1);
3653 /* Avoid walking into the same tree more than once. Unfortunately, we
3654 can't just use walk_tree_without_duplicates because it would only
3655 call us for the first occurrence of NRVs in the function body. */
3656 if (dp
->visited
->add (*tp
))
3662 /* Apply FUNC to all the sub-trees of nested functions in NODE. FUNC is called
3663 with the DATA and the address of each sub-tree. If FUNC returns a non-NULL
3664 value, the traversal is stopped. */
3667 walk_nesting_tree (struct cgraph_node
*node
, walk_tree_fn func
, void *data
)
3669 for (node
= first_nested_function (node
);
3670 node
; node
= next_nested_function (node
))
3672 walk_tree_without_duplicates (&DECL_SAVED_TREE (node
->decl
), func
, data
);
3673 walk_nesting_tree (node
, func
, data
);
3677 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3678 contains the candidates for Named Return Value and OTHER is a list of
3679 the other return values. GNAT_RET is a representative return node. */
3682 finalize_nrv (tree fndecl
, bitmap nrv
, vec
<tree
, va_gc
> *other
, Node_Id gnat_ret
)
3684 struct nrv_data data
;
3689 /* We shouldn't be applying the optimization to return types that we aren't
3690 allowed to manipulate freely. */
3691 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl
))));
3693 /* Prune the candidates that are referenced by other return values. */
3695 data
.result
= NULL_TREE
;
3696 data
.gnat_ret
= Empty
;
3697 data
.visited
= NULL
;
3698 FOR_EACH_VEC_SAFE_ELT (other
, i
, iter
)
3699 walk_tree_without_duplicates (&iter
, prune_nrv_r
, &data
);
3700 if (bitmap_empty_p (nrv
))
3703 /* Prune also the candidates that are referenced by nested functions. */
3704 walk_nesting_tree (cgraph_node::get_create (fndecl
), prune_nrv_r
, &data
);
3705 if (bitmap_empty_p (nrv
))
3708 /* Extract a set of NRVs with non-overlapping live ranges. */
3709 if (!prune_nrv_in_block (nrv
, DECL_INITIAL (fndecl
)))
3712 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3714 data
.result
= DECL_RESULT (fndecl
);
3715 data
.gnat_ret
= gnat_ret
;
3716 data
.visited
= new hash_set
<tree
>;
3717 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl
)))
3718 func
= finalize_nrv_unc_r
;
3720 func
= finalize_nrv_r
;
3721 walk_tree (&DECL_SAVED_TREE (fndecl
), func
, &data
, NULL
);
3722 delete data
.visited
;
3725 /* Return true if RET_VAL can be used as a Named Return Value for the
3726 anonymous return object RET_OBJ. */
3729 return_value_ok_for_nrv_p (tree ret_obj
, tree ret_val
)
3731 if (TREE_CODE (ret_val
) != VAR_DECL
)
3734 if (TREE_THIS_VOLATILE (ret_val
))
3737 if (DECL_CONTEXT (ret_val
) != current_function_decl
)
3740 if (TREE_STATIC (ret_val
))
3743 /* For the constrained case, test for addressability. */
3744 if (ret_obj
&& TREE_ADDRESSABLE (ret_val
))
3747 /* For the constrained case, test for overalignment. */
3748 if (ret_obj
&& DECL_ALIGN (ret_val
) > DECL_ALIGN (ret_obj
))
3751 /* For the unconstrained case, test for bogus initialization. */
3753 && DECL_INITIAL (ret_val
)
3754 && TREE_CODE (DECL_INITIAL (ret_val
)) == NULL_EXPR
)
3760 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3761 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3762 around RESULT_OBJ, which may be null in this case. */
3765 build_return_expr (tree ret_obj
, tree ret_val
)
3771 /* The gimplifier explicitly enforces the following invariant:
3780 As a consequence, type consistency dictates that we use the type
3781 of the RET_OBJ as the operation type. */
3782 tree operation_type
= TREE_TYPE (ret_obj
);
3784 /* Convert the right operand to the operation type. Note that this is
3785 the transformation applied in the INIT_EXPR case of build_binary_op,
3786 with the assumption that the type cannot involve a placeholder. */
3787 if (operation_type
!= TREE_TYPE (ret_val
))
3788 ret_val
= convert (operation_type
, ret_val
);
3790 /* We always can use an INIT_EXPR for the return object. */
3791 result_expr
= build2 (INIT_EXPR
, void_type_node
, ret_obj
, ret_val
);
3793 /* If the function returns an aggregate type, find out whether this is
3794 a candidate for Named Return Value. If so, record it. Otherwise,
3795 if this is an expression of some kind, record it elsewhere. */
3798 && AGGREGATE_TYPE_P (operation_type
)
3799 && !TYPE_IS_FAT_POINTER_P (operation_type
)
3800 && TYPE_MODE (operation_type
) == BLKmode
3801 && aggregate_value_p (operation_type
, current_function_decl
))
3803 /* Strip useless conversions around the return value. */
3804 if (gnat_useless_type_conversion (ret_val
))
3805 ret_val
= TREE_OPERAND (ret_val
, 0);
3807 /* Now apply the test to the return value. */
3808 if (return_value_ok_for_nrv_p (ret_obj
, ret_val
))
3810 if (!f_named_ret_val
)
3811 f_named_ret_val
= BITMAP_GGC_ALLOC ();
3812 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
3815 /* Note that we need not care about CONSTRUCTORs here, as they are
3816 totally transparent given the read-compose-write semantics of
3817 assignments from CONSTRUCTORs. */
3818 else if (EXPR_P (ret_val
))
3819 vec_safe_push (f_other_ret_val
, ret_val
);
3823 result_expr
= ret_obj
;
3825 return build1 (RETURN_EXPR
, void_type_node
, result_expr
);
3828 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3829 don't return anything. */
3832 Subprogram_Body_to_gnu (Node_Id gnat_node
)
3834 /* Defining identifier of a parameter to the subprogram. */
3835 Entity_Id gnat_param
;
3836 /* The defining identifier for the subprogram body. Note that if a
3837 specification has appeared before for this body, then the identifier
3838 occurring in that specification will also be a defining identifier and all
3839 the calls to this subprogram will point to that specification. */
3840 Entity_Id gnat_subprog_id
3841 = (Present (Corresponding_Spec (gnat_node
))
3842 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
3843 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3844 tree gnu_subprog_decl
;
3845 /* Its RESULT_DECL node. */
3846 tree gnu_result_decl
;
3847 /* Its FUNCTION_TYPE node. */
3848 tree gnu_subprog_type
;
3849 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3851 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3852 tree gnu_return_var_elmt
= NULL_TREE
;
3855 struct language_function
*gnu_subprog_language
;
3856 vec
<parm_attr
, va_gc
> *cache
;
3858 /* If this is a generic object or if it has been eliminated,
3860 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
3861 || Ekind (gnat_subprog_id
) == E_Generic_Function
3862 || Is_Eliminated (gnat_subprog_id
))
3865 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3866 the already-elaborated tree node. However, if this subprogram had its
3867 elaboration deferred, we will already have made a tree node for it. So
3868 treat it as not being defined in that case. Such a subprogram cannot
3869 have an address clause or a freeze node, so this test is safe, though it
3870 does disable some otherwise-useful error checking. */
3872 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
3873 Acts_As_Spec (gnat_node
)
3874 && !present_gnu_tree (gnat_subprog_id
));
3875 DECL_FUNCTION_IS_DEF (gnu_subprog_decl
) = true;
3876 gnu_result_decl
= DECL_RESULT (gnu_subprog_decl
);
3877 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
3878 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3879 if (gnu_cico_list
&& TREE_VALUE (gnu_cico_list
) == void_type_node
)
3880 gnu_return_var_elmt
= gnu_cico_list
;
3882 /* If the function returns by invisible reference, make it explicit in the
3883 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
3884 if (TREE_ADDRESSABLE (gnu_subprog_type
))
3886 TREE_TYPE (gnu_result_decl
)
3887 = build_reference_type (TREE_TYPE (gnu_result_decl
));
3888 relayout_decl (gnu_result_decl
);
3891 /* Set the line number in the decl to correspond to that of the body. */
3892 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
, false, gnu_subprog_decl
))
3893 locus
= input_location
;
3894 DECL_SOURCE_LOCATION (gnu_subprog_decl
) = locus
;
3896 /* If the body comes from an expression function, arrange it to be inlined
3897 in almost all cases. */
3898 if (Was_Expression_Function (gnat_node
))
3899 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog_decl
) = 1;
3901 /* Try to create a bona-fide thunk and hand it over to the middle-end. */
3902 if (Is_Thunk (gnat_subprog_id
)
3903 && maybe_make_gnu_thunk (gnat_subprog_id
, gnu_subprog_decl
))
3906 /* Initialize the information structure for the function. */
3907 allocate_struct_function (gnu_subprog_decl
, false);
3908 gnu_subprog_language
= ggc_cleared_alloc
<language_function
> ();
3909 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->language
= gnu_subprog_language
;
3910 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->function_start_locus
= locus
;
3913 begin_subprog_body (gnu_subprog_decl
);
3915 /* If there are copy-in/copy-out parameters, we need to ensure that they are
3916 properly copied out by the return statement. We do this by making a new
3917 block and converting any return into a goto to a label at the end of the
3921 tree gnu_return_var
= NULL_TREE
;
3923 vec_safe_push (gnu_return_label_stack
,
3924 create_artificial_label (input_location
));
3926 start_stmt_group ();
3929 /* If this is a function with copy-in/copy-out parameters and which does
3930 not return by invisible reference, we also need a variable for the
3931 return value to be placed. */
3932 if (gnu_return_var_elmt
&& !TREE_ADDRESSABLE (gnu_subprog_type
))
3934 tree gnu_return_type
3935 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt
));
3938 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE
,
3939 gnu_return_type
, NULL_TREE
,
3940 false, false, false, false, false,
3941 true, false, NULL
, gnat_subprog_id
);
3942 TREE_VALUE (gnu_return_var_elmt
) = gnu_return_var
;
3945 vec_safe_push (gnu_return_var_stack
, gnu_return_var
);
3947 /* See whether there are parameters for which we don't have a GCC tree
3948 yet. These must be Out parameters. Make a VAR_DECL for them and
3949 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3950 We can match up the entries because TYPE_CI_CO_LIST is in the order
3951 of the parameters. */
3952 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
3953 Present (gnat_param
);
3954 gnat_param
= Next_Formal_With_Extras (gnat_param
))
3955 if (!present_gnu_tree (gnat_param
))
3957 tree gnu_cico_entry
= gnu_cico_list
;
3960 /* Skip any entries that have been already filled in; they must
3961 correspond to In Out parameters. */
3962 while (gnu_cico_entry
&& TREE_VALUE (gnu_cico_entry
))
3963 gnu_cico_entry
= TREE_CHAIN (gnu_cico_entry
);
3965 /* Do any needed dereferences for by-ref objects. */
3966 gnu_decl
= gnat_to_gnu_entity (gnat_param
, NULL_TREE
, true);
3967 gcc_assert (DECL_P (gnu_decl
));
3968 if (DECL_BY_REF_P (gnu_decl
))
3969 gnu_decl
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_decl
);
3971 /* Do any needed references for padded types. */
3972 TREE_VALUE (gnu_cico_entry
)
3973 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry
)), gnu_decl
);
3977 vec_safe_push (gnu_return_label_stack
, NULL_TREE
);
3979 /* Get a tree corresponding to the code for the subprogram. */
3980 start_stmt_group ();
3983 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
3985 /* Generate the code of the subprogram itself. A return statement will be
3986 present and any Out parameters will be handled there. */
3987 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
3989 gnu_result
= end_stmt_group ();
3991 /* Attempt setting the end_locus of our GCC body tree, typically a BIND_EXPR,
3992 then the end_locus of our GCC subprogram declaration tree. */
3993 set_end_locus_from_node (gnu_result
, gnat_node
);
3994 set_end_locus_from_node (gnu_subprog_decl
, gnat_node
);
3996 /* If we populated the parameter attributes cache, we need to make sure that
3997 the cached expressions are evaluated on all the possible paths leading to
3998 their uses. So we force their evaluation on entry of the function. */
3999 cache
= gnu_subprog_language
->parm_attr_cache
;
4002 struct parm_attr_d
*pa
;
4005 start_stmt_group ();
4007 FOR_EACH_VEC_ELT (*cache
, i
, pa
)
4010 add_stmt_with_node_force (pa
->first
, gnat_node
);
4012 add_stmt_with_node_force (pa
->last
, gnat_node
);
4014 add_stmt_with_node_force (pa
->length
, gnat_node
);
4017 add_stmt (gnu_result
);
4018 gnu_result
= end_stmt_group ();
4020 gnu_subprog_language
->parm_attr_cache
= NULL
;
4023 /* If we are dealing with a return from an Ada procedure with parameters
4024 passed by copy-in/copy-out, we need to return a record containing the
4025 final values of these parameters. If the list contains only one entry,
4026 return just that entry though.
4028 For a full description of the copy-in/copy-out parameter mechanism, see
4029 the part of the gnat_to_gnu_entity routine dealing with the translation
4032 We need to make a block that contains the definition of that label and
4033 the copying of the return value. It first contains the function, then
4034 the label and copy statement. */
4037 const Node_Id gnat_end_label
4038 = End_Label (Handled_Statement_Sequence (gnat_node
));
4040 gnu_return_var_stack
->pop ();
4042 add_stmt (gnu_result
);
4043 add_stmt (build1 (LABEL_EXPR
, void_type_node
,
4044 gnu_return_label_stack
->last ()));
4046 /* If this is a function which returns by invisible reference, the
4047 return value has already been dealt with at the return statements,
4048 so we only need to indirectly copy out the parameters. */
4049 if (TREE_ADDRESSABLE (gnu_subprog_type
))
4052 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result_decl
);
4055 gcc_assert (TREE_VALUE (gnu_cico_list
) == void_type_node
);
4057 for (t
= TREE_CHAIN (gnu_cico_list
); t
; t
= TREE_CHAIN (t
))
4059 tree gnu_field_deref
4060 = build_component_ref (gnu_ret_deref
, TREE_PURPOSE (t
), true);
4061 gnu_result
= build2 (MODIFY_EXPR
, void_type_node
,
4062 gnu_field_deref
, TREE_VALUE (t
));
4063 add_stmt_with_node (gnu_result
, gnat_end_label
);
4067 /* Otherwise, if this is a procedure or a function which does not return
4068 by invisible reference, we can do a direct block-copy out. */
4073 if (list_length (gnu_cico_list
) == 1)
4074 gnu_retval
= TREE_VALUE (gnu_cico_list
);
4077 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type
),
4080 gnu_result
= build_return_expr (gnu_result_decl
, gnu_retval
);
4081 add_stmt_with_node (gnu_result
, gnat_end_label
);
4085 gnu_result
= end_stmt_group ();
4088 gnu_return_label_stack
->pop ();
4090 /* On SEH targets, install an exception handler around the main entry
4091 point to catch unhandled exceptions. */
4092 if (DECL_NAME (gnu_subprog_decl
) == main_identifier_node
4093 && targetm_common
.except_unwind_info (&global_options
) == UI_SEH
)
4098 t
= build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
4099 1, integer_zero_node
);
4100 t
= build_call_n_expr (unhandled_except_decl
, 1, t
);
4102 etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, unhandled_others_decl
);
4103 etype
= tree_cons (NULL_TREE
, etype
, NULL_TREE
);
4105 t
= build2 (CATCH_EXPR
, void_type_node
, etype
, t
);
4106 gnu_result
= build2 (TRY_CATCH_EXPR
, TREE_TYPE (gnu_result
),
4110 end_subprog_body (gnu_result
);
4112 /* Finally annotate the parameters and disconnect the trees for parameters
4113 that we have turned into variables since they are now unusable. */
4114 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
4115 Present (gnat_param
);
4116 gnat_param
= Next_Formal_With_Extras (gnat_param
))
4118 tree gnu_param
= get_gnu_tree (gnat_param
);
4119 bool is_var_decl
= (TREE_CODE (gnu_param
) == VAR_DECL
);
4121 annotate_object (gnat_param
, TREE_TYPE (gnu_param
), NULL_TREE
,
4122 DECL_BY_REF_P (gnu_param
));
4125 save_gnu_tree (gnat_param
, NULL_TREE
, false);
4128 /* Disconnect the variable created for the return value. */
4129 if (gnu_return_var_elmt
)
4130 TREE_VALUE (gnu_return_var_elmt
) = void_type_node
;
4132 /* If the function returns an aggregate type and we have candidates for
4133 a Named Return Value, finalize the optimization. */
4134 if (optimize
&& !optimize_debug
&& gnu_subprog_language
->named_ret_val
)
4136 finalize_nrv (gnu_subprog_decl
,
4137 gnu_subprog_language
->named_ret_val
,
4138 gnu_subprog_language
->other_ret_val
,
4139 gnu_subprog_language
->gnat_ret
);
4140 gnu_subprog_language
->named_ret_val
= NULL
;
4141 gnu_subprog_language
->other_ret_val
= NULL
;
4144 /* If this is an inlined external function that has been marked uninlinable,
4145 drop the body and stop there. Otherwise compile the body. */
4146 if (DECL_EXTERNAL (gnu_subprog_decl
) && DECL_UNINLINABLE (gnu_subprog_decl
))
4147 DECL_SAVED_TREE (gnu_subprog_decl
) = NULL_TREE
;
4149 rest_of_subprog_body_compilation (gnu_subprog_decl
);
4152 /* The type of an atomic access. */
4154 typedef enum { NOT_ATOMIC
, SIMPLE_ATOMIC
, OUTER_ATOMIC
} atomic_acces_t
;
4156 /* Return true if GNAT_NODE references an Atomic entity. This is modeled on
4157 the Is_Atomic_Object predicate of the front-end, but additionally handles
4158 explicit dereferences. */
4161 node_is_atomic (Node_Id gnat_node
)
4163 Entity_Id gnat_entity
;
4165 switch (Nkind (gnat_node
))
4168 case N_Expanded_Name
:
4169 gnat_entity
= Entity (gnat_node
);
4170 if (Ekind (gnat_entity
) != E_Variable
)
4172 return Is_Atomic (gnat_entity
) || Is_Atomic (Etype (gnat_entity
));
4174 case N_Selected_Component
:
4175 return Is_Atomic (Etype (gnat_node
))
4176 || Is_Atomic (Entity (Selector_Name (gnat_node
)));
4178 case N_Indexed_Component
:
4179 return Is_Atomic (Etype (gnat_node
))
4180 || Has_Atomic_Components (Etype (Prefix (gnat_node
)))
4181 || (Is_Entity_Name (Prefix (gnat_node
))
4182 && Has_Atomic_Components (Entity (Prefix (gnat_node
))));
4184 case N_Explicit_Dereference
:
4185 return Is_Atomic (Etype (gnat_node
));
4194 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. This is
4195 modeled on the Is_Volatile_Full_Access_Object predicate of the front-end,
4196 but additionally handles explicit dereferences. */
4199 node_is_volatile_full_access (Node_Id gnat_node
)
4201 Entity_Id gnat_entity
;
4203 switch (Nkind (gnat_node
))
4206 case N_Expanded_Name
:
4207 gnat_entity
= Entity (gnat_node
);
4208 if (!Is_Object (gnat_entity
))
4210 return Is_Volatile_Full_Access (gnat_entity
)
4211 || Is_Volatile_Full_Access (Etype (gnat_entity
));
4213 case N_Selected_Component
:
4214 return Is_Volatile_Full_Access (Etype (gnat_node
))
4215 || Is_Volatile_Full_Access (Entity (Selector_Name (gnat_node
)));
4217 case N_Indexed_Component
:
4218 case N_Explicit_Dereference
:
4219 return Is_Volatile_Full_Access (Etype (gnat_node
));
4228 /* Return true if GNAT_NODE references a component of a larger object. */
4231 node_is_component (Node_Id gnat_node
)
4233 const Node_Kind k
= Nkind (gnat_node
);
4235 (k
== N_Indexed_Component
|| k
== N_Selected_Component
|| k
== N_Slice
);
4238 /* Compute whether GNAT_NODE requires atomic access and set TYPE to the type
4239 of access and SYNC according to the associated synchronization setting.
4241 We implement 3 different semantics of atomicity in this function:
4243 1. the Ada 95/2005/2012 semantics of the Atomic aspect/pragma,
4244 2. the Ada 2020 semantics of the Atomic aspect/pragma,
4245 3. the semantics of the Volatile_Full_Access GNAT aspect/pragma.
4247 They are mutually exclusive and the FE should have rejected conflicts. */
4250 get_atomic_access (Node_Id gnat_node
, atomic_acces_t
*type
, bool *sync
)
4252 Node_Id gnat_parent
, gnat_temp
;
4253 unsigned char attr_id
;
4255 /* First, scan the parent to filter out irrelevant cases. */
4256 gnat_parent
= Parent (gnat_node
);
4257 switch (Nkind (gnat_parent
))
4259 case N_Attribute_Reference
:
4260 attr_id
= Get_Attribute_Id (Attribute_Name (gnat_parent
));
4261 /* Do not mess up machine code insertions. */
4262 if (attr_id
== Attr_Asm_Input
|| attr_id
== Attr_Asm_Output
)
4265 /* Nothing to do if we are the prefix of an attribute, since we do not
4266 want an atomic access for things like 'Size. */
4268 /* ... fall through ... */
4271 /* The N_Reference node is like an attribute. */
4272 if (Prefix (gnat_parent
) == gnat_node
)
4276 case N_Object_Renaming_Declaration
:
4277 /* Nothing to do for the identifier in an object renaming declaration,
4278 the renaming itself does not need atomic access. */
4285 /* Now strip any type conversion from GNAT_NODE. */
4286 if (Nkind (gnat_node
) == N_Type_Conversion
4287 || Nkind (gnat_node
) == N_Unchecked_Type_Conversion
)
4288 gnat_node
= Expression (gnat_node
);
4290 /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as
4291 a whole require atomic access (RM C.6(15)). But, starting with Ada 2020,
4292 reads of or writes to a nonatomic subcomponent of the object also require
4293 atomic access (RM C.6(19)). */
4294 if (node_is_atomic (gnat_node
))
4296 bool as_a_whole
= true;
4298 /* If we are the prefix of the parent, then the access is partial. */
4299 for (gnat_temp
= gnat_node
, gnat_parent
= Parent (gnat_temp
);
4300 node_is_component (gnat_parent
) && Prefix (gnat_parent
) == gnat_temp
;
4301 gnat_temp
= gnat_parent
, gnat_parent
= Parent (gnat_temp
))
4302 if (Ada_Version
< Ada_2020
|| node_is_atomic (gnat_parent
))
4307 /* We consider that partial accesses are not sequential actions and,
4308 therefore, do not require synchronization. */
4309 *type
= SIMPLE_ATOMIC
;
4310 *sync
= as_a_whole
? Atomic_Sync_Required (gnat_node
) : false;
4314 /* Look for an outer atomic access of a nonatomic subcomponent. Note that,
4315 for VFA, we do this before looking at the node itself because we need to
4316 access the outermost VFA object atomically, unlike for Atomic where it is
4317 the innermost atomic object (RM C.6(19)). */
4318 for (gnat_temp
= gnat_node
;
4319 node_is_component (gnat_temp
);
4320 gnat_temp
= Prefix (gnat_temp
))
4321 if ((Ada_Version
>= Ada_2020
&& node_is_atomic (Prefix (gnat_temp
)))
4322 || node_is_volatile_full_access (Prefix (gnat_temp
)))
4324 *type
= OUTER_ATOMIC
;
4329 /* Unlike Atomic, accessing a VFA object always requires atomic access. */
4330 if (node_is_volatile_full_access (gnat_node
))
4332 *type
= SIMPLE_ATOMIC
;
4342 /* Return true if GNAT_NODE requires simple atomic access and, if so, set SYNC
4343 according to the associated synchronization setting. */
4346 simple_atomic_access_required_p (Node_Id gnat_node
, bool *sync
)
4348 atomic_acces_t type
;
4349 get_atomic_access (gnat_node
, &type
, sync
);
4350 return type
== SIMPLE_ATOMIC
;
4353 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4356 create_temporary (const char *prefix
, tree type
)
4359 = create_var_decl (create_tmp_var_name (prefix
), NULL_TREE
,
4361 false, false, false, false, false,
4362 true, false, NULL
, Empty
);
4366 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4367 Put the initialization statement into GNU_INIT_STMT and annotate it with
4368 the SLOC of GNAT_NODE. Return the temporary variable. */
4371 create_init_temporary (const char *prefix
, tree gnu_init
, tree
*gnu_init_stmt
,
4374 tree gnu_temp
= create_temporary (prefix
, TREE_TYPE (gnu_init
));
4376 *gnu_init_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_temp
, gnu_init
);
4377 set_expr_location_from_node (*gnu_init_stmt
, gnat_node
);
4382 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
4383 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4384 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4385 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4386 N_Assignment_Statement and the result is to be placed into that object.
4387 ATOMIC_ACCESS is the type of atomic access to be used for the assignment
4388 to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment
4389 to GNU_TARGET requires atomic synchronization. */
4392 Call_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, tree gnu_target
,
4393 atomic_acces_t atomic_access
, bool atomic_sync
)
4395 const bool function_call
= (Nkind (gnat_node
) == N_Function_Call
);
4396 const bool returning_value
= (function_call
&& !gnu_target
);
4397 /* The GCC node corresponding to the GNAT subprogram name. This can either
4398 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
4399 or an indirect reference expression (an INDIRECT_REF node) pointing to a
4401 tree gnu_subprog
= gnat_to_gnu (Name (gnat_node
));
4402 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
4403 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog
);
4404 /* The return type of the FUNCTION_TYPE. */
4405 tree gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
4406 const bool frontend_builtin
4407 = (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
4408 && DECL_BUILT_IN_CLASS (gnu_subprog
) == BUILT_IN_FRONTEND
);
4409 auto_vec
<tree
, 16> gnu_actual_vec
;
4410 tree gnu_name_list
= NULL_TREE
;
4411 tree gnu_stmt_list
= NULL_TREE
;
4412 tree gnu_after_list
= NULL_TREE
;
4413 tree gnu_retval
= NULL_TREE
;
4414 tree gnu_call
, gnu_result
;
4415 bool went_into_elab_proc
= false;
4416 bool pushed_binding_level
= false;
4419 Entity_Id gnat_formal
;
4420 Node_Id gnat_actual
;
4421 atomic_acces_t aa_type
;
4424 gcc_assert (FUNC_OR_METHOD_TYPE_P (gnu_subprog_type
));
4426 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
4427 all our args first. */
4428 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
&& DECL_STUBBED_P (gnu_subprog
))
4430 tree call_expr
= build_call_raise (PE_Stubbed_Subprogram_Called
,
4431 gnat_node
, N_Raise_Program_Error
);
4433 for (gnat_actual
= First_Actual (gnat_node
);
4434 Present (gnat_actual
);
4435 gnat_actual
= Next_Actual (gnat_actual
))
4436 add_stmt (gnat_to_gnu (gnat_actual
));
4438 if (returning_value
)
4440 *gnu_result_type_p
= gnu_result_type
;
4441 return build1 (NULL_EXPR
, gnu_result_type
, call_expr
);
4447 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
)
4449 /* For a call to a nested function, check the inlining status. */
4450 if (decl_function_context (gnu_subprog
))
4451 check_inlining_for_nested_subprog (gnu_subprog
);
4453 /* For a recursive call, avoid explosion due to recursive inlining. */
4454 if (gnu_subprog
== current_function_decl
)
4455 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog
) = 0;
4458 /* The only way we can be making a call via an access type is if Name is an
4459 explicit dereference. In that case, get the list of formal args from the
4460 type the access type is pointing to. Otherwise, get the formals from the
4461 entity being called. */
4462 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
4464 const Entity_Id gnat_prefix_type
4465 = Underlying_Type (Etype (Prefix (Name (gnat_node
))));
4467 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
4468 variadic
= IN (Convention (gnat_prefix_type
), Convention_C_Variadic
);
4470 /* If the access type doesn't require foreign-compatible representation,
4471 be prepared for descriptors. */
4473 = targetm
.calls
.custom_function_descriptors
> 0
4474 && Can_Use_Internal_Rep (gnat_prefix_type
);
4476 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
4478 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4479 gnat_formal
= Empty
;
4481 by_descriptor
= false;
4485 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
4487 = IN (Convention (Entity (Name (gnat_node
))), Convention_C_Variadic
);
4488 by_descriptor
= false;
4491 /* The lifetime of the temporaries created for the call ends right after the
4492 return value is copied, so we can give them the scope of the elaboration
4493 routine at top level. */
4494 if (!current_function_decl
)
4496 current_function_decl
= get_elaboration_procedure ();
4497 went_into_elab_proc
= true;
4500 /* First, create the temporary for the return value when:
4502 1. There is no target and the function has copy-in/copy-out parameters,
4503 because we need to preserve the return value before copying back the
4506 2. There is no target and the call is made for neither an object, nor a
4507 renaming declaration, nor a return statement, nor an allocator, and
4508 the return type has variable size because in this case the gimplifier
4509 cannot create the temporary, or more generally is an aggregate type,
4510 because the gimplifier would create the temporary in the outermost
4511 scope instead of locally. But there is an exception for an allocator
4512 of an unconstrained record type with default discriminant because we
4513 allocate the actual size in this case, unlike the other 3 cases, so
4514 we need a temporary to fetch the discriminant and we create it here.
4516 3. There is a target and it is a slice or an array with fixed size,
4517 and the return type has variable size, because the gimplifier
4518 doesn't handle these cases.
4520 4. There is a target which is a bit-field and the function returns an
4521 unconstrained record type with default discriminant, because the
4522 return may copy more data than the bit-field can contain.
4524 5. There is no target and we have misaligned In Out or Out parameters
4525 passed by reference, because we need to preserve the return value
4526 before copying back the parameters. However, in this case, we'll
4527 defer creating the temporary, see below.
4529 This must be done before we push a binding level around the call, since
4530 we will pop it before copying the return value. */
4532 && ((!gnu_target
&& TYPE_CI_CO_LIST (gnu_subprog_type
))
4534 && Nkind (Parent (gnat_node
)) != N_Object_Declaration
4535 && Nkind (Parent (gnat_node
)) != N_Object_Renaming_Declaration
4536 && Nkind (Parent (gnat_node
)) != N_Simple_Return_Statement
4537 && (!(Nkind (Parent (gnat_node
)) == N_Qualified_Expression
4538 && Nkind (Parent (Parent (gnat_node
))) == N_Allocator
)
4539 || type_is_padding_self_referential (gnu_result_type
))
4540 && AGGREGATE_TYPE_P (gnu_result_type
)
4541 && !TYPE_IS_FAT_POINTER_P (gnu_result_type
))
4543 && (TREE_CODE (gnu_target
) == ARRAY_RANGE_REF
4544 || (TREE_CODE (TREE_TYPE (gnu_target
)) == ARRAY_TYPE
4545 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target
)))
4547 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
)
4549 && TREE_CODE (gnu_target
) == COMPONENT_REF
4550 && DECL_BIT_FIELD (TREE_OPERAND (gnu_target
, 1))
4551 && type_is_padding_self_referential (gnu_result_type
))))
4553 gnu_retval
= create_temporary ("R", gnu_result_type
);
4554 DECL_RETURN_VALUE_P (gnu_retval
) = 1;
4557 /* If we don't need a value or have already created it, push a binding level
4558 around the call. This will narrow the lifetime of the temporaries we may
4559 need to make when translating the parameters as much as possible. */
4560 if (!returning_value
|| gnu_retval
)
4562 start_stmt_group ();
4564 pushed_binding_level
= true;
4567 /* Create the list of the actual parameters as GCC expects it, namely a
4568 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4569 is an expression and the TREE_PURPOSE field is null. But skip Out
4570 parameters not passed by reference and that need not be copied in. */
4571 for (gnat_actual
= First_Actual (gnat_node
);
4572 Present (gnat_actual
);
4573 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
4574 gnat_actual
= Next_Actual (gnat_actual
))
4576 Entity_Id gnat_formal_type
= Etype (gnat_formal
);
4577 tree gnu_formal_type
= gnat_to_gnu_type (gnat_formal_type
);
4578 tree gnu_formal
= present_gnu_tree (gnat_formal
)
4579 ? get_gnu_tree (gnat_formal
) : NULL_TREE
;
4580 const bool in_param
= (Ekind (gnat_formal
) == E_In_Parameter
);
4581 const bool is_true_formal_parm
4582 = gnu_formal
&& TREE_CODE (gnu_formal
) == PARM_DECL
;
4583 const bool is_by_ref_formal_parm
4584 = is_true_formal_parm
4585 && (DECL_BY_REF_P (gnu_formal
)
4586 || DECL_BY_COMPONENT_PTR_P (gnu_formal
));
4587 /* In the In Out or Out case, we must suppress conversions that yield
4588 an lvalue but can nevertheless cause the creation of a temporary,
4589 because we need the real object in this case, either to pass its
4590 address if it's passed by reference or as target of the back copy
4591 done after the call if it uses the copy-in/copy-out mechanism.
4592 We do it in the In case too, except for an unchecked conversion
4593 to an elementary type or a constrained composite type because it
4594 alone can cause the actual to be misaligned and the addressability
4595 test is applied to the real object. */
4596 const bool suppress_type_conversion
4597 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
4599 || !is_by_ref_formal_parm
4600 || (Is_Composite_Type (Underlying_Type (gnat_formal_type
))
4601 && !Is_Constrained (Underlying_Type (gnat_formal_type
)))))
4602 || (Nkind (gnat_actual
) == N_Type_Conversion
4603 && Is_Composite_Type (Underlying_Type (gnat_formal_type
))));
4604 Node_Id gnat_name
= suppress_type_conversion
4605 ? Expression (gnat_actual
) : gnat_actual
;
4606 tree gnu_name
= gnat_to_gnu (gnat_name
), gnu_name_type
;
4608 /* If it's possible we may need to use this expression twice, make sure
4609 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4610 to force side-effects before the call. */
4611 if (!in_param
&& !is_by_ref_formal_parm
)
4613 tree init
= NULL_TREE
;
4614 gnu_name
= gnat_stabilize_reference (gnu_name
, true, &init
);
4617 = build_compound_expr (TREE_TYPE (gnu_name
), init
, gnu_name
);
4620 /* If we are passing a non-addressable parameter by reference, pass the
4621 address of a copy. In the In Out or Out case, set up to copy back
4622 out after the call. */
4623 if (is_by_ref_formal_parm
4624 && (gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
)))
4625 && !addressable_p (gnu_name
, gnu_name_type
))
4627 tree gnu_orig
= gnu_name
, gnu_temp
, gnu_stmt
;
4629 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4630 but sort of an instantiation for them. */
4631 if (TREE_CODE (remove_conversions (gnu_name
, true)) == CONSTRUCTOR
)
4634 /* If the formal is passed by reference, a copy is not allowed. */
4635 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type
)
4636 || Is_Aliased (gnat_formal
))
4637 post_error ("misaligned actual cannot be passed by reference",
4640 /* If the mechanism was forced to by-ref, a copy is not allowed but
4641 we issue only a warning because this case is not strict Ada. */
4642 else if (DECL_FORCED_BY_REF_P (gnu_formal
))
4643 post_error ("misaligned actual cannot be passed by reference??",
4646 /* If the actual type of the object is already the nominal type,
4647 we have nothing to do, except if the size is self-referential
4648 in which case we'll remove the unpadding below. */
4649 if (TREE_TYPE (gnu_name
) == gnu_name_type
4650 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type
)))
4653 /* Otherwise remove the unpadding from all the objects. */
4654 else if (TREE_CODE (gnu_name
) == COMPONENT_REF
4655 && TYPE_IS_PADDING_P
4656 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))
4657 gnu_orig
= gnu_name
= TREE_OPERAND (gnu_name
, 0);
4659 /* Otherwise convert to the nominal type of the object if needed.
4660 There are several cases in which we need to make the temporary
4661 using this type instead of the actual type of the object when
4662 they are distinct, because the expectations of the callee would
4663 otherwise not be met:
4664 - if it's a justified modular type,
4665 - if the actual type is a smaller form of it,
4666 - if it's a smaller form of the actual type. */
4667 else if ((TREE_CODE (gnu_name_type
) == RECORD_TYPE
4668 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type
)
4669 || smaller_form_type_p (TREE_TYPE (gnu_name
),
4671 || (INTEGRAL_TYPE_P (gnu_name_type
)
4672 && smaller_form_type_p (gnu_name_type
,
4673 TREE_TYPE (gnu_name
))))
4674 gnu_name
= convert (gnu_name_type
, gnu_name
);
4676 /* If this is an In Out or Out parameter and we're returning a value,
4677 we need to create a temporary for the return value because we must
4678 preserve it before copying back at the very end. */
4679 if (!in_param
&& returning_value
&& !gnu_retval
)
4681 gnu_retval
= create_temporary ("R", gnu_result_type
);
4682 DECL_RETURN_VALUE_P (gnu_retval
) = 1;
4685 /* If we haven't pushed a binding level, push it now. This will
4686 narrow the lifetime of the temporary we are about to make as
4687 much as possible. */
4688 if (!pushed_binding_level
&& (!returning_value
|| gnu_retval
))
4690 start_stmt_group ();
4692 pushed_binding_level
= true;
4695 /* Create an explicit temporary holding the copy. */
4696 /* Do not initialize it for the _Init parameter of an initialization
4697 procedure since no data is meant to be passed in. */
4698 if (Ekind (gnat_formal
) == E_Out_Parameter
4699 && Is_Entity_Name (Name (gnat_node
))
4700 && Is_Init_Proc (Entity (Name (gnat_node
))))
4701 gnu_name
= gnu_temp
= create_temporary ("A", TREE_TYPE (gnu_name
));
4703 /* Initialize it on the fly like for an implicit temporary in the
4704 other cases, as we don't necessarily have a statement list. */
4707 gnu_temp
= create_init_temporary ("A", gnu_name
, &gnu_stmt
,
4709 gnu_name
= build_compound_expr (TREE_TYPE (gnu_name
), gnu_stmt
,
4713 /* Set up to move the copy back to the original if needed. */
4716 /* If the original is a COND_EXPR whose first arm isn't meant to
4717 be further used, just deal with the second arm. This is very
4718 likely the conditional expression built for a check. */
4719 if (TREE_CODE (gnu_orig
) == COND_EXPR
4720 && TREE_CODE (TREE_OPERAND (gnu_orig
, 1)) == COMPOUND_EXPR
4722 (TREE_OPERAND (TREE_OPERAND (gnu_orig
, 1), 1)))
4723 gnu_orig
= TREE_OPERAND (gnu_orig
, 2);
4726 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_orig
, gnu_temp
);
4727 set_expr_location_from_node (gnu_stmt
, gnat_node
);
4729 append_to_statement_list (gnu_stmt
, &gnu_after_list
);
4733 /* Start from the real object and build the actual. */
4734 tree gnu_actual
= gnu_name
;
4736 /* If atomic access is required for an In or In Out actual parameter,
4737 build the atomic load. */
4738 if (is_true_formal_parm
4739 && !is_by_ref_formal_parm
4740 && Ekind (gnat_formal
) != E_Out_Parameter
4741 && simple_atomic_access_required_p (gnat_actual
, &aa_sync
))
4742 gnu_actual
= build_atomic_load (gnu_actual
, aa_sync
);
4744 /* If this was a procedure call, we may not have removed any padding.
4745 So do it here for the part we will use as an input, if any. */
4746 if (Ekind (gnat_formal
) != E_Out_Parameter
4747 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
4749 = convert (get_unpadded_type (Etype (gnat_actual
)), gnu_actual
);
4751 /* Put back the conversion we suppressed above in the computation of the
4752 real object. And even if we didn't suppress any conversion there, we
4753 may have suppressed a conversion to the Etype of the actual earlier,
4754 since the parent is a procedure call, so put it back here. Note that
4755 we might have a dummy type here if the actual is the dereference of a
4756 pointer to it, but that's OK if the formal is passed by reference. */
4757 tree gnu_actual_type
= get_unpadded_type (Etype (gnat_actual
));
4758 if (TYPE_IS_DUMMY_P (gnu_actual_type
))
4759 gcc_assert (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
));
4760 else if (suppress_type_conversion
4761 && Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
4762 gnu_actual
= unchecked_convert (gnu_actual_type
, gnu_actual
,
4763 No_Truncation (gnat_actual
));
4765 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
4767 gigi_checking_assert (!Do_Range_Check (gnat_actual
));
4769 /* First see if the parameter is passed by reference. */
4770 if (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
))
4774 /* In Out or Out parameters passed by reference don't use the
4775 copy-in/copy-out mechanism so the address of the real object
4776 must be passed to the function. */
4777 gnu_actual
= gnu_name
;
4779 /* If we have a padded type, be sure we've removed padding. */
4780 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
4781 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
4784 /* If we have the constructed subtype of an aliased object
4785 with an unconstrained nominal subtype, the type of the
4786 actual includes the template, although it is formally
4787 constrained. So we need to convert it back to the real
4788 constructed subtype to retrieve the constrained part
4789 and takes its address. */
4790 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
4791 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual
))
4792 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual
))
4793 && Is_Array_Type (Underlying_Type (Etype (gnat_actual
))))
4794 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
4797 /* There is no need to convert the actual to the formal's type before
4798 taking its address. The only exception is for unconstrained array
4799 types because of the way we build fat pointers. */
4800 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4802 /* Put back the conversion we suppressed above for In Out or Out
4803 parameters, since it may set the bounds of the actual. */
4804 if (!in_param
&& suppress_type_conversion
)
4805 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
4806 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4809 /* Take the address of the object and convert to the proper pointer
4811 gnu_formal_type
= TREE_TYPE (gnu_formal
);
4812 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4815 /* Then see if the parameter is an array passed to a foreign convention
4817 else if (is_true_formal_parm
&& DECL_BY_COMPONENT_PTR_P (gnu_formal
))
4819 gnu_actual
= maybe_padded_object (gnu_actual
);
4820 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
4822 /* Take the address of the object and convert to the proper pointer
4823 type. We'd like to actually compute the address of the beginning
4824 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4825 possibility that the ARRAY_REF might return a constant and we'd be
4826 getting the wrong address. Neither approach is exactly correct,
4827 but this is the most likely to work in all cases. */
4828 gnu_formal_type
= TREE_TYPE (gnu_formal
);
4829 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4832 /* Then see if the parameter is passed by copy. */
4833 else if (is_true_formal_parm
)
4836 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
4838 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4840 /* If this is a front-end built-in function, there is no need to
4841 convert to the type used to pass the argument. */
4842 if (!frontend_builtin
)
4843 gnu_actual
= convert (DECL_ARG_TYPE (gnu_formal
), gnu_actual
);
4846 /* Then see if this is an unnamed parameter in a variadic C function. */
4849 /* This is based on the processing done in gnat_to_gnu_param, but
4850 we expect the mechanism to be set in (almost) all cases. */
4851 const Mechanism_Type mech
= Mechanism (gnat_formal
);
4853 /* Strip off possible padding type. */
4854 if (TYPE_IS_PADDING_P (gnu_formal_type
))
4855 gnu_formal_type
= TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
4857 /* Arrays are passed as pointers to element type. First check for
4858 unconstrained array and get the underlying array. */
4859 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4862 (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_formal_type
))));
4864 /* Arrays are passed as pointers to element type. */
4865 if (mech
!= By_Copy
&& TREE_CODE (gnu_formal_type
) == ARRAY_TYPE
)
4867 gnu_actual
= maybe_padded_object (gnu_actual
);
4868 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
4870 /* Strip off any multi-dimensional entries, then strip
4871 off the last array to get the component type. */
4872 while (TREE_CODE (TREE_TYPE (gnu_formal_type
)) == ARRAY_TYPE
4873 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_formal_type
)))
4874 gnu_formal_type
= TREE_TYPE (gnu_formal_type
);
4876 gnu_formal_type
= TREE_TYPE (gnu_formal_type
);
4877 gnu_formal_type
= build_pointer_type (gnu_formal_type
);
4879 = build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4882 /* Fat pointers are passed as thin pointers. */
4883 else if (TYPE_IS_FAT_POINTER_P (gnu_formal_type
))
4885 = make_type_from_size (gnu_formal_type
,
4886 size_int (POINTER_SIZE
), 0);
4888 /* If we were requested or muss pass by reference, do so.
4889 If we were requested to pass by copy, do so.
4890 Otherwise, pass In Out or Out parameters or aggregates by
4892 else if (mech
== By_Reference
4893 || must_pass_by_ref (gnu_formal_type
)
4895 && (!in_param
|| AGGREGATE_TYPE_P (gnu_formal_type
))))
4897 gnu_formal_type
= build_reference_type (gnu_formal_type
);
4899 = build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4902 /* Otherwise pass by copy after applying default C promotions. */
4905 if (INTEGRAL_TYPE_P (gnu_formal_type
)
4906 && TYPE_PRECISION (gnu_formal_type
)
4907 < TYPE_PRECISION (integer_type_node
))
4908 gnu_formal_type
= integer_type_node
;
4910 else if (SCALAR_FLOAT_TYPE_P (gnu_formal_type
)
4911 && TYPE_PRECISION (gnu_formal_type
)
4912 < TYPE_PRECISION (double_type_node
))
4913 gnu_formal_type
= double_type_node
;
4916 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4919 /* If we didn't create a PARM_DECL for the formal, this means that
4920 it is an Out parameter not passed by reference and that need not
4921 be copied in. In this case, the value of the actual need not be
4922 read. However, we still need to make sure that its side-effects
4923 are evaluated before the call, so we evaluate its address. */
4927 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
4929 if (TREE_SIDE_EFFECTS (gnu_name
))
4931 tree addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_name
);
4932 append_to_statement_list (addr
, &gnu_stmt_list
);
4938 gnu_actual_vec
.safe_push (gnu_actual
);
4941 if (frontend_builtin
)
4943 tree pred_cst
= build_int_cst (integer_type_node
, PRED_BUILTIN_EXPECT
);
4944 enum internal_fn icode
= IFN_BUILTIN_EXPECT
;
4946 switch (DECL_FE_FUNCTION_CODE (gnu_subprog
))
4948 case BUILT_IN_EXPECT
:
4950 case BUILT_IN_LIKELY
:
4951 gnu_actual_vec
.safe_push (boolean_true_node
);
4953 case BUILT_IN_UNLIKELY
:
4954 gnu_actual_vec
.safe_push (boolean_false_node
);
4960 gnu_actual_vec
.safe_push (pred_cst
);
4963 = build_call_expr_internal_loc_array (UNKNOWN_LOCATION
,
4966 gnu_actual_vec
.length (),
4967 gnu_actual_vec
.begin ());
4972 = build_call_array_loc (UNKNOWN_LOCATION
,
4974 build_unary_op (ADDR_EXPR
, NULL_TREE
,
4976 gnu_actual_vec
.length (),
4977 gnu_actual_vec
.begin ());
4978 CALL_EXPR_BY_DESCRIPTOR (gnu_call
) = by_descriptor
;
4981 set_expr_location_from_node (gnu_call
, gnat_node
);
4983 /* If we have created a temporary for the return value, initialize it. */
4987 = build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_retval
, gnu_call
);
4988 set_expr_location_from_node (gnu_stmt
, gnat_node
);
4989 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
4990 gnu_call
= gnu_retval
;
4993 /* If this is a subprogram with copy-in/copy-out parameters, we need to
4994 unpack the valued returned from the function into the In Out or Out
4995 parameters. We deal with the function return (if this is an Ada
4997 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
4999 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
5000 copy-out parameters. */
5001 tree gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
5002 const int length
= list_length (gnu_cico_list
);
5004 /* The call sequence must contain one and only one call, even though the
5005 function is pure. Save the result into a temporary if needed. */
5012 = create_init_temporary ("P", gnu_call
, &gnu_stmt
, gnat_node
);
5013 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
5016 gnu_name_list
= nreverse (gnu_name_list
);
5019 /* The first entry is for the actual return value if this is a
5020 function, so skip it. */
5022 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
5024 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
5025 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
5027 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
5029 for (gnat_actual
= First_Actual (gnat_node
);
5030 Present (gnat_actual
);
5031 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
5032 gnat_actual
= Next_Actual (gnat_actual
))
5033 /* If we are dealing with a copy-in/copy-out parameter, we must
5034 retrieve its value from the record returned in the call. */
5035 if (!(present_gnu_tree (gnat_formal
)
5036 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
5037 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
5038 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))))
5039 && Ekind (gnat_formal
) != E_In_Parameter
)
5041 /* Get the value to assign to this In Out or Out parameter. It is
5042 either the result of the function if there is only a single such
5043 parameter or the appropriate field from the record returned. */
5047 : build_component_ref (gnu_call
, TREE_PURPOSE (gnu_cico_list
),
5050 /* If the actual is a conversion, get the inner expression, which
5051 will be the real destination, and convert the result to the
5052 type of the actual parameter. */
5054 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
5056 /* If the result is padded, remove the padding. */
5057 gnu_result
= maybe_padded_object (gnu_result
);
5059 /* If the actual is a type conversion, the real target object is
5060 denoted by the inner Expression and we need to convert the
5061 result to the associated type.
5062 We also need to convert our gnu assignment target to this type
5063 if the corresponding GNU_NAME was constructed from the GNAT
5064 conversion node and not from the inner Expression. */
5065 if (Nkind (gnat_actual
) == N_Type_Conversion
)
5067 const Node_Id gnat_expr
= Expression (gnat_actual
);
5069 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
5072 = convert_with_check (Etype (gnat_expr
), gnu_result
,
5073 Do_Overflow_Check (gnat_actual
),
5074 Float_Truncate (gnat_actual
),
5077 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal
))))
5078 gnu_actual
= convert (TREE_TYPE (gnu_result
), gnu_actual
);
5081 /* Unchecked conversions as actuals for Out parameters are not
5082 allowed in user code because they are not variables, but do
5083 occur in front-end expansions. The associated GNU_NAME is
5084 always obtained from the inner expression in such cases. */
5085 else if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
5086 gnu_result
= unchecked_convert (TREE_TYPE (gnu_actual
),
5088 No_Truncation (gnat_actual
));
5091 gigi_checking_assert (!Do_Range_Check (gnat_actual
));
5093 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
5094 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
5095 gnu_result
= convert (TREE_TYPE (gnu_actual
), gnu_result
);
5098 get_atomic_access (gnat_actual
, &aa_type
, &aa_sync
);
5100 /* If an outer atomic access is required for an actual parameter,
5101 build the load-modify-store sequence. */
5102 if (aa_type
== OUTER_ATOMIC
)
5104 = build_load_modify_store (gnu_actual
, gnu_result
, gnat_node
);
5106 /* Or else, if a simple atomic access is required, build the atomic
5108 else if (aa_type
== SIMPLE_ATOMIC
)
5110 = build_atomic_store (gnu_actual
, gnu_result
, aa_sync
);
5112 /* Otherwise build a regular assignment. */
5114 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5115 gnu_actual
, gnu_result
);
5117 if (EXPR_P (gnu_result
))
5118 set_expr_location_from_node (gnu_result
, gnat_node
);
5119 append_to_statement_list (gnu_result
, &gnu_stmt_list
);
5120 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
5121 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
5125 /* If this is a function call, the result is the call expression unless a
5126 target is specified, in which case we copy the result into the target
5127 and return the assignment statement. */
5130 /* If this is a function with copy-in/copy-out parameters, extract the
5131 return value from it and update the return type. */
5132 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
5134 tree gnu_elmt
= TYPE_CI_CO_LIST (gnu_subprog_type
);
5136 = build_component_ref (gnu_call
, TREE_PURPOSE (gnu_elmt
), false);
5137 gnu_result_type
= TREE_TYPE (gnu_call
);
5140 /* If the function returns an unconstrained array or by direct reference,
5141 we have to dereference the pointer. */
5142 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
)
5143 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
))
5144 gnu_call
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_call
);
5148 Node_Id gnat_parent
= Parent (gnat_node
);
5149 enum tree_code op_code
;
5151 gigi_checking_assert (!Do_Range_Check (gnat_node
));
5153 /* ??? If the return type has variable size, then force the return
5154 slot optimization as we would not be able to create a temporary.
5155 That's what has been done historically. */
5156 if (return_type_with_variable_size_p (gnu_result_type
))
5157 op_code
= INIT_EXPR
;
5159 op_code
= MODIFY_EXPR
;
5161 /* Use the required method to move the result to the target. */
5162 if (atomic_access
== OUTER_ATOMIC
)
5164 = build_load_modify_store (gnu_target
, gnu_call
, gnat_node
);
5165 else if (atomic_access
== SIMPLE_ATOMIC
)
5166 gnu_call
= build_atomic_store (gnu_target
, gnu_call
, atomic_sync
);
5169 = build_binary_op (op_code
, NULL_TREE
, gnu_target
, gnu_call
);
5171 if (EXPR_P (gnu_call
))
5172 set_expr_location_from_node (gnu_call
, gnat_parent
);
5173 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
5176 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
5179 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
5180 parameters, the result is just the call statement. */
5181 else if (!TYPE_CI_CO_LIST (gnu_subprog_type
))
5182 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
5184 /* Finally, add the copy back statements, if any. */
5185 append_to_statement_list (gnu_after_list
, &gnu_stmt_list
);
5187 if (went_into_elab_proc
)
5188 current_function_decl
= NULL_TREE
;
5190 /* If we have pushed a binding level, pop it and finish up the enclosing
5192 if (pushed_binding_level
)
5194 add_stmt (gnu_stmt_list
);
5196 gnu_result
= end_stmt_group ();
5199 /* Otherwise, retrieve the statement list, if any. */
5200 else if (gnu_stmt_list
)
5201 gnu_result
= gnu_stmt_list
;
5203 /* Otherwise, just return the call expression. */
5207 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
5208 But first simplify if we have only one statement in the list. */
5209 if (returning_value
)
5211 tree first
= expr_first (gnu_result
), last
= expr_last (gnu_result
);
5215 = build_compound_expr (TREE_TYPE (gnu_call
), gnu_result
, gnu_call
);
5221 /* Subroutine of gnat_to_gnu to translate gnat_node, an
5222 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
5225 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node
)
5227 /* If just annotating, ignore all EH and cleanups. */
5229 = (!type_annotate_only
5230 && Present (Exception_Handlers (gnat_node
))
5231 && Back_End_Exceptions ());
5232 const bool fe_sjlj_eh
5233 = (!type_annotate_only
5234 && Present (Exception_Handlers (gnat_node
))
5235 && Exception_Mechanism
== Front_End_SJLJ
);
5236 const bool at_end
= !type_annotate_only
&& Present (At_End_Proc (gnat_node
));
5237 const bool binding_for_block
= (at_end
|| gcc_eh
|| fe_sjlj_eh
);
5238 tree gnu_jmpsave_decl
= NULL_TREE
;
5239 tree gnu_jmpbuf_decl
= NULL_TREE
;
5240 tree gnu_inner_block
; /* The statement(s) for the block itself. */
5245 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
5246 and the front-end has its own SJLJ mechanism. To call the GCC mechanism,
5247 we call add_cleanup, and when we leave the binding, end_stmt_group will
5248 create the TRY_FINALLY_EXPR construct.
5250 ??? The region level calls down there have been specifically put in place
5251 for a ZCX context and currently the order in which things are emitted
5252 (region/handlers) is different from the SJLJ case. Instead of putting
5253 other calls with different conditions at other places for the SJLJ case,
5254 it seems cleaner to reorder things for the SJLJ case and generalize the
5255 condition to make it not ZCX specific.
5257 If there are any exceptions or cleanup processing involved, we need an
5258 outer statement group (for front-end SJLJ) and binding level. */
5259 if (binding_for_block
)
5261 start_stmt_group ();
5265 /* If using fe_sjlj_eh, make the variables for the setjmp buffer and save
5266 area for address of previous buffer. Do this first since we need to have
5267 the setjmp buf known for any decls in this block. */
5271 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
5273 build_call_n_expr (get_jmpbuf_decl
, 0),
5274 false, false, false, false, false, true, false,
5277 /* The __builtin_setjmp receivers will immediately reinstall it. Now
5278 because of the unstructured form of EH used by fe_sjlj_eh, there
5279 might be forward edges going to __builtin_setjmp receivers on which
5280 it is uninitialized, although they will never be actually taken. */
5281 TREE_NO_WARNING (gnu_jmpsave_decl
) = 1;
5283 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE
,
5286 false, false, false, false, false, true, false,
5289 set_block_jmpbuf_decl (gnu_jmpbuf_decl
);
5291 /* When we exit this block, restore the saved value. */
5292 add_cleanup (build_call_n_expr (set_jmpbuf_decl
, 1, gnu_jmpsave_decl
),
5293 Present (End_Label (gnat_node
))
5294 ? End_Label (gnat_node
) : gnat_node
);
5297 /* If we are to call a function when exiting this block, add a cleanup
5298 to the binding level we made above. Note that add_cleanup is FIFO
5299 so we must register this cleanup after the EH cleanup just above. */
5302 tree proc_decl
= gnat_to_gnu (At_End_Proc (gnat_node
));
5304 /* When not optimizing, disable inlining of finalizers as this can
5305 create a more complex CFG in the parent function. */
5306 if (!optimize
|| optimize_debug
)
5307 DECL_DECLARED_INLINE_P (proc_decl
) = 0;
5309 /* If there is no end label attached, we use the location of the At_End
5310 procedure because Expand_Cleanup_Actions might reset the location of
5311 the enclosing construct to that of an inner statement. */
5312 add_cleanup (build_call_n_expr (proc_decl
, 0),
5313 Present (End_Label (gnat_node
))
5314 ? End_Label (gnat_node
) : At_End_Proc (gnat_node
));
5317 /* Now build the tree for the declarations and statements inside this block.
5318 If this is SJLJ, set our jmp_buf as the current buffer. */
5319 start_stmt_group ();
5323 gnu_expr
= build_call_n_expr (set_jmpbuf_decl
, 1,
5324 build_unary_op (ADDR_EXPR
, NULL_TREE
,
5326 set_expr_location_from_node (gnu_expr
, gnat_node
);
5327 add_stmt (gnu_expr
);
5330 if (Present (First_Real_Statement (gnat_node
)))
5331 process_decls (Statements (gnat_node
), Empty
,
5332 First_Real_Statement (gnat_node
), true, true);
5334 /* Generate code for each statement in the block. */
5335 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
5336 ? First_Real_Statement (gnat_node
)
5337 : First (Statements (gnat_node
)));
5338 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
5339 add_stmt (gnat_to_gnu (gnat_temp
));
5341 gnu_inner_block
= end_stmt_group ();
5343 /* Now generate code for the two exception models, if either is relevant for
5347 tree
*gnu_else_ptr
= 0;
5350 /* Make a binding level for the exception handling declarations and code
5351 and set up gnu_except_ptr_stack for the handlers to use. */
5352 start_stmt_group ();
5355 vec_safe_push (gnu_except_ptr_stack
,
5356 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
5357 build_pointer_type (except_type_node
),
5358 build_call_n_expr (get_excptr_decl
, 0),
5359 false, false, false, false, false,
5360 true, false, NULL
, gnat_node
));
5362 /* Generate code for each handler. The N_Exception_Handler case does the
5363 real work and returns a COND_EXPR for each handler, which we chain
5365 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
5366 Present (gnat_temp
); gnat_temp
= Next_Non_Pragma (gnat_temp
))
5368 gnu_expr
= gnat_to_gnu (gnat_temp
);
5370 /* If this is the first one, set it as the outer one. Otherwise,
5371 point the "else" part of the previous handler to us. Then point
5372 to our "else" part. */
5374 add_stmt (gnu_expr
);
5376 *gnu_else_ptr
= gnu_expr
;
5378 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
5381 /* If none of the exception handlers did anything, re-raise but do not
5383 gnu_expr
= build_call_n_expr (raise_nodefer_decl
, 1,
5384 gnu_except_ptr_stack
->last ());
5385 set_expr_location_from_node
5387 Present (End_Label (gnat_node
)) ? End_Label (gnat_node
) : gnat_node
);
5390 *gnu_else_ptr
= gnu_expr
;
5392 add_stmt (gnu_expr
);
5394 /* End the binding level dedicated to the exception handlers and get the
5395 whole statement group. */
5396 gnu_except_ptr_stack
->pop ();
5398 gnu_handler
= end_stmt_group ();
5400 /* If the setjmp returns 1, we restore our incoming longjmp value and
5401 then check the handlers. */
5402 start_stmt_group ();
5403 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl
, 1,
5406 add_stmt (gnu_handler
);
5407 gnu_handler
= end_stmt_group ();
5409 /* This block is now "if (setjmp) ... <handlers> else <block>". */
5410 gnu_result
= build3 (COND_EXPR
, void_type_node
,
5413 build_unary_op (ADDR_EXPR
, NULL_TREE
,
5415 gnu_handler
, gnu_inner_block
);
5422 /* First make a block containing the handlers. */
5423 start_stmt_group ();
5424 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
5425 Present (gnat_temp
);
5426 gnat_temp
= Next_Non_Pragma (gnat_temp
))
5427 add_stmt (gnat_to_gnu (gnat_temp
));
5428 gnu_handlers
= end_stmt_group ();
5430 /* Now make the TRY_CATCH_EXPR for the block. */
5431 gnu_result
= build2 (TRY_CATCH_EXPR
, void_type_node
,
5432 gnu_inner_block
, gnu_handlers
);
5433 /* Set a location. We need to find a unique location for the dispatching
5434 code, otherwise we can get coverage or debugging issues. Try with
5435 the location of the end label. */
5436 if (Present (End_Label (gnat_node
))
5437 && Sloc_to_locus (Sloc (End_Label (gnat_node
)), &locus
))
5438 SET_EXPR_LOCATION (gnu_result
, locus
);
5440 /* Clear column information so that the exception handler of an
5441 implicit transient block does not incorrectly inherit the slocs
5442 of a decision, which would otherwise confuse control flow based
5443 coverage analysis tools. */
5444 set_expr_location_from_node (gnu_result
, gnat_node
, true);
5447 gnu_result
= gnu_inner_block
;
5449 /* Now close our outer block, if we had to make one. */
5450 if (binding_for_block
)
5452 add_stmt (gnu_result
);
5454 gnu_result
= end_stmt_group ();
5460 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5461 to a GCC tree, which is returned. This is the variant for front-end sjlj
5462 exception handling. */
5465 Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node
)
5467 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
5468 an "if" statement to select the proper exceptions. For "Others", exclude
5469 exceptions where Handled_By_Others is nonzero unless the All_Others flag
5470 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
5471 tree gnu_choice
= boolean_false_node
;
5472 tree gnu_body
= build_stmt_group (Statements (gnat_node
), false);
5475 for (gnat_temp
= First (Exception_Choices (gnat_node
));
5476 gnat_temp
; gnat_temp
= Next (gnat_temp
))
5480 if (Nkind (gnat_temp
) == N_Others_Choice
)
5482 if (All_Others (gnat_temp
))
5483 this_choice
= boolean_true_node
;
5487 (EQ_EXPR
, boolean_type_node
,
5492 (INDIRECT_REF
, NULL_TREE
,
5493 gnu_except_ptr_stack
->last ()),
5494 not_handled_by_others_decl
,
5499 else if (Nkind (gnat_temp
) == N_Identifier
5500 || Nkind (gnat_temp
) == N_Expanded_Name
)
5502 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
5505 /* Exception may be a renaming. Recover original exception which is
5506 the one elaborated and registered. */
5507 if (Present (Renamed_Object (gnat_ex_id
)))
5508 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
5510 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, false);
5514 (EQ_EXPR
, boolean_type_node
,
5515 gnu_except_ptr_stack
->last (),
5516 convert (TREE_TYPE (gnu_except_ptr_stack
->last ()),
5517 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
5522 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
5523 gnu_choice
, this_choice
);
5526 return build3 (COND_EXPR
, void_type_node
, gnu_choice
, gnu_body
, NULL_TREE
);
5529 /* Return true if no statement in GNAT_LIST can alter the control flow. */
5532 stmt_list_cannot_alter_control_flow_p (List_Id gnat_list
)
5537 /* This is very conservative, we reject everything except for simple
5538 assignments between identifiers or literals. */
5539 for (Node_Id gnat_node
= First (gnat_list
);
5540 Present (gnat_node
);
5541 gnat_node
= Next (gnat_node
))
5543 if (Nkind (gnat_node
) != N_Assignment_Statement
)
5546 if (Nkind (Name (gnat_node
)) != N_Identifier
)
5549 Node_Kind nkind
= Nkind (Expression (gnat_node
));
5550 if (nkind
!= N_Identifier
5551 && nkind
!= N_Integer_Literal
5552 && nkind
!= N_Real_Literal
)
5559 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5560 to a GCC tree, which is returned. This is the variant for GCC exception
5564 Exception_Handler_to_gnu_gcc (Node_Id gnat_node
)
5566 tree gnu_etypes_list
= NULL_TREE
;
5568 /* We build a TREE_LIST of nodes representing what exception types this
5569 handler can catch, with special cases for others and all others cases.
5571 Each exception type is actually identified by a pointer to the exception
5572 id, or to a dummy object for "others" and "all others". */
5573 for (Node_Id gnat_temp
= First (Exception_Choices (gnat_node
));
5575 gnat_temp
= Next (gnat_temp
))
5577 tree gnu_expr
, gnu_etype
;
5579 if (Nkind (gnat_temp
) == N_Others_Choice
)
5581 gnu_expr
= All_Others (gnat_temp
) ? all_others_decl
: others_decl
;
5582 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
5584 else if (Nkind (gnat_temp
) == N_Identifier
5585 || Nkind (gnat_temp
) == N_Expanded_Name
)
5587 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
5589 /* Exception may be a renaming. Recover original exception which is
5590 the one elaborated and registered. */
5591 if (Present (Renamed_Object (gnat_ex_id
)))
5592 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
5594 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, false);
5595 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
5600 /* The GCC interface expects NULL to be passed for catch all handlers, so
5601 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
5602 is integer_zero_node. It would not work, however, because GCC's
5603 notion of "catch all" is stronger than our notion of "others". Until
5604 we correctly use the cleanup interface as well, doing that would
5605 prevent the "all others" handlers from being seen, because nothing
5606 can be caught beyond a catch all from GCC's point of view. */
5607 gnu_etypes_list
= tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
5610 start_stmt_group ();
5613 /* Expand a call to the begin_handler hook at the beginning of the
5614 handler, and arrange for a call to the end_handler hook to occur
5615 on every possible exit path. GDB sets a breakpoint in the
5616 begin_handler for catchpoints.
5618 A v1 begin handler saves the cleanup from the exception object,
5619 and marks the exception as in use, so that it will not be
5620 released by other handlers. A v1 end handler restores the
5621 cleanup and releases the exception object, unless it is still
5622 claimed, or the exception is being propagated (reraised).
5624 __builtin_eh_pointer references the exception occurrence being
5625 handled or propagated. Within the handler region, it is the
5626 former, but within the else branch of the EH_ELSE_EXPR, i.e. the
5627 exceptional cleanup path, it is the latter, so we must save the
5628 occurrence being handled early on, so that, should an exception
5629 be (re)raised, we can release the current exception, or figure
5630 out we're not to release it because we're propagating a reraise
5633 We use local variables to retrieve the incoming value at handler
5634 entry time (EXPTR), the saved cleanup (EXCLN) and the token
5635 (EXVTK), and reuse them to feed the end_handler hook's argument
5638 /* CODE: void *EXPTR = __builtin_eh_pointer (0); */
5639 tree gnu_current_exc_ptr
5640 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
5641 1, integer_zero_node
);
5643 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
5644 ptr_type_node
, gnu_current_exc_ptr
,
5645 true, false, false, false, false, true, true,
5648 tree prev_gnu_incoming_exc_ptr
= gnu_incoming_exc_ptr
;
5649 gnu_incoming_exc_ptr
= exc_ptr
;
5651 /* begin_handler_decl must not throw, so we can use it as an
5652 initializer for a variable used in cleanups.
5654 CODE: void *EXCLN = __gnat_begin_handler_v1 (EXPTR); */
5656 = create_var_decl (get_identifier ("EXCLN"), NULL_TREE
,
5658 build_call_n_expr (begin_handler_decl
, 1,
5660 true, false, false, false, false,
5661 true, true, NULL
, gnat_node
);
5663 /* Declare and initialize the choice parameter, if present. */
5664 if (Present (Choice_Parameter (gnat_node
)))
5667 = gnat_to_gnu_entity (Choice_Parameter (gnat_node
), NULL_TREE
, true);
5669 /* CODE: __gnat_set_exception_parameter (&choice_param, EXPTR); */
5670 add_stmt (build_call_n_expr
5671 (set_exception_parameter_decl
, 2,
5672 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_param
),
5673 gnu_incoming_exc_ptr
));
5676 /* CODE: <handler proper> */
5677 add_stmt_list (Statements (gnat_node
));
5679 tree call
= build_call_n_expr (end_handler_decl
, 3,
5683 /* If the handler can only end by falling off the end, don't bother
5685 if (stmt_list_cannot_alter_control_flow_p (Statements (gnat_node
)))
5686 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, NULL); */
5687 add_stmt_with_node (call
, gnat_node
);
5688 /* Otherwise, all of the above is after
5691 The call above will appear after
5694 And the code below will appear after
5697 The else block to a finally block is taken instead of the finally
5698 block when an exception propagates out of the try block. */
5701 start_stmt_group ();
5703 /* CODE: void *EXPRP = __builtin_eh_handler (0); */
5705 = create_var_decl (get_identifier ("EXPRP"), NULL_TREE
,
5707 build_call_expr (builtin_decl_explicit
5708 (BUILT_IN_EH_POINTER
),
5709 1, integer_zero_node
),
5710 true, false, false, false, false,
5711 true, true, NULL
, gnat_node
);
5713 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, EXPRP); */
5714 tree ecall
= build_call_n_expr (end_handler_decl
, 3,
5719 add_stmt_with_node (ecall
, gnat_node
);
5723 tree eblk
= end_stmt_group ();
5724 tree ehls
= build2 (EH_ELSE_EXPR
, void_type_node
, call
, eblk
);
5725 add_cleanup (ehls
, gnat_node
);
5730 gnu_incoming_exc_ptr
= prev_gnu_incoming_exc_ptr
;
5733 build2 (CATCH_EXPR
, void_type_node
, gnu_etypes_list
, end_stmt_group ());
5736 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
5739 Compilation_Unit_to_gnu (Node_Id gnat_node
)
5741 const Node_Id gnat_unit
= Unit (gnat_node
);
5742 const bool body_p
= (Nkind (gnat_unit
) == N_Package_Body
5743 || Nkind (gnat_unit
) == N_Subprogram_Body
);
5744 const Entity_Id gnat_unit_entity
= Defining_Entity (gnat_unit
);
5745 Entity_Id gnat_entity
;
5746 Node_Id gnat_pragma
, gnat_iter
;
5747 /* Make the decl for the elaboration procedure. Emit debug info for it, so
5748 that users can break into their elaboration code in debuggers. Kludge:
5749 don't consider it as a definition so that we have a line map for its
5750 body, but no subprogram description in debug info. In addition, don't
5751 qualify it as artificial, even though it is not a user subprogram per se,
5752 in particular for specs. Unlike, say, clones created internally by the
5753 compiler, this subprogram materializes specific user code and flagging it
5754 artificial would take elab code away from gcov's analysis. */
5755 tree gnu_elab_proc_decl
5756 = create_subprog_decl
5757 (create_concat_name (gnat_unit_entity
, body_p
? "elabb" : "elabs"),
5758 NULL_TREE
, void_ftype
, NULL_TREE
,
5759 is_default
, true, false, false, true, false, NULL
, gnat_unit
);
5760 struct elab_info
*info
;
5762 vec_safe_push (gnu_elab_proc_stack
, gnu_elab_proc_decl
);
5763 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl
) = 1;
5765 /* Initialize the information structure for the function. */
5766 allocate_struct_function (gnu_elab_proc_decl
, false);
5769 current_function_decl
= NULL_TREE
;
5771 start_stmt_group ();
5774 /* For a body, first process the spec if there is one. */
5775 if (Nkind (gnat_unit
) == N_Package_Body
5776 || (Nkind (gnat_unit
) == N_Subprogram_Body
&& !Acts_As_Spec (gnat_node
)))
5777 add_stmt (gnat_to_gnu (Library_Unit (gnat_node
)));
5779 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
5781 elaborate_all_entities (gnat_node
);
5783 if (Nkind (gnat_unit
) == N_Subprogram_Declaration
5784 || Nkind (gnat_unit
) == N_Generic_Package_Declaration
5785 || Nkind (gnat_unit
) == N_Generic_Subprogram_Declaration
)
5789 /* Then process any pragmas and declarations preceding the unit. */
5790 for (gnat_pragma
= First (Context_Items (gnat_node
));
5791 Present (gnat_pragma
);
5792 gnat_pragma
= Next (gnat_pragma
))
5793 if (Nkind (gnat_pragma
) == N_Pragma
)
5794 add_stmt (gnat_to_gnu (gnat_pragma
));
5795 process_decls (Declarations (Aux_Decls_Node (gnat_node
)), Empty
, Empty
,
5798 /* Process the unit itself. */
5799 add_stmt (gnat_to_gnu (gnat_unit
));
5801 /* Generate code for all the inlined subprograms. */
5802 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
5803 Present (gnat_entity
);
5804 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
5808 /* Without optimization, process only the required subprograms. */
5809 if (!optimize
&& !Has_Pragma_Inline_Always (gnat_entity
))
5812 /* The set of inlined subprograms is computed from data recorded early
5813 during expansion and it can be a strict superset of the final set
5814 computed after semantic analysis, for example if a call to such a
5815 subprogram occurs in a pragma Assert and assertions are disabled.
5816 In that case, semantic analysis resets Is_Public to false but the
5817 entry for the subprogram in the inlining tables is stalled. */
5818 if (!Is_Public (gnat_entity
))
5821 gnat_body
= Parent (Declaration_Node (gnat_entity
));
5822 if (Nkind (gnat_body
) != N_Subprogram_Body
)
5824 /* ??? This happens when only the spec of a package is provided. */
5825 if (No (Corresponding_Body (gnat_body
)))
5829 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
5832 /* Define the entity first so we set DECL_EXTERNAL. */
5833 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
5834 add_stmt (gnat_to_gnu (gnat_body
));
5837 /* Process any pragmas and actions following the unit. */
5838 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node
)));
5839 add_stmt_list (Actions (Aux_Decls_Node (gnat_node
)));
5840 finalize_from_limited_with ();
5842 /* Then process the expressions of pragma Compile_Time_{Error|Warning} to
5843 annotate types referenced therein if they have not been annotated. */
5844 for (int i
= 0; gnat_compile_time_expr_list
.iterate (i
, &gnat_iter
); i
++)
5845 (void) gnat_to_gnu_external (gnat_iter
);
5846 gnat_compile_time_expr_list
.release ();
5848 /* Save away what we've made so far and finish it up. */
5849 set_current_block_context (gnu_elab_proc_decl
);
5851 DECL_SAVED_TREE (gnu_elab_proc_decl
) = end_stmt_group ();
5852 set_end_locus_from_node (gnu_elab_proc_decl
, gnat_unit
);
5853 gnu_elab_proc_stack
->pop ();
5855 /* Record this potential elaboration procedure for later processing. */
5856 info
= ggc_alloc
<elab_info
> ();
5857 info
->next
= elab_info_list
;
5858 info
->elab_proc
= gnu_elab_proc_decl
;
5859 info
->gnat_node
= gnat_node
;
5860 elab_info_list
= info
;
5862 /* Force the processing for all nodes that remain in the queue. */
5863 process_deferred_decl_context (true);
5866 /* Mark COND, a boolean expression, as predicating a call to a noreturn
5867 function, i.e. predict that it is very likely false, and return it.
5869 The compiler will automatically predict the last edge leading to a call
5870 to a noreturn function as very unlikely taken. This function makes it
5871 possible to extend the prediction to predecessors in case the condition
5872 is made up of several short-circuit operators. */
5875 build_noreturn_cond (tree cond
)
5877 tree pred_cst
= build_int_cst (integer_type_node
, PRED_NORETURN
);
5879 build_call_expr_internal_loc (UNKNOWN_LOCATION
, IFN_BUILTIN_EXPECT
,
5880 boolean_type_node
, 3, cond
,
5881 boolean_false_node
, pred_cst
);
5884 /* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a
5885 range of values, into GNU_LOW and GNU_HIGH bounds. */
5888 Range_to_gnu (Node_Id gnat_range
, tree
*gnu_low
, tree
*gnu_high
)
5890 /* GNAT_RANGE is either an N_Range or an identifier denoting a subtype. */
5891 switch (Nkind (gnat_range
))
5894 *gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
5895 *gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
5898 case N_Expanded_Name
:
5901 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
5902 tree gnu_range_base_type
= get_base_type (gnu_range_type
);
5905 = convert (gnu_range_base_type
, TYPE_MIN_VALUE (gnu_range_type
));
5907 = convert (gnu_range_base_type
, TYPE_MAX_VALUE (gnu_range_type
));
5916 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
5917 to a GCC tree and return it. GNU_RESULT_TYPE_P is a pointer to where
5918 we should place the result type. */
5921 Raise_Error_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
5923 const Node_Kind kind
= Nkind (gnat_node
);
5924 const Node_Id gnat_cond
= Condition (gnat_node
);
5925 const int reason
= UI_To_Int (Reason (gnat_node
));
5926 const bool with_extra_info
5927 = Exception_Extra_Info
5928 && !No_Exception_Handlers_Set ()
5929 && No (get_exception_label (kind
));
5930 tree gnu_result
= NULL_TREE
, gnu_cond
= NULL_TREE
;
5933 /* The following processing is not required for correctness. Its purpose is
5934 to give more precise error messages and to record some information. */
5937 case CE_Access_Check_Failed
:
5938 if (with_extra_info
)
5939 gnu_result
= build_call_raise_column (reason
, gnat_node
, kind
);
5942 case CE_Index_Check_Failed
:
5943 case CE_Range_Check_Failed
:
5944 case CE_Invalid_Data
:
5945 if (No (gnat_cond
) || Nkind (gnat_cond
) != N_Op_Not
)
5947 gnat_rcond
= Right_Opnd (gnat_cond
);
5948 if (Nkind (gnat_rcond
) == N_In
5949 || Nkind (gnat_rcond
) == N_Op_Ge
5950 || Nkind (gnat_rcond
) == N_Op_Le
)
5952 const Node_Id gnat_index
= Left_Opnd (gnat_rcond
);
5953 const Node_Id gnat_type
= Etype (gnat_index
);
5954 tree gnu_index
= gnat_to_gnu (gnat_index
);
5955 tree gnu_type
= get_unpadded_type (gnat_type
);
5956 tree gnu_low_bound
, gnu_high_bound
, disp
;
5957 struct loop_info_d
*loop
;
5960 switch (Nkind (gnat_rcond
))
5963 Range_to_gnu (Right_Opnd (gnat_rcond
),
5964 &gnu_low_bound
, &gnu_high_bound
);
5968 gnu_low_bound
= gnat_to_gnu (Right_Opnd (gnat_rcond
));
5969 gnu_high_bound
= TYPE_MAX_VALUE (gnu_type
);
5973 gnu_low_bound
= TYPE_MIN_VALUE (gnu_type
);
5974 gnu_high_bound
= gnat_to_gnu (Right_Opnd (gnat_rcond
));
5981 gnu_type
= maybe_character_type (gnu_type
);
5982 if (TREE_TYPE (gnu_index
) != gnu_type
)
5984 gnu_low_bound
= convert (gnu_type
, gnu_low_bound
);
5985 gnu_high_bound
= convert (gnu_type
, gnu_high_bound
);
5986 gnu_index
= convert (gnu_type
, gnu_index
);
5990 && Known_Esize (gnat_type
)
5991 && UI_To_Int (Esize (gnat_type
)) <= 32)
5993 = build_call_raise_range (reason
, gnat_node
, kind
, gnu_index
,
5994 gnu_low_bound
, gnu_high_bound
);
5996 /* If optimization is enabled and we are inside a loop, we try to
5997 compute invariant conditions for checks applied to the iteration
5998 variable, i.e. conditions that are independent of the variable
5999 and necessary in order for the checks to fail in the course of
6000 some iteration. If we succeed, we consider an alternative:
6002 1. If loop unswitching is enabled, we prepend these conditions
6003 to the original conditions of the checks. This will make it
6004 possible for the loop unswitching pass to replace the loop
6005 with two loops, one of which has the checks eliminated and
6006 the other has the original checks reinstated, and a prologue
6007 implementing a run-time selection. The former loop will be
6008 for example suitable for vectorization.
6010 2. Otherwise, we instead append the conditions to the original
6011 conditions of the checks. At worse, if the conditions cannot
6012 be evaluated at compile time, they will be evaluated as true
6013 at run time only when the checks have already failed, thus
6014 contributing negatively only to the size of the executable.
6015 But the hope is that these invariant conditions be evaluated
6016 at compile time to false, thus taking away the entire checks
6021 || (gnu_low_bound
= gnat_invariant_expr (gnu_low_bound
)))
6023 || (gnu_high_bound
= gnat_invariant_expr (gnu_high_bound
)))
6024 && (loop
= find_loop_for (gnu_index
, &disp
, &neg_p
)))
6026 struct range_check_info_d
*rci
= ggc_alloc
<range_check_info_d
> ();
6027 rci
->low_bound
= gnu_low_bound
;
6028 rci
->high_bound
= gnu_high_bound
;
6031 rci
->type
= gnu_type
;
6033 = build1 (SAVE_EXPR
, boolean_type_node
, boolean_true_node
);
6034 vec_safe_push (loop
->checks
, rci
);
6035 gnu_cond
= build_noreturn_cond (gnat_to_gnu (gnat_cond
));
6037 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6042 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6045 rci
->inserted_cond
);
6054 /* The following processing does the real work, but we must nevertheless make
6055 sure not to override the result of the previous processing. */
6057 gnu_result
= build_call_raise (reason
, gnat_node
, kind
);
6058 set_expr_location_from_node (gnu_result
, gnat_node
);
6060 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
6062 /* If the type is VOID, this is a statement, so we need to generate the code
6063 for the call. Handle a condition, if there is one. */
6064 if (VOID_TYPE_P (*gnu_result_type_p
))
6066 if (Present (gnat_cond
))
6069 gnu_cond
= gnat_to_gnu (gnat_cond
);
6070 gnu_result
= build3 (COND_EXPR
, void_type_node
, gnu_cond
, gnu_result
,
6071 alloc_stmt_list ());
6075 gnu_result
= build1 (NULL_EXPR
, *gnu_result_type_p
, gnu_result
);
6080 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
6081 parameter of a call. */
6084 lhs_or_actual_p (Node_Id gnat_node
)
6086 const Node_Id gnat_parent
= Parent (gnat_node
);
6087 const Node_Kind kind
= Nkind (gnat_parent
);
6089 if (kind
== N_Assignment_Statement
&& Name (gnat_parent
) == gnat_node
)
6092 if ((kind
== N_Procedure_Call_Statement
|| kind
== N_Function_Call
)
6093 && Name (gnat_parent
) != gnat_node
)
6096 if (kind
== N_Parameter_Association
)
6102 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
6103 of an assignment or an actual parameter of a call. */
6106 present_in_lhs_or_actual_p (Node_Id gnat_node
)
6108 if (lhs_or_actual_p (gnat_node
))
6111 const Node_Kind kind
= Nkind (Parent (gnat_node
));
6113 if ((kind
== N_Type_Conversion
|| kind
== N_Unchecked_Type_Conversion
)
6114 && lhs_or_actual_p (Parent (gnat_node
)))
6120 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
6121 as gigi is concerned. This is used to avoid conversions on the LHS. */
6124 unchecked_conversion_nop (Node_Id gnat_node
)
6126 Entity_Id from_type
, to_type
;
6128 /* The conversion must be on the LHS of an assignment or an actual parameter
6129 of a call. Otherwise, even if the conversion was essentially a no-op, it
6130 could de facto ensure type consistency and this should be preserved. */
6131 if (!lhs_or_actual_p (gnat_node
))
6134 from_type
= Etype (Expression (gnat_node
));
6136 /* We're interested in artificial conversions generated by the front-end
6137 to make private types explicit, e.g. in Expand_Assign_Array. */
6138 if (!Is_Private_Type (from_type
))
6141 from_type
= Underlying_Type (from_type
);
6142 to_type
= Etype (gnat_node
);
6144 /* The direct conversion to the underlying type is a no-op. */
6145 if (to_type
== from_type
)
6148 /* For an array subtype, the conversion to the PAIT is a no-op. */
6149 if (Ekind (from_type
) == E_Array_Subtype
6150 && to_type
== Packed_Array_Impl_Type (from_type
))
6153 /* For a record subtype, the conversion to the type is a no-op. */
6154 if (Ekind (from_type
) == E_Record_Subtype
6155 && to_type
== Etype (from_type
))
6161 /* Return true if GNAT_NODE represents a statement. */
6164 statement_node_p (Node_Id gnat_node
)
6166 const Node_Kind kind
= Nkind (gnat_node
);
6168 if (kind
== N_Label
)
6171 if (IN (kind
, N_Statement_Other_Than_Procedure_Call
))
6174 if (kind
== N_Procedure_Call_Statement
)
6177 if (IN (kind
, N_Raise_xxx_Error
) && Ekind (Etype (gnat_node
)) == E_Void
)
6183 /* This function is the driver of the GNAT to GCC tree transformation process.
6184 It is the entry point of the tree transformer. GNAT_NODE is the root of
6185 some GNAT tree. Return the root of the corresponding GCC tree. If this
6186 is an expression, return the GCC equivalent of the expression. If this
6187 is a statement, return the statement or add it to the current statement
6188 group, in which case anything returned is to be interpreted as occurring
6189 after anything added. */
6192 gnat_to_gnu (Node_Id gnat_node
)
6194 const Node_Kind kind
= Nkind (gnat_node
);
6195 bool went_into_elab_proc
= false;
6196 tree gnu_result
= error_mark_node
; /* Default to no value. */
6197 tree gnu_result_type
= void_type_node
;
6198 tree gnu_expr
, gnu_lhs
, gnu_rhs
;
6200 atomic_acces_t aa_type
;
6203 /* Save node number for error message and set location information. */
6204 Current_Error_Node
= gnat_node
;
6205 Sloc_to_locus (Sloc (gnat_node
), &input_location
);
6207 /* If we are only annotating types and this node is a statement, return
6208 an empty statement list. */
6209 if (type_annotate_only
&& statement_node_p (gnat_node
))
6210 return alloc_stmt_list ();
6212 /* If we are only annotating types and this node is a subexpression, return
6213 a NULL_EXPR, but filter out nodes appearing in the expressions attached
6214 to packed array implementation types. */
6215 if (type_annotate_only
6216 && IN (kind
, N_Subexpr
)
6217 && !(((IN (kind
, N_Op
) && kind
!= N_Op_Expon
)
6218 || kind
== N_Type_Conversion
)
6219 && Is_Integer_Type (Etype (gnat_node
)))
6220 && !(kind
== N_Attribute_Reference
6221 && (Get_Attribute_Id (Attribute_Name (gnat_node
)) == Attr_Length
6222 || Get_Attribute_Id (Attribute_Name (gnat_node
)) == Attr_Size
)
6223 && Is_Constrained (Etype (Prefix (gnat_node
)))
6224 && !Is_Constr_Subt_For_U_Nominal (Etype (Prefix (gnat_node
))))
6225 && kind
!= N_Expanded_Name
6226 && kind
!= N_Identifier
6227 && !Compile_Time_Known_Value (gnat_node
))
6228 return build1 (NULL_EXPR
, get_unpadded_type (Etype (gnat_node
)),
6229 build_call_raise (CE_Range_Check_Failed
, gnat_node
,
6230 N_Raise_Constraint_Error
));
6232 if ((statement_node_p (gnat_node
) && kind
!= N_Null_Statement
)
6233 || kind
== N_Handled_Sequence_Of_Statements
6234 || kind
== N_Implicit_Label_Declaration
)
6236 tree current_elab_proc
= get_elaboration_procedure ();
6238 /* If this is a statement and we are at top level, it must be part of
6239 the elaboration procedure, so mark us as being in that procedure. */
6240 if (!current_function_decl
)
6242 current_function_decl
= current_elab_proc
;
6243 went_into_elab_proc
= true;
6246 /* If we are in the elaboration procedure, check if we are violating a
6247 No_Elaboration_Code restriction by having a statement there. Don't
6248 check for a possible No_Elaboration_Code restriction violation on
6249 N_Handled_Sequence_Of_Statements, as we want to signal an error on
6250 every nested real statement instead. This also avoids triggering
6251 spurious errors on dummy (empty) sequences created by the front-end
6252 for package bodies in some cases. */
6253 if (current_function_decl
== current_elab_proc
6254 && kind
!= N_Handled_Sequence_Of_Statements
6255 && kind
!= N_Implicit_Label_Declaration
)
6256 Check_Elaboration_Code_Allowed (gnat_node
);
6261 /********************************/
6262 /* Chapter 2: Lexical Elements */
6263 /********************************/
6266 case N_Expanded_Name
:
6267 case N_Operator_Symbol
:
6268 case N_Defining_Identifier
:
6269 case N_Defining_Operator_Symbol
:
6270 gnu_result
= Identifier_to_gnu (gnat_node
, &gnu_result_type
);
6272 /* If atomic access is required on the RHS, build the atomic load. */
6273 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6274 && !present_in_lhs_or_actual_p (gnat_node
))
6275 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6278 case N_Integer_Literal
:
6282 /* Get the type of the result, looking inside any padding and
6283 justified modular types. Then get the value in that type. */
6284 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6286 if (TREE_CODE (gnu_type
) == RECORD_TYPE
6287 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
6288 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
6290 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
6292 /* If the result overflows (meaning it doesn't fit in its base type),
6293 abort, unless this is for a named number because that's not fatal.
6294 We would like to check that the value is within the range of the
6295 subtype, but that causes problems with subtypes whose usage will
6296 raise Constraint_Error and also with biased representation. */
6297 if (TREE_OVERFLOW (gnu_result
))
6299 if (Nkind (Parent (gnat_node
)) == N_Number_Declaration
)
6300 gnu_result
= error_mark_node
;
6307 case N_Character_Literal
:
6308 /* If a Entity is present, it means that this was one of the
6309 literals in a user-defined character type. In that case,
6310 just return the value in the CONST_DECL. Otherwise, use the
6311 character code. In that case, the base type should be an
6312 INTEGER_TYPE, but we won't bother checking for that. */
6313 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6314 if (Present (Entity (gnat_node
)))
6315 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
6318 = build_int_cst (gnu_result_type
,
6319 UI_To_CC (Char_Literal_Value (gnat_node
)));
6322 case N_Real_Literal
:
6323 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6325 /* If this is of a fixed-point type, the value we want is the value of
6326 the corresponding integer. */
6327 if (Is_Fixed_Point_Type (Underlying_Type (Etype (gnat_node
))))
6329 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
6331 gcc_assert (!TREE_OVERFLOW (gnu_result
));
6336 Ureal ur_realval
= Realval (gnat_node
);
6338 /* First convert the value to a machine number if it isn't already.
6339 That will force the base to 2 for non-zero values and simplify
6340 the rest of the logic. */
6341 if (!Is_Machine_Number (gnat_node
))
6343 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
6344 ur_realval
, Round_Even
, gnat_node
);
6346 if (UR_Is_Zero (ur_realval
))
6347 gnu_result
= build_real (gnu_result_type
, dconst0
);
6350 REAL_VALUE_TYPE tmp
;
6352 gnu_result
= UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
6354 /* The base must be 2 as Machine guarantees this, so we scale
6355 the value, which we know can fit in the mantissa of the type
6356 (hence the use of that type above). */
6357 gcc_assert (Rbase (ur_realval
) == 2);
6358 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
6359 - UI_To_Int (Denominator (ur_realval
)));
6360 gnu_result
= build_real (gnu_result_type
, tmp
);
6363 /* Now see if we need to negate the result. Do it this way to
6364 properly handle -0. */
6365 if (UR_Is_Negative (Realval (gnat_node
)))
6367 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
6373 case N_String_Literal
:
6374 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6375 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
6377 String_Id gnat_string
= Strval (gnat_node
);
6378 int length
= String_Length (gnat_string
);
6381 if (length
>= ALLOCA_THRESHOLD
)
6382 string
= XNEWVEC (char, length
);
6384 string
= (char *) alloca (length
);
6386 /* Build the string with the characters in the literal. Note
6387 that Ada strings are 1-origin. */
6388 for (i
= 0; i
< length
; i
++)
6389 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
6391 gnu_result
= build_string (length
, string
);
6393 /* Strings in GCC don't normally have types, but we want
6394 this to not be converted to the array type. */
6395 TREE_TYPE (gnu_result
) = gnu_result_type
;
6397 if (length
>= ALLOCA_THRESHOLD
)
6402 /* Build a list consisting of each character, then make
6404 String_Id gnat_string
= Strval (gnat_node
);
6405 int length
= String_Length (gnat_string
);
6407 tree gnu_idx
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
6408 tree gnu_one_node
= convert (TREE_TYPE (gnu_idx
), integer_one_node
);
6409 vec
<constructor_elt
, va_gc
> *gnu_vec
;
6410 vec_alloc (gnu_vec
, length
);
6412 for (i
= 0; i
< length
; i
++)
6414 tree t
= build_int_cst (TREE_TYPE (gnu_result_type
),
6415 Get_String_Char (gnat_string
, i
+ 1));
6417 CONSTRUCTOR_APPEND_ELT (gnu_vec
, gnu_idx
, t
);
6418 gnu_idx
= int_const_binop (PLUS_EXPR
, gnu_idx
, gnu_one_node
);
6421 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
6426 gnu_result
= Pragma_to_gnu (gnat_node
);
6429 /**************************************/
6430 /* Chapter 3: Declarations and Types */
6431 /**************************************/
6433 case N_Subtype_Declaration
:
6434 case N_Full_Type_Declaration
:
6435 case N_Incomplete_Type_Declaration
:
6436 case N_Private_Type_Declaration
:
6437 case N_Private_Extension_Declaration
:
6438 case N_Task_Type_Declaration
:
6439 process_type (Defining_Entity (gnat_node
));
6440 gnu_result
= alloc_stmt_list ();
6443 case N_Object_Declaration
:
6444 case N_Number_Declaration
:
6445 case N_Exception_Declaration
:
6446 gnat_temp
= Defining_Entity (gnat_node
);
6447 gnu_result
= alloc_stmt_list ();
6449 /* If we are just annotating types and this object has an unconstrained
6450 or task type, don't elaborate it. */
6451 if (type_annotate_only
6452 && (((Is_Array_Type (Etype (gnat_temp
))
6453 || Is_Record_Type (Etype (gnat_temp
)))
6454 && !Is_Constrained (Etype (gnat_temp
)))
6455 || Is_Concurrent_Type (Etype (gnat_temp
))))
6458 if (Present (Expression (gnat_node
))
6459 && !(kind
== N_Object_Declaration
&& No_Initialization (gnat_node
))
6460 && (!type_annotate_only
6461 || Compile_Time_Known_Value (Expression (gnat_node
))))
6463 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node
)));
6465 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
6467 /* First deal with erroneous expressions. */
6468 if (TREE_CODE (gnu_expr
) == ERROR_MARK
)
6470 /* If this is a named number for which we cannot manipulate
6471 the value, just skip the declaration altogether. */
6472 if (kind
== N_Number_Declaration
)
6474 else if (type_annotate_only
)
6475 gnu_expr
= NULL_TREE
;
6478 /* Then a special case: we do not want the SLOC of the expression
6479 of the tag to pop up every time it is referenced somewhere. */
6480 else if (EXPR_P (gnu_expr
) && Is_Tag (gnat_temp
))
6481 SET_EXPR_LOCATION (gnu_expr
, UNKNOWN_LOCATION
);
6484 gnu_expr
= NULL_TREE
;
6486 /* If this is a deferred constant with an address clause, we ignore the
6487 full view since the clause is on the partial view and we cannot have
6488 2 different GCC trees for the object. The only bits of the full view
6489 we will use is the initializer, but it will be directly fetched. */
6490 if (Ekind (gnat_temp
) == E_Constant
6491 && Present (Address_Clause (gnat_temp
))
6492 && Present (Full_View (gnat_temp
)))
6493 save_gnu_tree (Full_View (gnat_temp
), error_mark_node
, true);
6495 /* If this object has its elaboration delayed, we must force evaluation
6496 of GNU_EXPR now and save it for the freeze point. Note that we need
6497 not do anything special at the global level since the lifetime of the
6498 temporary is fully contained within the elaboration routine. */
6499 if (Present (Freeze_Node (gnat_temp
)))
6503 gnu_result
= gnat_save_expr (gnu_expr
);
6504 save_gnu_tree (gnat_node
, gnu_result
, true);
6508 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, true);
6511 case N_Object_Renaming_Declaration
:
6512 gnat_temp
= Defining_Entity (gnat_node
);
6513 gnu_result
= alloc_stmt_list ();
6515 /* Don't do anything if this renaming is handled by the front end and it
6516 does not need debug info. Note that we consider renamings don't need
6517 debug info when optimizing: our way to describe them has a
6518 memory/elaboration footprint.
6520 Don't do anything neither if we are just annotating types and this
6521 object has a composite or task type, don't elaborate it. */
6522 if ((!Is_Renaming_Of_Object (gnat_temp
)
6523 || (Needs_Debug_Info (gnat_temp
)
6525 && can_materialize_object_renaming_p
6526 (Renamed_Object (gnat_temp
))))
6527 && ! (type_annotate_only
6528 && (Is_Array_Type (Etype (gnat_temp
))
6529 || Is_Record_Type (Etype (gnat_temp
))
6530 || Is_Concurrent_Type (Etype (gnat_temp
)))))
6531 gnat_to_gnu_entity (gnat_temp
,
6532 gnat_to_gnu (Renamed_Object (gnat_temp
)),
6536 case N_Exception_Renaming_Declaration
:
6537 gnat_temp
= Defining_Entity (gnat_node
);
6538 gnu_result
= alloc_stmt_list ();
6540 if (Present (Renamed_Entity (gnat_temp
)))
6541 gnat_to_gnu_entity (gnat_temp
,
6542 gnat_to_gnu (Renamed_Entity (gnat_temp
)),
6546 case N_Subprogram_Renaming_Declaration
:
6548 const Node_Id gnat_renaming
= Defining_Entity (gnat_node
);
6549 const Node_Id gnat_renamed
= Renamed_Entity (gnat_renaming
);
6551 gnu_result
= alloc_stmt_list ();
6553 /* Materializing renamed subprograms will only benefit the debugging
6554 information as they aren't referenced in the generated code. So
6555 skip them when they aren't needed. Avoid doing this if:
6557 - there is a freeze node: in this case the renamed entity is not
6559 - the renamed subprogram is intrinsic: it will not be available in
6560 the debugging information (note that both or only one of the
6561 renaming and the renamed subprograms can be intrinsic). */
6562 if (!type_annotate_only
6563 && Needs_Debug_Info (gnat_renaming
)
6564 && No (Freeze_Node (gnat_renaming
))
6565 && Present (gnat_renamed
)
6566 && (Ekind (gnat_renamed
) == E_Function
6567 || Ekind (gnat_renamed
) == E_Procedure
)
6568 && !Is_Intrinsic_Subprogram (gnat_renaming
)
6569 && !Is_Intrinsic_Subprogram (gnat_renamed
))
6570 gnat_to_gnu_entity (gnat_renaming
, gnat_to_gnu (gnat_renamed
), true);
6574 case N_Implicit_Label_Declaration
:
6575 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, true);
6576 gnu_result
= alloc_stmt_list ();
6579 case N_Package_Renaming_Declaration
:
6580 /* These are fully handled in the front end. */
6581 /* ??? For package renamings, find a way to use GENERIC namespaces so
6582 that we get proper debug information for them. */
6583 gnu_result
= alloc_stmt_list ();
6586 /*************************************/
6587 /* Chapter 4: Names and Expressions */
6588 /*************************************/
6590 case N_Explicit_Dereference
:
6591 /* Make sure the designated type is complete before dereferencing. */
6592 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6593 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
6594 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
6596 /* If atomic access is required on the RHS, build the atomic load. */
6597 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6598 && !present_in_lhs_or_actual_p (gnat_node
))
6599 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6602 case N_Indexed_Component
:
6604 tree gnu_array_object
= gnat_to_gnu ((Prefix (gnat_node
)));
6607 Node_Id
*gnat_expr_array
;
6609 gnu_array_object
= maybe_padded_object (gnu_array_object
);
6610 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
6612 /* Convert vector inputs to their representative array type, to fit
6613 what the code below expects. */
6614 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object
)))
6616 if (present_in_lhs_or_actual_p (gnat_node
))
6617 gnat_mark_addressable (gnu_array_object
);
6618 gnu_array_object
= maybe_vector_array (gnu_array_object
);
6621 /* The failure of this assertion will very likely come from a missing
6622 expansion for a packed array access. */
6623 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object
)) == ARRAY_TYPE
);
6625 /* First compute the number of dimensions of the array, then
6626 fill the expression array, the order depending on whether
6627 this is a Convention_Fortran array or not. */
6628 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
6629 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
6630 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
6631 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
6634 gnat_expr_array
= XALLOCAVEC (Node_Id
, ndim
);
6636 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
6637 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
6639 i
--, gnat_temp
= Next (gnat_temp
))
6640 gnat_expr_array
[i
] = gnat_temp
;
6642 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
6644 i
++, gnat_temp
= Next (gnat_temp
))
6645 gnat_expr_array
[i
] = gnat_temp
;
6647 /* Start with the prefix and build the successive references. */
6648 gnu_result
= gnu_array_object
;
6650 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
6652 i
++, gnu_type
= TREE_TYPE (gnu_type
))
6654 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
6655 gnat_temp
= gnat_expr_array
[i
];
6656 gnu_expr
= maybe_character_value (gnat_to_gnu (gnat_temp
));
6659 = build_binary_op (ARRAY_REF
, NULL_TREE
, gnu_result
, gnu_expr
);
6662 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6664 /* If atomic access is required on the RHS, build the atomic load. */
6665 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6666 && !present_in_lhs_or_actual_p (gnat_node
))
6667 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6673 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
6675 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6677 gnu_array_object
= maybe_padded_object (gnu_array_object
);
6678 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
6680 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
6681 gnu_expr
= maybe_character_value (gnu_expr
);
6683 /* If this is a slice with non-constant size of an array with constant
6684 size, set the maximum size for the allocation of temporaries. */
6685 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type
))
6686 && TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object
))))
6687 TYPE_ARRAY_MAX_SIZE (gnu_result_type
)
6688 = TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object
));
6690 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
6691 gnu_array_object
, gnu_expr
);
6695 case N_Selected_Component
:
6697 const Entity_Id gnat_prefix
= Prefix (gnat_node
);
6698 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
6699 tree gnu_prefix
= gnat_to_gnu (gnat_prefix
);
6701 gnu_prefix
= maybe_padded_object (gnu_prefix
);
6703 /* gnat_to_gnu_entity does not save the GNU tree made for renamed
6704 discriminants so avoid making recursive calls on each reference
6705 to them by following the appropriate link directly here. */
6706 if (Ekind (gnat_field
) == E_Discriminant
)
6708 /* For discriminant references in tagged types always substitute
6709 the corresponding discriminant as the actual component. */
6710 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix
))))
6711 while (Present (Corresponding_Discriminant (gnat_field
)))
6712 gnat_field
= Corresponding_Discriminant (gnat_field
);
6714 /* For discriminant references in untagged types always substitute
6715 the corresponding stored discriminant. */
6716 else if (Present (Corresponding_Discriminant (gnat_field
)))
6717 gnat_field
= Original_Record_Component (gnat_field
);
6720 /* Handle extracting the real or imaginary part of a complex.
6721 The real part is the first field and the imaginary the last. */
6722 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
6723 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
6724 ? REALPART_EXPR
: IMAGPART_EXPR
,
6725 NULL_TREE
, gnu_prefix
);
6728 tree gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
6731 = build_component_ref (gnu_prefix
, gnu_field
,
6732 (Nkind (Parent (gnat_node
))
6733 == N_Attribute_Reference
)
6734 && lvalue_required_for_attribute_p
6735 (Parent (gnat_node
)));
6738 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6740 /* If atomic access is required on the RHS, build the atomic load. */
6741 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6742 && !present_in_lhs_or_actual_p (gnat_node
))
6743 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6747 case N_Attribute_Reference
:
6749 /* The attribute designator. */
6750 const int attr
= Get_Attribute_Id (Attribute_Name (gnat_node
));
6752 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
6753 is a unit, not an object with a GCC equivalent. */
6754 if (attr
== Attr_Elab_Spec
|| attr
== Attr_Elab_Body
)
6756 create_subprog_decl (create_concat_name
6757 (Entity (Prefix (gnat_node
)),
6758 attr
== Attr_Elab_Body
? "elabb" : "elabs"),
6759 NULL_TREE
, void_ftype
, NULL_TREE
, is_default
,
6760 true, true, true, true, false, NULL
,
6763 gnu_result
= Attribute_to_gnu (gnat_node
, &gnu_result_type
, attr
);
6768 /* Like 'Access as far as we are concerned. */
6769 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
6770 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
6771 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6775 case N_Extension_Aggregate
:
6779 /* Check that this aggregate has not slipped through the cracks. */
6780 gcc_assert (!Expansion_Delayed (gnat_node
));
6782 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6784 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
6785 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
6787 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type
)));
6788 else if (TREE_CODE (gnu_result_type
) == VECTOR_TYPE
)
6789 gnu_aggr_type
= TYPE_REPRESENTATIVE_ARRAY (gnu_result_type
);
6791 gnu_aggr_type
= gnu_result_type
;
6793 if (Null_Record_Present (gnat_node
))
6794 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL
);
6796 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
6797 || TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
6799 = assoc_to_constructor (Etype (gnat_node
),
6800 First (Component_Associations (gnat_node
)),
6802 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
6803 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
6805 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
6808 (COMPLEX_EXPR
, gnu_aggr_type
,
6809 gnat_to_gnu (Expression (First
6810 (Component_Associations (gnat_node
)))),
6811 gnat_to_gnu (Expression
6813 (First (Component_Associations (gnat_node
))))));
6817 gnu_result
= convert (gnu_result_type
, gnu_result
);
6822 if (TARGET_VTABLE_USES_DESCRIPTORS
6823 && Ekind (Etype (gnat_node
)) == E_Access_Subprogram_Type
6824 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
6825 gnu_result
= null_fdesc_node
;
6827 gnu_result
= null_pointer_node
;
6828 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6831 case N_Type_Conversion
:
6832 case N_Qualified_Expression
:
6833 gnu_expr
= maybe_character_value (gnat_to_gnu (Expression (gnat_node
)));
6834 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6836 /* If this is a qualified expression for a tagged type, we mark the type
6837 as used. Because of polymorphism, this might be the only reference to
6838 the tagged type in the program while objects have it as dynamic type.
6839 The debugger needs to see it to display these objects properly. */
6840 if (kind
== N_Qualified_Expression
&& Is_Tagged_Type (Etype (gnat_node
)))
6841 used_types_insert (gnu_result_type
);
6843 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node
)));
6846 = convert_with_check (Etype (gnat_node
), gnu_expr
,
6847 Do_Overflow_Check (gnat_node
),
6848 kind
== N_Type_Conversion
6849 && Float_Truncate (gnat_node
), gnat_node
);
6852 case N_Unchecked_Type_Conversion
:
6853 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6854 gnu_expr
= maybe_character_value (gnat_to_gnu (Expression (gnat_node
)));
6856 /* Skip further processing if the conversion is deemed a no-op. */
6857 if (unchecked_conversion_nop (gnat_node
))
6859 gnu_result
= gnu_expr
;
6860 gnu_result_type
= TREE_TYPE (gnu_result
);
6864 /* If the result is a pointer type, see if we are improperly
6865 converting to a stricter alignment. */
6866 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
6867 && Is_Access_Type (Etype (gnat_node
)))
6869 unsigned int align
= known_alignment (gnu_expr
);
6870 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
6871 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
6873 if (align
!= 0 && align
< oalign
&& !TYPE_ALIGN_OK (gnu_obj_type
))
6874 post_error_ne_tree_2
6875 ("?source alignment (^) '< alignment of & (^)",
6876 gnat_node
, Designated_Type (Etype (gnat_node
)),
6877 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
6880 /* If we are converting a descriptor to a function pointer, first
6881 build the pointer. */
6882 if (TARGET_VTABLE_USES_DESCRIPTORS
6883 && TREE_TYPE (gnu_expr
) == fdesc_type_node
6884 && POINTER_TYPE_P (gnu_result_type
))
6885 gnu_expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
6887 gnu_result
= unchecked_convert (gnu_result_type
, gnu_expr
,
6888 No_Truncation (gnat_node
));
6894 tree gnu_obj
= gnat_to_gnu (Left_Opnd (gnat_node
));
6895 tree gnu_low
, gnu_high
;
6897 Range_to_gnu (Right_Opnd (gnat_node
), &gnu_low
, &gnu_high
);
6898 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6900 tree gnu_op_type
= maybe_character_type (TREE_TYPE (gnu_obj
));
6901 if (TREE_TYPE (gnu_obj
) != gnu_op_type
)
6903 gnu_obj
= convert (gnu_op_type
, gnu_obj
);
6904 gnu_low
= convert (gnu_op_type
, gnu_low
);
6905 gnu_high
= convert (gnu_op_type
, gnu_high
);
6908 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
6909 ensure that GNU_OBJ is evaluated only once and perform a full range
6911 if (operand_equal_p (gnu_low
, gnu_high
, 0))
6913 = build_binary_op (EQ_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
6917 gnu_obj
= gnat_protect_expr (gnu_obj
);
6918 t1
= build_binary_op (GE_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
6920 set_expr_location_from_node (t1
, gnat_node
);
6921 t2
= build_binary_op (LE_EXPR
, gnu_result_type
, gnu_obj
, gnu_high
);
6923 set_expr_location_from_node (t2
, gnat_node
);
6925 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
, t1
, t2
);
6928 if (kind
== N_Not_In
)
6930 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result
), gnu_result
);
6935 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
6936 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
6937 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6938 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
6940 : (Rounded_Result (gnat_node
)
6941 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
6942 gnu_result_type
, gnu_lhs
, gnu_rhs
);
6956 case N_Op_Rotate_Left
:
6957 case N_Op_Rotate_Right
:
6958 case N_Op_Shift_Left
:
6959 case N_Op_Shift_Right
:
6960 case N_Op_Shift_Right_Arithmetic
:
6967 enum tree_code code
= gnu_codes
[kind
];
6968 bool ignore_lhs_overflow
= false;
6969 location_t saved_location
= input_location
;
6970 tree gnu_type
, gnu_max_shift
= NULL_TREE
;
6972 /* Fix operations set up for boolean types in GNU_CODES above. */
6973 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node
))))
6977 code
= BIT_AND_EXPR
;
6980 code
= BIT_IOR_EXPR
;
6983 code
= BIT_XOR_EXPR
;
6989 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
6990 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
6991 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6993 /* If this is a shift, take the count as unsigned since that is what
6994 most machines do and will generate simpler adjustments below. */
6995 if (IN (kind
, N_Op_Shift
))
6998 = gnat_unsigned_type_for (get_base_type (TREE_TYPE (gnu_rhs
)));
6999 gnu_rhs
= convert (gnu_count_type
, gnu_rhs
);
7001 = convert (TREE_TYPE (gnu_rhs
), TYPE_SIZE (gnu_type
));
7004 /* Pending generic support for efficient vector logical operations in
7005 GCC, convert vectors to their representative array type view and
7007 gnu_lhs
= maybe_vector_array (gnu_lhs
);
7008 gnu_rhs
= maybe_vector_array (gnu_rhs
);
7010 /* If this is a comparison operator, convert any references to an
7011 unconstrained array value into a reference to the actual array. */
7012 if (TREE_CODE_CLASS (code
) == tcc_comparison
)
7014 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
7015 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
7017 tree gnu_op_type
= maybe_character_type (TREE_TYPE (gnu_lhs
));
7018 if (TREE_TYPE (gnu_lhs
) != gnu_op_type
)
7020 gnu_lhs
= convert (gnu_op_type
, gnu_lhs
);
7021 gnu_rhs
= convert (gnu_op_type
, gnu_rhs
);
7025 /* If this is a shift whose count is not guaranteed to be correct,
7026 we need to adjust the shift count. */
7027 if ((kind
== N_Op_Rotate_Left
|| kind
== N_Op_Rotate_Right
)
7028 && !Shift_Count_OK (gnat_node
))
7029 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, TREE_TYPE (gnu_rhs
),
7030 gnu_rhs
, gnu_max_shift
);
7031 else if (kind
== N_Op_Shift_Right_Arithmetic
7032 && !Shift_Count_OK (gnat_node
))
7034 = build_binary_op (MIN_EXPR
, TREE_TYPE (gnu_rhs
),
7035 build_binary_op (MINUS_EXPR
,
7036 TREE_TYPE (gnu_rhs
),
7039 (TREE_TYPE (gnu_rhs
), 1)),
7042 /* For right shifts, the type says what kind of shift to do,
7043 so we may need to choose a different type. In this case,
7044 we have to ignore integer overflow lest it propagates all
7045 the way down and causes a CE to be explicitly raised. */
7046 if (kind
== N_Op_Shift_Right
&& !TYPE_UNSIGNED (gnu_type
))
7048 gnu_type
= gnat_unsigned_type_for (gnu_type
);
7049 ignore_lhs_overflow
= true;
7051 else if (kind
== N_Op_Shift_Right_Arithmetic
7052 && TYPE_UNSIGNED (gnu_type
))
7054 gnu_type
= gnat_signed_type_for (gnu_type
);
7055 ignore_lhs_overflow
= true;
7058 if (gnu_type
!= gnu_result_type
)
7060 tree gnu_old_lhs
= gnu_lhs
;
7061 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
7062 if (TREE_CODE (gnu_lhs
) == INTEGER_CST
&& ignore_lhs_overflow
)
7063 TREE_OVERFLOW (gnu_lhs
) = TREE_OVERFLOW (gnu_old_lhs
);
7064 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
7066 gnu_max_shift
= convert (gnu_type
, gnu_max_shift
);
7069 /* For signed integer addition, subtraction and multiplication, do an
7070 overflow check if required. */
7071 if (Do_Overflow_Check (gnat_node
)
7072 && (code
== PLUS_EXPR
|| code
== MINUS_EXPR
|| code
== MULT_EXPR
)
7073 && !TYPE_UNSIGNED (gnu_type
)
7074 && !FLOAT_TYPE_P (gnu_type
))
7076 = build_binary_op_trapv (code
, gnu_type
, gnu_lhs
, gnu_rhs
,
7080 /* Some operations, e.g. comparisons of arrays, generate complex
7081 trees that need to be annotated while they are being built. */
7082 input_location
= saved_location
;
7083 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
7086 /* If this is a logical shift with the shift count not verified,
7087 we must return zero if it is too large. We cannot compensate
7088 beforehand in this case. */
7089 if ((kind
== N_Op_Shift_Left
|| kind
== N_Op_Shift_Right
)
7090 && !Shift_Count_OK (gnat_node
))
7092 = build_cond_expr (gnu_type
,
7093 build_binary_op (GE_EXPR
, boolean_type_node
,
7094 gnu_rhs
, gnu_max_shift
),
7095 build_int_cst (gnu_type
, 0),
7100 case N_If_Expression
:
7102 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
7103 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
7105 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
7107 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7109 = build_cond_expr (gnu_result_type
, gnu_cond
, gnu_true
, gnu_false
);
7114 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
7115 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7119 /* This case can apply to a boolean or a modular type.
7120 Fall through for a boolean operand since GNU_CODES is set
7121 up to handle this. */
7122 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node
))))
7124 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
7125 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7126 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
7131 /* ... fall through ... */
7135 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
7136 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7138 /* For signed integer negation and absolute value, do an overflow check
7140 if (Do_Overflow_Check (gnat_node
)
7141 && !TYPE_UNSIGNED (gnu_result_type
)
7142 && !FLOAT_TYPE_P (gnu_result_type
))
7144 = build_unary_op_trapv (gnu_codes
[kind
], gnu_result_type
, gnu_expr
,
7148 = build_unary_op (gnu_codes
[kind
], gnu_result_type
, gnu_expr
);
7153 tree gnu_type
, gnu_init
;
7154 bool ignore_init_type
;
7156 gnat_temp
= Expression (gnat_node
);
7158 /* The expression can be either an N_Identifier or an Expanded_Name,
7159 which must represent a type, or a N_Qualified_Expression, which
7160 contains both the type and an initial value for the object. */
7161 if (Nkind (gnat_temp
) == N_Identifier
7162 || Nkind (gnat_temp
) == N_Expanded_Name
)
7164 ignore_init_type
= false;
7165 gnu_init
= NULL_TREE
;
7166 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
7169 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
7171 const Entity_Id gnat_desig_type
7172 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
7174 ignore_init_type
= Has_Constrained_Partial_View (gnat_desig_type
);
7176 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
7177 gnu_init
= maybe_unconstrained_array (gnu_init
);
7179 gigi_checking_assert (!Do_Range_Check (Expression (gnat_temp
)));
7181 if (Is_Elementary_Type (gnat_desig_type
)
7182 || Is_Constrained (gnat_desig_type
))
7183 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
7186 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
7187 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
7188 gnu_type
= TREE_TYPE (gnu_init
);
7191 /* See the N_Qualified_Expression case for the rationale. */
7192 if (Is_Tagged_Type (gnat_desig_type
))
7193 used_types_insert (gnu_type
);
7195 gnu_init
= convert (gnu_type
, gnu_init
);
7200 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7201 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
7202 Procedure_To_Call (gnat_node
),
7203 Storage_Pool (gnat_node
), gnat_node
,
7208 /**************************/
7209 /* Chapter 5: Statements */
7210 /**************************/
7213 gnu_result
= build1 (LABEL_EXPR
, void_type_node
,
7214 gnat_to_gnu (Identifier (gnat_node
)));
7217 case N_Null_Statement
:
7218 /* When not optimizing, turn null statements from source into gotos to
7219 the next statement that the middle-end knows how to preserve. */
7220 if (!optimize
&& Comes_From_Source (gnat_node
))
7222 tree stmt
, label
= create_label_decl (NULL_TREE
, gnat_node
);
7223 DECL_IGNORED_P (label
) = 1;
7224 start_stmt_group ();
7225 stmt
= build1 (GOTO_EXPR
, void_type_node
, label
);
7226 set_expr_location_from_node (stmt
, gnat_node
);
7228 stmt
= build1 (LABEL_EXPR
, void_type_node
, label
);
7229 set_expr_location_from_node (stmt
, gnat_node
);
7231 gnu_result
= end_stmt_group ();
7234 gnu_result
= alloc_stmt_list ();
7237 case N_Assignment_Statement
:
7238 /* Get the LHS and RHS of the statement and convert any reference to an
7239 unconstrained array into a reference to the underlying array. */
7240 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
7242 /* If the type has a size that overflows, convert this into raise of
7243 Storage_Error: execution shouldn't have gotten here anyway. */
7244 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
7245 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))))
7246 gnu_result
= build_call_raise (SE_Object_Too_Large
, gnat_node
,
7247 N_Raise_Storage_Error
);
7248 else if (Nkind (Expression (gnat_node
)) == N_Function_Call
)
7250 get_atomic_access (Name (gnat_node
), &aa_type
, &aa_sync
);
7252 = Call_to_gnu (Expression (gnat_node
), &gnu_result_type
, gnu_lhs
,
7257 const Node_Id gnat_expr
= Expression (gnat_node
);
7258 const Node_Id gnat_inner
7259 = Nkind (gnat_expr
) == N_Qualified_Expression
7260 ? Expression (gnat_expr
)
7262 const Entity_Id gnat_type
7263 = Underlying_Type (Etype (Name (gnat_node
)));
7264 const bool use_memset_p
7265 = Is_Array_Type (gnat_type
)
7266 && Nkind (gnat_inner
) == N_Aggregate
7267 && Is_Single_Aggregate (gnat_inner
);
7269 /* If we use memset, we need to find the innermost expression. */
7272 gnat_temp
= gnat_inner
;
7275 = Expression (First (Component_Associations (gnat_temp
)));
7276 } while (Nkind (gnat_temp
) == N_Aggregate
7277 && Is_Single_Aggregate (gnat_temp
));
7278 gnu_rhs
= gnat_to_gnu (gnat_temp
);
7281 gnu_rhs
= maybe_unconstrained_array (gnat_to_gnu (gnat_expr
));
7283 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
7285 get_atomic_access (Name (gnat_node
), &aa_type
, &aa_sync
);
7287 /* If an outer atomic access is required on the LHS, build the load-
7288 modify-store sequence. */
7289 if (aa_type
== OUTER_ATOMIC
)
7290 gnu_result
= build_load_modify_store (gnu_lhs
, gnu_rhs
, gnat_node
);
7292 /* Or else, if a simple atomic access is required, build the atomic
7294 else if (aa_type
== SIMPLE_ATOMIC
)
7295 gnu_result
= build_atomic_store (gnu_lhs
, gnu_rhs
, aa_sync
);
7297 /* Or else, use memset when the conditions are met. This has already
7298 been validated by Aggr_Assignment_OK_For_Backend in the front-end
7299 and the RHS is thus guaranteed to be of the appropriate form. */
7300 else if (use_memset_p
)
7303 = real_zerop (gnu_rhs
)
7305 : fold_convert (integer_type_node
, gnu_rhs
);
7306 tree dest
= build_fold_addr_expr (gnu_lhs
);
7307 tree t
= builtin_decl_explicit (BUILT_IN_MEMSET
);
7308 /* Be extra careful not to write too much data. */
7310 if (TREE_CODE (gnu_lhs
) == COMPONENT_REF
)
7311 size
= DECL_SIZE_UNIT (TREE_OPERAND (gnu_lhs
, 1));
7312 else if (DECL_P (gnu_lhs
))
7313 size
= DECL_SIZE_UNIT (gnu_lhs
);
7315 size
= TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
));
7316 size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_lhs
);
7317 if (TREE_CODE (value
) == INTEGER_CST
&& !integer_zerop (value
))
7320 = build_int_cst (integer_type_node
,
7321 ((HOST_WIDE_INT
) 1 << BITS_PER_UNIT
) - 1);
7322 value
= int_const_binop (BIT_AND_EXPR
, value
, mask
);
7324 gnu_result
= build_call_expr (t
, 3, dest
, value
, size
);
7327 /* Otherwise build a regular assignment. */
7330 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
7332 /* If the assignment type is a regular array and the two sides are
7333 not completely disjoint, play safe and use memmove. But don't do
7334 it for a bit-packed array as it might not be byte-aligned. */
7335 if (TREE_CODE (gnu_result
) == MODIFY_EXPR
7336 && Is_Array_Type (gnat_type
)
7337 && !Is_Bit_Packed_Array (gnat_type
)
7338 && !(Forwards_OK (gnat_node
) && Backwards_OK (gnat_node
)))
7340 tree to
= TREE_OPERAND (gnu_result
, 0);
7341 tree from
= TREE_OPERAND (gnu_result
, 1);
7342 tree type
= TREE_TYPE (from
);
7344 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type
), from
);
7345 tree to_ptr
= build_fold_addr_expr (to
);
7346 tree from_ptr
= build_fold_addr_expr (from
);
7347 tree t
= builtin_decl_explicit (BUILT_IN_MEMMOVE
);
7348 gnu_result
= build_call_expr (t
, 3, to_ptr
, from_ptr
, size
);
7353 case N_If_Statement
:
7355 tree
*gnu_else_ptr
; /* Point to put next "else if" or "else". */
7357 /* Make the outer COND_EXPR. Avoid non-determinism. */
7358 gnu_result
= build3 (COND_EXPR
, void_type_node
,
7359 gnat_to_gnu (Condition (gnat_node
)),
7360 NULL_TREE
, NULL_TREE
);
7361 COND_EXPR_THEN (gnu_result
)
7362 = build_stmt_group (Then_Statements (gnat_node
), false);
7363 TREE_SIDE_EFFECTS (gnu_result
) = 1;
7364 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_result
);
7366 /* Now make a COND_EXPR for each of the "else if" parts. Put each
7367 into the previous "else" part and point to where to put any
7368 outer "else". Also avoid non-determinism. */
7369 if (Present (Elsif_Parts (gnat_node
)))
7370 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
7371 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
7373 gnu_expr
= build3 (COND_EXPR
, void_type_node
,
7374 gnat_to_gnu (Condition (gnat_temp
)),
7375 NULL_TREE
, NULL_TREE
);
7376 COND_EXPR_THEN (gnu_expr
)
7377 = build_stmt_group (Then_Statements (gnat_temp
), false);
7378 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
7379 set_expr_location_from_node (gnu_expr
, gnat_temp
);
7380 *gnu_else_ptr
= gnu_expr
;
7381 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
7384 *gnu_else_ptr
= build_stmt_group (Else_Statements (gnat_node
), false);
7388 case N_Case_Statement
:
7389 gnu_result
= Case_Statement_to_gnu (gnat_node
);
7392 case N_Loop_Statement
:
7393 gnu_result
= Loop_Statement_to_gnu (gnat_node
);
7396 case N_Block_Statement
:
7397 /* The only way to enter the block is to fall through to it. */
7398 if (stmt_group_may_fallthru ())
7400 start_stmt_group ();
7402 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7403 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
7405 gnu_result
= end_stmt_group ();
7408 gnu_result
= alloc_stmt_list ();
7411 case N_Exit_Statement
:
7413 = build2 (EXIT_STMT
, void_type_node
,
7414 (Present (Condition (gnat_node
))
7415 ? gnat_to_gnu (Condition (gnat_node
)) : NULL_TREE
),
7416 (Present (Name (gnat_node
))
7417 ? get_gnu_tree (Entity (Name (gnat_node
)))
7418 : LOOP_STMT_LABEL (gnu_loop_stack
->last ()->stmt
)));
7421 case N_Simple_Return_Statement
:
7423 tree gnu_ret_obj
, gnu_ret_val
;
7425 /* If the subprogram is a function, we must return the expression. */
7426 if (Present (Expression (gnat_node
)))
7428 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
7430 /* If this function has copy-in/copy-out parameters parameters and
7431 doesn't return by invisible reference, get the real object for
7432 the return. See Subprogram_Body_to_gnu. */
7433 if (TYPE_CI_CO_LIST (gnu_subprog_type
)
7434 && !TREE_ADDRESSABLE (gnu_subprog_type
))
7435 gnu_ret_obj
= gnu_return_var_stack
->last ();
7437 gnu_ret_obj
= DECL_RESULT (current_function_decl
);
7439 /* Get the GCC tree for the expression to be returned. */
7440 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
7442 /* Do not remove the padding from GNU_RET_VAL if the inner type is
7443 self-referential since we want to allocate the fixed size. */
7444 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
7445 && type_is_padding_self_referential
7446 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
7447 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
7449 /* If the function returns by direct reference, return a pointer
7450 to the return value. */
7451 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
)
7452 || By_Ref (gnat_node
))
7453 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
7455 /* Otherwise, if it returns an unconstrained array, we have to
7456 allocate a new version of the result and return it. */
7457 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
))
7459 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
7461 /* And find out whether this is a candidate for Named Return
7462 Value. If so, record it. */
7465 && !TYPE_CI_CO_LIST (gnu_subprog_type
))
7467 tree ret_val
= gnu_ret_val
;
7469 /* Strip useless conversions around the return value. */
7470 if (gnat_useless_type_conversion (ret_val
))
7471 ret_val
= TREE_OPERAND (ret_val
, 0);
7473 /* Strip unpadding around the return value. */
7474 if (TREE_CODE (ret_val
) == COMPONENT_REF
7475 && TYPE_IS_PADDING_P
7476 (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
7477 ret_val
= TREE_OPERAND (ret_val
, 0);
7479 /* Now apply the test to the return value. */
7480 if (return_value_ok_for_nrv_p (NULL_TREE
, ret_val
))
7482 if (!f_named_ret_val
)
7483 f_named_ret_val
= BITMAP_GGC_ALLOC ();
7484 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
7486 f_gnat_ret
= gnat_node
;
7490 gnu_ret_val
= build_allocator (TREE_TYPE (gnu_ret_val
),
7492 TREE_TYPE (gnu_ret_obj
),
7493 Procedure_To_Call (gnat_node
),
7494 Storage_Pool (gnat_node
),
7498 /* Otherwise, if it returns by invisible reference, dereference
7499 the pointer it is passed using the type of the return value
7500 and build the copy operation manually. This ensures that we
7501 don't copy too much data, for example if the return type is
7502 unconstrained with a maximum size. */
7503 else if (TREE_ADDRESSABLE (gnu_subprog_type
))
7506 = build_unary_op (INDIRECT_REF
, TREE_TYPE (gnu_ret_val
),
7508 gnu_result
= build2 (INIT_EXPR
, void_type_node
,
7509 gnu_ret_deref
, gnu_ret_val
);
7510 add_stmt_with_node (gnu_result
, gnat_node
);
7511 gnu_ret_val
= NULL_TREE
;
7516 gnu_ret_obj
= gnu_ret_val
= NULL_TREE
;
7518 /* If we have a return label defined, convert this into a branch to
7519 that label. The return proper will be handled elsewhere. */
7520 if (gnu_return_label_stack
->last ())
7523 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_ret_obj
,
7526 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
7527 gnu_return_label_stack
->last ());
7529 /* When not optimizing, make sure the return is preserved. */
7530 if (!optimize
&& Comes_From_Source (gnat_node
))
7531 DECL_ARTIFICIAL (gnu_return_label_stack
->last ()) = 0;
7534 /* Otherwise, build a regular return. */
7536 gnu_result
= build_return_expr (gnu_ret_obj
, gnu_ret_val
);
7540 case N_Goto_Statement
:
7541 gnu_expr
= gnat_to_gnu (Name (gnat_node
));
7542 gnu_result
= build1 (GOTO_EXPR
, void_type_node
, gnu_expr
);
7543 TREE_USED (gnu_expr
) = 1;
7546 /***************************/
7547 /* Chapter 6: Subprograms */
7548 /***************************/
7550 case N_Subprogram_Declaration
:
7551 /* Unless there is a freeze node, declare the entity. We consider
7552 this a definition even though we're not generating code for the
7553 subprogram because we will be making the corresponding GCC node.
7554 When there is a freeze node, it is considered the definition of
7555 the subprogram and we do nothing until after it is encountered.
7556 That's an efficiency issue: the types involved in the profile
7557 are far more likely to be frozen between the declaration and
7558 the freeze node than before the declaration, so we save some
7559 updates of the GCC node by waiting until the freeze node.
7560 The counterpart is that we assume that there is no reference
7561 to the subprogram between the declaration and the freeze node
7562 in the expanded code; otherwise, it will be interpreted as an
7563 external reference and very likely give rise to a link failure. */
7564 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
7565 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
7567 gnu_result
= alloc_stmt_list ();
7570 case N_Abstract_Subprogram_Declaration
:
7571 /* This subprogram doesn't exist for code generation purposes, but we
7572 have to elaborate the types of any parameters and result, unless
7573 they are imported types (nothing to generate in this case).
7575 The parameter list may contain types with freeze nodes, e.g. not null
7576 subtypes, so the subprogram itself may carry a freeze node, in which
7577 case its elaboration must be deferred. */
7579 /* Process the parameter types first. */
7580 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
7582 = First_Formal_With_Extras
7583 (Defining_Entity (Specification (gnat_node
)));
7584 Present (gnat_temp
);
7585 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
7586 if (Is_Itype (Etype (gnat_temp
))
7587 && !From_Limited_With (Etype (gnat_temp
)))
7588 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, false);
7590 /* Then the result type, set to Standard_Void_Type for procedures. */
7592 Entity_Id gnat_temp_type
7593 = Etype (Defining_Entity (Specification (gnat_node
)));
7595 if (Is_Itype (gnat_temp_type
) && !From_Limited_With (gnat_temp_type
))
7596 gnat_to_gnu_entity (Etype (gnat_temp_type
), NULL_TREE
, false);
7599 gnu_result
= alloc_stmt_list ();
7602 case N_Defining_Program_Unit_Name
:
7603 /* For a child unit identifier go up a level to get the specification.
7604 We get this when we try to find the spec of a child unit package
7605 that is the compilation unit being compiled. */
7606 gnu_result
= gnat_to_gnu (Parent (gnat_node
));
7609 case N_Subprogram_Body
:
7610 Subprogram_Body_to_gnu (gnat_node
);
7611 gnu_result
= alloc_stmt_list ();
7614 case N_Function_Call
:
7615 case N_Procedure_Call_Statement
:
7616 gnu_result
= Call_to_gnu (gnat_node
, &gnu_result_type
, NULL_TREE
,
7620 /************************/
7621 /* Chapter 7: Packages */
7622 /************************/
7624 case N_Package_Declaration
:
7625 gnu_result
= gnat_to_gnu (Specification (gnat_node
));
7628 case N_Package_Specification
:
7630 start_stmt_group ();
7631 process_decls (Visible_Declarations (gnat_node
),
7632 Private_Declarations (gnat_node
), Empty
, true, true);
7633 gnu_result
= end_stmt_group ();
7636 case N_Package_Body
:
7638 /* If this is the body of a generic package - do nothing. */
7639 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
7641 gnu_result
= alloc_stmt_list ();
7645 start_stmt_group ();
7646 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7648 if (Present (Handled_Statement_Sequence (gnat_node
)))
7649 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
7651 gnu_result
= end_stmt_group ();
7654 /********************************/
7655 /* Chapter 8: Visibility Rules */
7656 /********************************/
7658 case N_Use_Package_Clause
:
7659 case N_Use_Type_Clause
:
7660 /* Nothing to do here - but these may appear in list of declarations. */
7661 gnu_result
= alloc_stmt_list ();
7664 /*********************/
7665 /* Chapter 9: Tasks */
7666 /*********************/
7668 case N_Protected_Type_Declaration
:
7669 gnu_result
= alloc_stmt_list ();
7672 case N_Single_Task_Declaration
:
7673 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, true);
7674 gnu_result
= alloc_stmt_list ();
7677 /*********************************************************/
7678 /* Chapter 10: Program Structure and Compilation Issues */
7679 /*********************************************************/
7681 case N_Compilation_Unit
:
7682 /* This is not called for the main unit on which gigi is invoked. */
7683 Compilation_Unit_to_gnu (gnat_node
);
7684 gnu_result
= alloc_stmt_list ();
7688 gnu_result
= gnat_to_gnu (Proper_Body (gnat_node
));
7692 case N_Protected_Body
:
7694 /* These nodes should only be present when annotating types. */
7695 gcc_assert (type_annotate_only
);
7696 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7697 gnu_result
= alloc_stmt_list ();
7700 case N_Subprogram_Body_Stub
:
7701 case N_Package_Body_Stub
:
7702 case N_Protected_Body_Stub
:
7703 case N_Task_Body_Stub
:
7704 /* Simply process whatever unit is being inserted. */
7705 if (Present (Library_Unit (gnat_node
)))
7706 gnu_result
= gnat_to_gnu (Unit (Library_Unit (gnat_node
)));
7709 gcc_assert (type_annotate_only
);
7710 gnu_result
= alloc_stmt_list ();
7714 /***************************/
7715 /* Chapter 11: Exceptions */
7716 /***************************/
7718 case N_Handled_Sequence_Of_Statements
:
7719 /* If there is an At_End procedure attached to this node, and the EH
7720 mechanism is front-end, we must have at least a corresponding At_End
7721 handler, unless the No_Exception_Handlers restriction is set. */
7722 gcc_assert (type_annotate_only
7723 || !Front_End_Exceptions ()
7724 || No (At_End_Proc (gnat_node
))
7725 || Present (Exception_Handlers (gnat_node
))
7726 || No_Exception_Handlers_Set ());
7728 gnu_result
= Handled_Sequence_Of_Statements_to_gnu (gnat_node
);
7731 case N_Exception_Handler
:
7732 if (Back_End_Exceptions ())
7733 gnu_result
= Exception_Handler_to_gnu_gcc (gnat_node
);
7734 else if (Exception_Mechanism
== Front_End_SJLJ
)
7735 gnu_result
= Exception_Handler_to_gnu_fe_sjlj (gnat_node
);
7740 case N_Raise_Statement
:
7741 /* Only for reraise in back-end exceptions mode. */
7742 gcc_assert (No (Name (gnat_node
)) && Back_End_Exceptions ());
7744 start_stmt_group ();
7746 add_stmt_with_node (build_call_n_expr (reraise_zcx_decl
, 1,
7747 gnu_incoming_exc_ptr
),
7750 gnu_result
= end_stmt_group ();
7753 case N_Push_Constraint_Error_Label
:
7754 gnu_constraint_error_label_stack
.safe_push (Exception_Label (gnat_node
));
7757 case N_Push_Storage_Error_Label
:
7758 gnu_storage_error_label_stack
.safe_push (Exception_Label (gnat_node
));
7761 case N_Push_Program_Error_Label
:
7762 gnu_program_error_label_stack
.safe_push (Exception_Label (gnat_node
));
7765 case N_Pop_Constraint_Error_Label
:
7766 gnat_temp
= gnu_constraint_error_label_stack
.pop ();
7767 if (Present (gnat_temp
)
7768 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
7769 Warn_If_No_Local_Raise (gnat_temp
);
7772 case N_Pop_Storage_Error_Label
:
7773 gnat_temp
= gnu_storage_error_label_stack
.pop ();
7774 if (Present (gnat_temp
)
7775 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
7776 Warn_If_No_Local_Raise (gnat_temp
);
7779 case N_Pop_Program_Error_Label
:
7780 gnat_temp
= gnu_program_error_label_stack
.pop ();
7781 if (Present (gnat_temp
)
7782 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
7783 Warn_If_No_Local_Raise (gnat_temp
);
7786 /******************************/
7787 /* Chapter 12: Generic Units */
7788 /******************************/
7790 case N_Generic_Function_Renaming_Declaration
:
7791 case N_Generic_Package_Renaming_Declaration
:
7792 case N_Generic_Procedure_Renaming_Declaration
:
7793 case N_Generic_Package_Declaration
:
7794 case N_Generic_Subprogram_Declaration
:
7795 case N_Package_Instantiation
:
7796 case N_Procedure_Instantiation
:
7797 case N_Function_Instantiation
:
7798 /* These nodes can appear on a declaration list but there is nothing to
7799 to be done with them. */
7800 gnu_result
= alloc_stmt_list ();
7803 /**************************************************/
7804 /* Chapter 13: Representation Clauses and */
7805 /* Implementation-Dependent Features */
7806 /**************************************************/
7808 case N_Attribute_Definition_Clause
:
7809 gnu_result
= alloc_stmt_list ();
7811 /* The only one we need to deal with is 'Address since, for the others,
7812 the front-end puts the information elsewhere. */
7813 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
)
7816 /* And we only deal with 'Address if the object has a Freeze node. */
7817 gnat_temp
= Entity (Name (gnat_node
));
7818 if (Freeze_Node (gnat_temp
))
7820 tree gnu_address
= gnat_to_gnu (Expression (gnat_node
)), gnu_temp
;
7822 /* Get the value to use as the address and save it as the equivalent
7823 for the object; when it is frozen, gnat_to_gnu_entity will do the
7824 right thing. For a subprogram, put the naked address but build a
7825 meaningfull expression for an object in case its address is taken
7826 before the Freeze node is encountered; this can happen if the type
7827 of the object is limited and it is initialized with the result of
7829 if (Is_Subprogram (gnat_temp
))
7830 gnu_temp
= gnu_address
;
7833 tree gnu_type
= gnat_to_gnu_type (Etype (gnat_temp
));
7834 /* Drop atomic and volatile qualifiers for the expression. */
7835 gnu_type
= TYPE_MAIN_VARIANT (gnu_type
);
7837 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
7838 gnu_address
= convert (gnu_type
, gnu_address
);
7840 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_address
);
7843 save_gnu_tree (gnat_temp
, gnu_temp
, true);
7847 case N_Enumeration_Representation_Clause
:
7848 case N_Record_Representation_Clause
:
7850 /* We do nothing with these. SEM puts the information elsewhere. */
7851 gnu_result
= alloc_stmt_list ();
7854 case N_Code_Statement
:
7855 if (!type_annotate_only
)
7857 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
7858 tree gnu_inputs
= NULL_TREE
, gnu_outputs
= NULL_TREE
;
7859 tree gnu_clobbers
= NULL_TREE
, tail
;
7860 bool allows_mem
, allows_reg
, fake
;
7861 int ninputs
, noutputs
, i
;
7862 const char **oconstraints
;
7863 const char *constraint
;
7866 /* First retrieve the 3 operand lists built by the front-end. */
7867 Setup_Asm_Outputs (gnat_node
);
7868 while (Present (gnat_temp
= Asm_Output_Variable ()))
7870 tree gnu_value
= gnat_to_gnu (gnat_temp
);
7871 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
7872 (Asm_Output_Constraint ()));
7874 gnu_outputs
= tree_cons (gnu_constr
, gnu_value
, gnu_outputs
);
7878 Setup_Asm_Inputs (gnat_node
);
7879 while (Present (gnat_temp
= Asm_Input_Value ()))
7881 tree gnu_value
= gnat_to_gnu (gnat_temp
);
7882 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
7883 (Asm_Input_Constraint ()));
7885 gnu_inputs
= tree_cons (gnu_constr
, gnu_value
, gnu_inputs
);
7889 Clobber_Setup (gnat_node
);
7890 while ((clobber
= Clobber_Get_Next ()))
7892 = tree_cons (NULL_TREE
,
7893 build_string (strlen (clobber
) + 1, clobber
),
7896 /* Then perform some standard checking and processing on the
7897 operands. In particular, mark them addressable if needed. */
7898 gnu_outputs
= nreverse (gnu_outputs
);
7899 noutputs
= list_length (gnu_outputs
);
7900 gnu_inputs
= nreverse (gnu_inputs
);
7901 ninputs
= list_length (gnu_inputs
);
7902 oconstraints
= XALLOCAVEC (const char *, noutputs
);
7904 for (i
= 0, tail
= gnu_outputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
7906 tree output
= TREE_VALUE (tail
);
7908 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
7909 oconstraints
[i
] = constraint
;
7911 if (parse_output_constraint (&constraint
, i
, ninputs
, noutputs
,
7912 &allows_mem
, &allows_reg
, &fake
))
7914 /* If the operand is going to end up in memory,
7915 mark it addressable. Note that we don't test
7916 allows_mem like in the input case below; this
7917 is modeled on the C front-end. */
7920 output
= remove_conversions (output
, false);
7921 if (TREE_CODE (output
) == CONST_DECL
7922 && DECL_CONST_CORRESPONDING_VAR (output
))
7923 output
= DECL_CONST_CORRESPONDING_VAR (output
);
7924 if (!gnat_mark_addressable (output
))
7925 output
= error_mark_node
;
7929 output
= error_mark_node
;
7931 TREE_VALUE (tail
) = output
;
7934 for (i
= 0, tail
= gnu_inputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
7936 tree input
= TREE_VALUE (tail
);
7938 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
7940 if (parse_input_constraint (&constraint
, i
, ninputs
, noutputs
,
7942 &allows_mem
, &allows_reg
))
7944 /* If the operand is going to end up in memory,
7945 mark it addressable. */
7946 if (!allows_reg
&& allows_mem
)
7948 input
= remove_conversions (input
, false);
7949 if (TREE_CODE (input
) == CONST_DECL
7950 && DECL_CONST_CORRESPONDING_VAR (input
))
7951 input
= DECL_CONST_CORRESPONDING_VAR (input
);
7952 if (!gnat_mark_addressable (input
))
7953 input
= error_mark_node
;
7957 input
= error_mark_node
;
7959 TREE_VALUE (tail
) = input
;
7962 gnu_result
= build5 (ASM_EXPR
, void_type_node
,
7963 gnu_template
, gnu_outputs
,
7964 gnu_inputs
, gnu_clobbers
, NULL_TREE
);
7965 ASM_VOLATILE_P (gnu_result
) = Is_Asm_Volatile (gnat_node
);
7968 gnu_result
= alloc_stmt_list ();
7976 /* Markers are created by the ABE mechanism to capture information which
7977 is either unavailable of expensive to recompute. Markers do not have
7978 and runtime semantics, and should be ignored. */
7981 case N_Variable_Reference_Marker
:
7982 gnu_result
= alloc_stmt_list ();
7985 case N_Expression_With_Actions
:
7986 /* This construct doesn't define a scope so we don't push a binding
7987 level around the statement list, but we wrap it in a SAVE_EXPR to
7988 protect it from unsharing. Elaborate the expression as part of the
7989 same statement group as the actions so that the type declaration
7990 gets inserted there as well. This ensures that the type elaboration
7991 code is issued past the actions computing values on which it might
7993 start_stmt_group ();
7994 add_stmt_list (Actions (gnat_node
));
7995 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
7996 gnu_result
= end_stmt_group ();
7998 gnu_result
= build1 (SAVE_EXPR
, void_type_node
, gnu_result
);
7999 TREE_SIDE_EFFECTS (gnu_result
) = 1;
8002 = build_compound_expr (TREE_TYPE (gnu_expr
), gnu_result
, gnu_expr
);
8003 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
8006 case N_Freeze_Entity
:
8007 start_stmt_group ();
8008 process_freeze_entity (gnat_node
);
8009 process_decls (Actions (gnat_node
), Empty
, Empty
, true, true);
8010 gnu_result
= end_stmt_group ();
8013 case N_Freeze_Generic_Entity
:
8014 gnu_result
= alloc_stmt_list ();
8017 case N_Itype_Reference
:
8018 if (!present_gnu_tree (Itype (gnat_node
)))
8019 process_type (Itype (gnat_node
));
8020 gnu_result
= alloc_stmt_list ();
8023 case N_Free_Statement
:
8024 gnat_temp
= Expression (gnat_node
);
8026 if (!type_annotate_only
)
8028 tree gnu_ptr
, gnu_ptr_type
, gnu_obj_type
, gnu_actual_obj_type
;
8030 const Entity_Id gnat_desig_type
8031 = Designated_Type (Underlying_Type (Etype (gnat_temp
)));
8033 /* Make sure the designated type is complete before dereferencing,
8034 in case it is a Taft Amendment type. */
8035 (void) gnat_to_gnu_entity (gnat_desig_type
, NULL_TREE
, false);
8037 gnu_ptr
= gnat_to_gnu (gnat_temp
);
8038 gnu_ptr_type
= TREE_TYPE (gnu_ptr
);
8040 /* If this is a thin pointer, we must first dereference it to create
8041 a fat pointer, then go back below to a thin pointer. The reason
8042 for this is that we need to have a fat pointer someplace in order
8043 to properly compute the size. */
8044 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
8045 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
8046 build_unary_op (INDIRECT_REF
, NULL_TREE
,
8049 /* If this is a fat pointer, the object must have been allocated with
8050 the template in front of the array. So pass the template address,
8051 and get the total size; do it by converting to a thin pointer. */
8052 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
8054 = convert (build_pointer_type
8055 (TYPE_OBJECT_RECORD_TYPE
8056 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
8059 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
8061 /* If this is a thin pointer, the object must have been allocated with
8062 the template in front of the array. So pass the template address,
8063 and get the total size. */
8064 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
8066 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
8068 fold_build1 (NEGATE_EXPR
, sizetype
,
8071 TYPE_FIELDS ((gnu_obj_type
)))));
8073 /* If we have a special dynamic constrained subtype on the node, use
8074 it to compute the size; otherwise, use the designated subtype. */
8075 if (Present (Actual_Designated_Subtype (gnat_node
)))
8078 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node
));
8080 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
))
8082 = build_unc_object_type_from_ptr (gnu_ptr_type
,
8083 gnu_actual_obj_type
,
8084 get_identifier ("DEALLOC"),
8088 gnu_actual_obj_type
= gnu_obj_type
;
8090 tree gnu_size
= TYPE_SIZE_UNIT (gnu_actual_obj_type
);
8091 gnu_size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size
, gnu_ptr
);
8094 = build_call_alloc_dealloc (gnu_ptr
, gnu_size
, gnu_obj_type
,
8095 Procedure_To_Call (gnat_node
),
8096 Storage_Pool (gnat_node
),
8101 case N_Raise_Constraint_Error
:
8102 case N_Raise_Program_Error
:
8103 case N_Raise_Storage_Error
:
8104 if (type_annotate_only
)
8105 gnu_result
= alloc_stmt_list ();
8107 gnu_result
= Raise_Error_to_gnu (gnat_node
, &gnu_result_type
);
8110 case N_Validate_Unchecked_Conversion
:
8111 /* The only validation we currently do on an unchecked conversion is
8112 that of aliasing assumptions. */
8113 if (flag_strict_aliasing
)
8114 gnat_validate_uc_list
.safe_push (gnat_node
);
8115 gnu_result
= alloc_stmt_list ();
8118 case N_Function_Specification
:
8119 case N_Procedure_Specification
:
8121 case N_Component_Association
:
8122 /* These nodes should only be present when annotating types. */
8123 gcc_assert (type_annotate_only
);
8124 gnu_result
= alloc_stmt_list ();
8128 /* Other nodes are not supposed to reach here. */
8132 /* If we pushed the processing of the elaboration routine, pop it back. */
8133 if (went_into_elab_proc
)
8134 current_function_decl
= NULL_TREE
;
8136 /* When not optimizing, turn boolean rvalues B into B != false tests
8137 so that we can put the location information of the reference to B on
8138 the inequality operator for better debug info. */
8140 && TREE_CODE (gnu_result
) != INTEGER_CST
8141 && TREE_CODE (gnu_result
) != TYPE_DECL
8142 && (kind
== N_Identifier
8143 || kind
== N_Expanded_Name
8144 || kind
== N_Explicit_Dereference
8145 || kind
== N_Indexed_Component
8146 || kind
== N_Selected_Component
)
8147 && TREE_CODE (get_base_type (gnu_result_type
)) == BOOLEAN_TYPE
8148 && Nkind (Parent (gnat_node
)) != N_Attribute_Reference
8149 && Nkind (Parent (gnat_node
)) != N_Variant_Part
8150 && !lvalue_required_p (gnat_node
, gnu_result_type
, false, false))
8153 = build_binary_op (NE_EXPR
, gnu_result_type
,
8154 convert (gnu_result_type
, gnu_result
),
8155 convert (gnu_result_type
, boolean_false_node
));
8156 if (TREE_CODE (gnu_result
) != INTEGER_CST
)
8157 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
8160 /* Set the location information on the result if it's not a simple name
8161 or something that contains a simple name, for example a tag, because
8162 we don"t want all the references to get the location of the first use.
8163 Note that we may have no result if we tried to build a CALL_EXPR node
8164 to a procedure with no side-effects and optimization is enabled. */
8165 else if (kind
!= N_Identifier
8166 && !(kind
== N_Selected_Component
8167 && Chars (Selector_Name (gnat_node
)) == Name_uTag
)
8169 && EXPR_P (gnu_result
))
8170 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
8172 /* If we're supposed to return something of void_type, it means we have
8173 something we're elaborating for effect, so just return. */
8174 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
8177 /* If the result is a constant that overflowed, raise Constraint_Error. */
8178 if (TREE_CODE (gnu_result
) == INTEGER_CST
&& TREE_OVERFLOW (gnu_result
))
8180 post_error ("?`Constraint_Error` will be raised at run time", gnat_node
);
8182 = build1 (NULL_EXPR
, gnu_result_type
,
8183 build_call_raise (CE_Overflow_Check_Failed
, gnat_node
,
8184 N_Raise_Constraint_Error
));
8187 /* If the result has side-effects and is of an unconstrained type, protect
8188 the expression in case it will be referenced multiple times, i.e. for
8189 its value and to compute the size of an object. But do it neither for
8190 an object nor a renaming declaration, nor a return statement of a call
8191 to a function that returns an unconstrained record type with default
8192 discriminant, because there is no size to be computed in these cases
8193 and this will create a useless temporary. We must do this before any
8195 if (TREE_SIDE_EFFECTS (gnu_result
)
8196 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
8197 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
)))
8198 && !(TREE_CODE (gnu_result
) == CALL_EXPR
8199 && type_is_padding_self_referential (TREE_TYPE (gnu_result
))
8200 && (Nkind (Parent (gnat_node
)) == N_Object_Declaration
8201 || Nkind (Parent (gnat_node
)) == N_Object_Renaming_Declaration
8202 || Nkind (Parent (gnat_node
)) == N_Simple_Return_Statement
)))
8203 gnu_result
= gnat_protect_expr (gnu_result
);
8205 /* Now convert the result to the result type, unless we are in one of the
8208 1. If this is the LHS of an assignment or an actual parameter of a
8209 call, return the result almost unmodified since the RHS will have
8210 to be converted to our type in that case, unless the result type
8211 has a simpler size or for array types because this size might be
8212 changed in-between. Likewise if there is just a no-op unchecked
8213 conversion in-between. Similarly, don't convert integral types
8214 that are the operands of an unchecked conversion since we need
8215 to ignore those conversions (for 'Valid).
8217 2. If we have a label (which doesn't have any well-defined type), a
8218 field or an error, return the result almost unmodified. Similarly,
8219 if the two types are record types with the same name, don't convert.
8220 This will be the case when we are converting from a packable version
8221 of a type to its original type and we need those conversions to be
8222 NOPs in order for assignments into these types to work properly.
8224 3. If the type is void or if we have no result, return error_mark_node
8225 to show we have no result.
8227 4. If this is a call to a function that returns with variable size and
8228 the call is used as the expression in either an object or a renaming
8229 declaration, return the result unmodified because we want to use the
8230 return slot optimization in this case.
8232 5. If this is a reference to an unconstrained array which is used as the
8233 prefix of an attribute reference that requires an lvalue, return the
8234 result unmodified because we want to return the original bounds.
8236 6. Finally, if the type of the result is already correct. */
8238 if (Present (Parent (gnat_node
))
8239 && (lhs_or_actual_p (gnat_node
)
8240 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
8241 && unchecked_conversion_nop (Parent (gnat_node
)))
8242 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
8243 && !AGGREGATE_TYPE_P (gnu_result_type
)
8244 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))))
8245 && !(TYPE_SIZE (gnu_result_type
)
8246 && TYPE_SIZE (TREE_TYPE (gnu_result
))
8247 && AGGREGATE_TYPE_P (gnu_result_type
)
8248 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))
8249 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
8250 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
8252 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
8253 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
8254 && (CONTAINS_PLACEHOLDER_P
8255 (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
8256 || (TREE_CODE (gnu_result_type
) == ARRAY_TYPE
8257 && TREE_CODE (TREE_TYPE (gnu_result
)) == ARRAY_TYPE
))
8258 && !(TREE_CODE (gnu_result_type
) == RECORD_TYPE
8259 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type
))))
8261 /* Remove padding only if the inner object is of self-referential
8262 size: in that case it must be an object of unconstrained type
8263 with a default discriminant and we want to avoid copying too
8264 much data. But do not remove it if it is already too small. */
8265 if (type_is_padding_self_referential (TREE_TYPE (gnu_result
))
8266 && !(TREE_CODE (gnu_result
) == COMPONENT_REF
8267 && DECL_BIT_FIELD (TREE_OPERAND (gnu_result
, 1))))
8268 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
8272 else if (TREE_CODE (gnu_result
) == LABEL_DECL
8273 || TREE_CODE (gnu_result
) == FIELD_DECL
8274 || TREE_CODE (gnu_result
) == ERROR_MARK
8275 || (TYPE_NAME (gnu_result_type
)
8276 == TYPE_NAME (TREE_TYPE (gnu_result
))
8277 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
8278 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
))
8280 /* Remove any padding. */
8281 gnu_result
= maybe_padded_object (gnu_result
);
8284 else if (gnu_result
== error_mark_node
|| gnu_result_type
== void_type_node
)
8285 gnu_result
= error_mark_node
;
8287 else if (TREE_CODE (gnu_result
) == CALL_EXPR
8288 && Present (Parent (gnat_node
))
8289 && (Nkind (Parent (gnat_node
)) == N_Object_Declaration
8290 || Nkind (Parent (gnat_node
)) == N_Object_Renaming_Declaration
)
8291 && return_type_with_variable_size_p (TREE_TYPE (gnu_result
)))
8294 else if (TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
8295 && Present (Parent (gnat_node
))
8296 && Nkind (Parent (gnat_node
)) == N_Attribute_Reference
8297 && lvalue_required_for_attribute_p (Parent (gnat_node
)))
8300 else if (TREE_TYPE (gnu_result
) != gnu_result_type
)
8301 gnu_result
= convert (gnu_result_type
, gnu_result
);
8303 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
8304 while ((TREE_CODE (gnu_result
) == NOP_EXPR
8305 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
8306 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
8307 gnu_result
= TREE_OPERAND (gnu_result
, 0);
8312 /* Similar to gnat_to_gnu, but discard any object that might be created in
8313 the course of the translation of GNAT_NODE, which must be an "external"
8314 expression in the sense that it will be elaborated elsewhere. */
8317 gnat_to_gnu_external (Node_Id gnat_node
)
8319 const int save_force_global
= force_global
;
8320 bool went_into_elab_proc
= false;
8322 /* Force the local context and create a fake scope that we zap
8323 at the end so declarations will not be stuck either in the
8324 global varpool or in the current scope. */
8325 if (!current_function_decl
)
8327 current_function_decl
= get_elaboration_procedure ();
8328 went_into_elab_proc
= true;
8333 tree gnu_result
= gnat_to_gnu (gnat_node
);
8336 force_global
= save_force_global
;
8337 if (went_into_elab_proc
)
8338 current_function_decl
= NULL_TREE
;
8340 /* Do not import locations from external units. */
8341 if (gnu_result
&& EXPR_P (gnu_result
))
8342 SET_EXPR_LOCATION (gnu_result
, UNKNOWN_LOCATION
);
8347 /* Return true if the statement list STMT_LIST is empty. */
8350 empty_stmt_list_p (tree stmt_list
)
8352 tree_stmt_iterator tsi
;
8354 for (tsi
= tsi_start (stmt_list
); !tsi_end_p (tsi
); tsi_next (&tsi
))
8356 tree stmt
= tsi_stmt (tsi
);
8358 /* Anything else than an empty STMT_STMT counts as something. */
8359 if (TREE_CODE (stmt
) != STMT_STMT
|| STMT_STMT_STMT (stmt
))
8366 /* Record the current code position in GNAT_NODE. */
8369 record_code_position (Node_Id gnat_node
)
8371 tree stmt_stmt
= build1 (STMT_STMT
, void_type_node
, NULL_TREE
);
8373 add_stmt_with_node (stmt_stmt
, gnat_node
);
8374 save_gnu_tree (gnat_node
, stmt_stmt
, true);
8377 /* Insert the code for GNAT_NODE at the position saved for that node. */
8380 insert_code_for (Node_Id gnat_node
)
8382 tree code
= gnat_to_gnu (gnat_node
);
8384 /* It's too late to remove the STMT_STMT itself at this point. */
8385 if (!empty_stmt_list_p (code
))
8386 STMT_STMT_STMT (get_gnu_tree (gnat_node
)) = code
;
8388 save_gnu_tree (gnat_node
, NULL_TREE
, true);
8391 /* Start a new statement group chained to the previous group. */
8394 start_stmt_group (void)
8396 struct stmt_group
*group
= stmt_group_free_list
;
8398 /* First see if we can get one from the free list. */
8400 stmt_group_free_list
= group
->previous
;
8402 group
= ggc_alloc
<stmt_group
> ();
8404 group
->previous
= current_stmt_group
;
8405 group
->stmt_list
= group
->block
= group
->cleanups
= NULL_TREE
;
8406 current_stmt_group
= group
;
8409 /* Add GNU_STMT to the current statement group. If it is an expression with
8410 no effects, it is ignored. */
8413 add_stmt (tree gnu_stmt
)
8415 append_to_statement_list (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
8418 /* Similar, but the statement is always added, regardless of side-effects. */
8421 add_stmt_force (tree gnu_stmt
)
8423 append_to_statement_list_force (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
8426 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
8429 add_stmt_with_node (tree gnu_stmt
, Node_Id gnat_node
)
8431 if (Present (gnat_node
))
8432 set_expr_location_from_node (gnu_stmt
, gnat_node
);
8433 add_stmt (gnu_stmt
);
8436 /* Similar, but the statement is always added, regardless of side-effects. */
8439 add_stmt_with_node_force (tree gnu_stmt
, Node_Id gnat_node
)
8441 if (Present (gnat_node
))
8442 set_expr_location_from_node (gnu_stmt
, gnat_node
);
8443 add_stmt_force (gnu_stmt
);
8446 /* Add a declaration statement for GNU_DECL to the current statement group.
8447 Get the SLOC to be put onto the statement from GNAT_NODE. */
8450 add_decl_expr (tree gnu_decl
, Node_Id gnat_node
)
8452 tree type
= TREE_TYPE (gnu_decl
);
8453 tree gnu_stmt
, gnu_init
;
8455 /* If this is a variable that Gigi is to ignore, we may have been given
8456 an ERROR_MARK. So test for it. We also might have been given a
8457 reference for a renaming. So only do something for a decl. Also
8458 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
8459 if (!DECL_P (gnu_decl
)
8460 || (TREE_CODE (gnu_decl
) == TYPE_DECL
8461 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
))
8464 gnu_stmt
= build1 (DECL_EXPR
, void_type_node
, gnu_decl
);
8466 /* If we are external or global, we don't want to output the DECL_EXPR for
8467 this DECL node since we already have evaluated the expressions in the
8468 sizes and positions as globals and doing it again would be wrong. */
8469 if (DECL_EXTERNAL (gnu_decl
) || global_bindings_p ())
8471 /* Mark everything as used to prevent node sharing with subprograms.
8472 Note that walk_tree knows how to deal with TYPE_DECL, but neither
8473 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
8474 MARK_VISITED (gnu_stmt
);
8475 if (TREE_CODE (gnu_decl
) == VAR_DECL
8476 || TREE_CODE (gnu_decl
) == CONST_DECL
)
8478 MARK_VISITED (DECL_SIZE (gnu_decl
));
8479 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl
));
8480 MARK_VISITED (DECL_INITIAL (gnu_decl
));
8482 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
8483 else if (TREE_CODE (gnu_decl
) == TYPE_DECL
8484 && RECORD_OR_UNION_TYPE_P (type
)
8485 && !TYPE_FAT_POINTER_P (type
))
8486 MARK_VISITED (TYPE_ADA_SIZE (type
));
8489 add_stmt_with_node (gnu_stmt
, gnat_node
);
8491 /* If this is a variable and an initializer is attached to it, it must be
8492 valid for the context. Similar to init_const in create_var_decl. */
8493 if (TREE_CODE (gnu_decl
) == VAR_DECL
8494 && (gnu_init
= DECL_INITIAL (gnu_decl
))
8495 && (!gnat_types_compatible_p (type
, TREE_TYPE (gnu_init
))
8496 || (TREE_STATIC (gnu_decl
)
8497 && !initializer_constant_valid_p (gnu_init
,
8498 TREE_TYPE (gnu_init
)))))
8500 DECL_INITIAL (gnu_decl
) = NULL_TREE
;
8501 if (TREE_READONLY (gnu_decl
))
8503 TREE_READONLY (gnu_decl
) = 0;
8504 DECL_READONLY_ONCE_ELAB (gnu_decl
) = 1;
8507 /* Remove any padding so the assignment is done properly. */
8508 gnu_decl
= maybe_padded_object (gnu_decl
);
8510 gnu_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_decl
, gnu_init
);
8511 add_stmt_with_node (gnu_stmt
, gnat_node
);
8515 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
8518 mark_visited_r (tree
*tp
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
8522 if (TREE_VISITED (t
))
8525 /* Don't mark a dummy type as visited because we want to mark its sizes
8526 and fields once it's filled in. */
8527 else if (!TYPE_IS_DUMMY_P (t
))
8528 TREE_VISITED (t
) = 1;
8530 /* The test in gimplify_type_sizes is on the main variant. */
8532 TYPE_SIZES_GIMPLIFIED (TYPE_MAIN_VARIANT (t
)) = 1;
8537 /* Mark nodes rooted at T with TREE_VISITED and types as having their
8538 sized gimplified. We use this to indicate all variable sizes and
8539 positions in global types may not be shared by any subprogram. */
8542 mark_visited (tree t
)
8544 walk_tree (&t
, mark_visited_r
, NULL
, NULL
);
8547 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
8548 set its location to that of GNAT_NODE if present, but with column info
8549 cleared so that conditional branches generated as part of the cleanup
8550 code do not interfere with coverage analysis tools. */
8553 add_cleanup (tree gnu_cleanup
, Node_Id gnat_node
)
8555 if (Present (gnat_node
))
8556 set_expr_location_from_node (gnu_cleanup
, gnat_node
, true);
8558 /* An EH_ELSE_EXPR must be by itself, and that's all we need when we
8559 use it. The assert below makes sure that is so. Should we ever
8560 need more than that, we could combine EH_ELSE_EXPRs, and copy
8561 non-EH_ELSE_EXPR stmts into both cleanup paths of an
8563 if (TREE_CODE (gnu_cleanup
) == EH_ELSE_EXPR
)
8565 gcc_assert (!current_stmt_group
->cleanups
);
8566 current_stmt_group
->cleanups
= gnu_cleanup
;
8570 gcc_assert (!current_stmt_group
->cleanups
8571 || (TREE_CODE (current_stmt_group
->cleanups
)
8573 append_to_statement_list (gnu_cleanup
, ¤t_stmt_group
->cleanups
);
8577 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
8580 set_block_for_group (tree gnu_block
)
8582 gcc_assert (!current_stmt_group
->block
);
8583 current_stmt_group
->block
= gnu_block
;
8586 /* Return code corresponding to the current code group. It is normally
8587 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
8588 BLOCK or cleanups were set. */
8591 end_stmt_group (void)
8593 struct stmt_group
*group
= current_stmt_group
;
8594 tree gnu_retval
= group
->stmt_list
;
8596 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
8597 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
8598 make a BIND_EXPR. Note that we nest in that because the cleanup may
8599 reference variables in the block. */
8601 gnu_retval
= alloc_stmt_list ();
8603 if (group
->cleanups
)
8604 gnu_retval
= build2 (TRY_FINALLY_EXPR
, void_type_node
, gnu_retval
,
8607 if (current_stmt_group
->block
)
8608 gnu_retval
= build3 (BIND_EXPR
, void_type_node
, BLOCK_VARS (group
->block
),
8609 gnu_retval
, group
->block
);
8611 /* Remove this group from the stack and add it to the free list. */
8612 current_stmt_group
= group
->previous
;
8613 group
->previous
= stmt_group_free_list
;
8614 stmt_group_free_list
= group
;
8619 /* Return whether the current statement group may fall through. */
8622 stmt_group_may_fallthru (void)
8624 if (current_stmt_group
->stmt_list
)
8625 return block_may_fallthru (current_stmt_group
->stmt_list
);
8630 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
8634 add_stmt_list (List_Id gnat_list
)
8638 if (Present (gnat_list
))
8639 for (gnat_node
= First (gnat_list
); Present (gnat_node
);
8640 gnat_node
= Next (gnat_node
))
8641 add_stmt (gnat_to_gnu (gnat_node
));
8644 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
8645 If BINDING_P is true, push and pop a binding level around the list. */
8648 build_stmt_group (List_Id gnat_list
, bool binding_p
)
8650 start_stmt_group ();
8655 add_stmt_list (gnat_list
);
8660 return end_stmt_group ();
8663 /* Generate GIMPLE in place for the expression at *EXPR_P. */
8666 gnat_gimplify_expr (tree
*expr_p
, gimple_seq
*pre_p
,
8667 gimple_seq
*post_p ATTRIBUTE_UNUSED
)
8669 tree expr
= *expr_p
;
8670 tree type
= TREE_TYPE (expr
);
8673 if (IS_ADA_STMT (expr
))
8674 return gnat_gimplify_stmt (expr_p
);
8676 switch (TREE_CODE (expr
))
8679 /* If this is an aggregate type, build a null pointer of the appropriate
8680 type and dereference it. */
8681 if (AGGREGATE_TYPE_P (type
)
8682 || TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
8683 *expr_p
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
8684 convert (build_pointer_type (type
),
8685 integer_zero_node
));
8686 /* Otherwise, just make a VAR_DECL. */
8689 *expr_p
= create_tmp_var (type
, NULL
);
8690 TREE_NO_WARNING (*expr_p
) = 1;
8693 gimplify_and_add (TREE_OPERAND (expr
, 0), pre_p
);
8696 case UNCONSTRAINED_ARRAY_REF
:
8697 /* We should only do this if we are just elaborating for side-effects,
8698 but we can't know that yet. */
8699 *expr_p
= TREE_OPERAND (*expr_p
, 0);
8703 op
= TREE_OPERAND (expr
, 0);
8705 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
8706 is put into static memory. We know that it's going to be read-only
8707 given the semantics we have and it must be in static memory when the
8708 reference is in an elaboration procedure. */
8709 if (TREE_CODE (op
) == CONSTRUCTOR
&& TREE_CONSTANT (op
))
8711 tree addr
= build_fold_addr_expr (tree_output_constant_def (op
));
8712 *expr_p
= fold_convert (type
, addr
);
8716 /* Replace atomic loads with their first argument. That's necessary
8717 because the gimplifier would create a temporary otherwise. */
8718 if (TREE_SIDE_EFFECTS (op
))
8719 while (handled_component_p (op
) || CONVERT_EXPR_P (op
))
8721 tree inner
= TREE_OPERAND (op
, 0);
8722 if (TREE_CODE (inner
) == CALL_EXPR
&& call_is_atomic_load (inner
))
8724 tree t
= CALL_EXPR_ARG (inner
, 0);
8725 if (TREE_CODE (t
) == NOP_EXPR
)
8726 t
= TREE_OPERAND (t
, 0);
8727 if (TREE_CODE (t
) == ADDR_EXPR
)
8728 TREE_OPERAND (op
, 0) = TREE_OPERAND (t
, 0);
8730 TREE_OPERAND (op
, 0) = build_fold_indirect_ref (t
);
8736 return GS_UNHANDLED
;
8738 case VIEW_CONVERT_EXPR
:
8739 op
= TREE_OPERAND (expr
, 0);
8741 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
8742 type to a scalar one, explicitly create the local temporary. That's
8743 required if the type is passed by reference. */
8744 if ((TREE_CODE (op
) == CONSTRUCTOR
|| TREE_CODE (op
) == CALL_EXPR
)
8745 && AGGREGATE_TYPE_P (TREE_TYPE (op
))
8746 && !AGGREGATE_TYPE_P (type
))
8748 tree mod
, new_var
= create_tmp_var_raw (TREE_TYPE (op
), "C");
8749 gimple_add_tmp_var (new_var
);
8751 mod
= build2 (INIT_EXPR
, TREE_TYPE (new_var
), new_var
, op
);
8752 gimplify_and_add (mod
, pre_p
);
8754 TREE_OPERAND (expr
, 0) = new_var
;
8758 return GS_UNHANDLED
;
8761 op
= DECL_EXPR_DECL (expr
);
8763 /* The expressions for the RM bounds must be gimplified to ensure that
8764 they are properly elaborated. See gimplify_decl_expr. */
8765 if ((TREE_CODE (op
) == TYPE_DECL
|| TREE_CODE (op
) == VAR_DECL
)
8766 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op
)))
8767 switch (TREE_CODE (TREE_TYPE (op
)))
8774 tree type
= TYPE_MAIN_VARIANT (TREE_TYPE (op
)), t
, val
;
8776 val
= TYPE_RM_MIN_VALUE (type
);
8779 gimplify_one_sizepos (&val
, pre_p
);
8780 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
8781 SET_TYPE_RM_MIN_VALUE (t
, val
);
8784 val
= TYPE_RM_MAX_VALUE (type
);
8787 gimplify_one_sizepos (&val
, pre_p
);
8788 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
8789 SET_TYPE_RM_MAX_VALUE (t
, val
);
8799 /* ... fall through ... */
8802 return GS_UNHANDLED
;
8806 /* Generate GIMPLE in place for the statement at *STMT_P. */
8808 static enum gimplify_status
8809 gnat_gimplify_stmt (tree
*stmt_p
)
8811 tree stmt
= *stmt_p
;
8813 switch (TREE_CODE (stmt
))
8816 *stmt_p
= STMT_STMT_STMT (stmt
);
8821 tree gnu_start_label
= create_artificial_label (input_location
);
8822 tree gnu_cond
= LOOP_STMT_COND (stmt
);
8823 tree gnu_update
= LOOP_STMT_UPDATE (stmt
);
8824 tree gnu_end_label
= LOOP_STMT_LABEL (stmt
);
8826 /* Build the condition expression from the test, if any. */
8829 /* Deal with the optimization hints. */
8830 if (LOOP_STMT_IVDEP (stmt
))
8831 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8832 build_int_cst (integer_type_node
,
8833 annot_expr_ivdep_kind
),
8835 if (LOOP_STMT_NO_UNROLL (stmt
))
8836 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8837 build_int_cst (integer_type_node
,
8838 annot_expr_unroll_kind
),
8840 if (LOOP_STMT_UNROLL (stmt
))
8841 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8842 build_int_cst (integer_type_node
,
8843 annot_expr_unroll_kind
),
8844 build_int_cst (NULL_TREE
, USHRT_MAX
));
8845 if (LOOP_STMT_NO_VECTOR (stmt
))
8846 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8847 build_int_cst (integer_type_node
,
8848 annot_expr_no_vector_kind
),
8850 if (LOOP_STMT_VECTOR (stmt
))
8851 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8852 build_int_cst (integer_type_node
,
8853 annot_expr_vector_kind
),
8857 = build3 (COND_EXPR
, void_type_node
, gnu_cond
, NULL_TREE
,
8858 build1 (GOTO_EXPR
, void_type_node
, gnu_end_label
));
8861 /* Set to emit the statements of the loop. */
8862 *stmt_p
= NULL_TREE
;
8864 /* We first emit the start label and then a conditional jump to the
8865 end label if there's a top condition, then the update if it's at
8866 the top, then the body of the loop, then a conditional jump to
8867 the end label if there's a bottom condition, then the update if
8868 it's at the bottom, and finally a jump to the start label and the
8869 definition of the end label. */
8870 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
8874 if (gnu_cond
&& !LOOP_STMT_BOTTOM_COND_P (stmt
))
8875 append_to_statement_list (gnu_cond
, stmt_p
);
8877 if (gnu_update
&& LOOP_STMT_TOP_UPDATE_P (stmt
))
8878 append_to_statement_list (gnu_update
, stmt_p
);
8880 append_to_statement_list (LOOP_STMT_BODY (stmt
), stmt_p
);
8882 if (gnu_cond
&& LOOP_STMT_BOTTOM_COND_P (stmt
))
8883 append_to_statement_list (gnu_cond
, stmt_p
);
8885 if (gnu_update
&& !LOOP_STMT_TOP_UPDATE_P (stmt
))
8886 append_to_statement_list (gnu_update
, stmt_p
);
8888 tree t
= build1 (GOTO_EXPR
, void_type_node
, gnu_start_label
);
8889 SET_EXPR_LOCATION (t
, DECL_SOURCE_LOCATION (gnu_end_label
));
8890 append_to_statement_list (t
, stmt_p
);
8892 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
8899 /* Build a statement to jump to the corresponding end label, then
8900 see if it needs to be conditional. */
8901 *stmt_p
= build1 (GOTO_EXPR
, void_type_node
, EXIT_STMT_LABEL (stmt
));
8902 if (EXIT_STMT_COND (stmt
))
8903 *stmt_p
= build3 (COND_EXPR
, void_type_node
,
8904 EXIT_STMT_COND (stmt
), *stmt_p
, alloc_stmt_list ());
8912 /* Force a reference to each of the entities in GNAT_PACKAGE recursively.
8914 This routine is exclusively called in type_annotate mode, to compute DDA
8915 information for types in withed units, for ASIS use. */
8918 elaborate_all_entities_for_package (Entity_Id gnat_package
)
8920 Entity_Id gnat_entity
;
8922 for (gnat_entity
= First_Entity (gnat_package
);
8923 Present (gnat_entity
);
8924 gnat_entity
= Next_Entity (gnat_entity
))
8926 const Entity_Kind kind
= Ekind (gnat_entity
);
8928 /* We are interested only in entities visible from the main unit. */
8929 if (!Is_Public (gnat_entity
))
8932 /* Skip stuff internal to the compiler. */
8933 if (Convention (gnat_entity
) == Convention_Intrinsic
)
8935 if (kind
== E_Operator
)
8937 if (IN (kind
, Subprogram_Kind
)
8938 && (Present (Alias (gnat_entity
))
8939 || Is_Intrinsic_Subprogram (gnat_entity
)))
8941 if (Is_Itype (gnat_entity
))
8944 /* Skip named numbers. */
8945 if (IN (kind
, Named_Kind
))
8948 /* Skip generic declarations. */
8949 if (IN (kind
, Generic_Unit_Kind
))
8952 /* Skip formal objects. */
8953 if (IN (kind
, Formal_Object_Kind
))
8956 /* Skip package bodies. */
8957 if (kind
== E_Package_Body
)
8960 /* Skip limited views that point back to the main unit. */
8961 if (IN (kind
, Incomplete_Kind
)
8962 && From_Limited_With (gnat_entity
)
8963 && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_entity
)))
8966 /* Skip types that aren't frozen. */
8967 if (IN (kind
, Type_Kind
) && !Is_Frozen (gnat_entity
))
8970 /* Recurse on real packages that aren't in the main unit. */
8971 if (kind
== E_Package
)
8973 if (No (Renamed_Entity (gnat_entity
))
8974 && !In_Extended_Main_Code_Unit (gnat_entity
))
8975 elaborate_all_entities_for_package (gnat_entity
);
8978 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
8982 /* Force a reference to each of the entities in packages withed by GNAT_NODE.
8983 Operate recursively but check that we aren't elaborating something more
8986 This routine is exclusively called in type_annotate mode, to compute DDA
8987 information for types in withed units, for ASIS use. */
8990 elaborate_all_entities (Node_Id gnat_node
)
8992 Entity_Id gnat_with_clause
;
8994 /* Process each unit only once. As we trace the context of all relevant
8995 units transitively, including generic bodies, we may encounter the
8996 same generic unit repeatedly. */
8997 if (!present_gnu_tree (gnat_node
))
8998 save_gnu_tree (gnat_node
, integer_zero_node
, true);
9000 /* Save entities in all context units. A body may have an implicit_with
9001 on its own spec, if the context includes a child unit, so don't save
9003 for (gnat_with_clause
= First (Context_Items (gnat_node
));
9004 Present (gnat_with_clause
);
9005 gnat_with_clause
= Next (gnat_with_clause
))
9006 if (Nkind (gnat_with_clause
) == N_With_Clause
9007 && !present_gnu_tree (Library_Unit (gnat_with_clause
))
9008 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
9010 Node_Id gnat_unit
= Library_Unit (gnat_with_clause
);
9011 Entity_Id gnat_entity
= Entity (Name (gnat_with_clause
));
9013 elaborate_all_entities (gnat_unit
);
9015 if (Ekind (gnat_entity
) == E_Package
9016 && No (Renamed_Entity (gnat_entity
)))
9017 elaborate_all_entities_for_package (gnat_entity
);
9019 else if (Ekind (gnat_entity
) == E_Generic_Package
)
9021 Node_Id gnat_body
= Corresponding_Body (Unit (gnat_unit
));
9023 /* Retrieve compilation unit node of generic body. */
9024 while (Present (gnat_body
)
9025 && Nkind (gnat_body
) != N_Compilation_Unit
)
9026 gnat_body
= Parent (gnat_body
);
9028 /* If body is available, elaborate its context. */
9029 if (Present (gnat_body
))
9030 elaborate_all_entities (gnat_body
);
9034 if (Nkind (Unit (gnat_node
)) == N_Package_Body
)
9035 elaborate_all_entities (Library_Unit (gnat_node
));
9038 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
9041 process_freeze_entity (Node_Id gnat_node
)
9043 const Entity_Id gnat_entity
= Entity (gnat_node
);
9044 const Entity_Kind kind
= Ekind (gnat_entity
);
9045 tree gnu_old
, gnu_new
;
9047 /* If this is a package, generate code for the package body, if any. */
9048 if (kind
== E_Package
)
9050 const Node_Id gnat_decl
= Parent (Declaration_Node (gnat_entity
));
9051 if (Present (Corresponding_Body (gnat_decl
)))
9052 insert_code_for (Parent (Corresponding_Body (gnat_decl
)));
9056 /* Don't do anything for class-wide types as they are always transformed
9057 into their root type. */
9058 if (kind
== E_Class_Wide_Type
)
9061 /* Check for an old definition if this isn't an object with address clause,
9062 since the saved GCC tree is the address expression in that case. */
9064 = present_gnu_tree (gnat_entity
) && No (Address_Clause (gnat_entity
))
9065 ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
9067 /* Don't do anything for subprograms that may have been elaborated before
9068 their freeze nodes. This can happen, for example, because of an inner
9069 call in an instance body or because of previous compilation of a spec
9070 for inlining purposes. */
9072 && ((TREE_CODE (gnu_old
) == FUNCTION_DECL
9073 && (kind
== E_Function
|| kind
== E_Procedure
))
9074 || (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_old
))
9075 && kind
== E_Subprogram_Type
)))
9078 /* If we have a non-dummy type old tree, we have nothing to do, except for
9079 aborting, since this node was never delayed as it should have been. We
9080 let this happen for concurrent types and their Corresponding_Record_Type,
9081 however, because each might legitimately be elaborated before its own
9082 freeze node, e.g. while processing the other. */
9084 && !(TREE_CODE (gnu_old
) == TYPE_DECL
9085 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
9087 gcc_assert (Is_Concurrent_Type (gnat_entity
)
9088 || (Is_Record_Type (gnat_entity
)
9089 && Is_Concurrent_Record_Type (gnat_entity
)));
9093 /* Reset the saved tree, if any, and elaborate the object or type for real.
9094 If there is a full view, elaborate it and use the result. And, if this
9095 is the root type of a class-wide type, reuse it for the latter. */
9098 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
9100 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9101 && Present (Full_View (gnat_entity
)))
9103 Entity_Id full_view
= Full_View (gnat_entity
);
9105 save_gnu_tree (full_view
, NULL_TREE
, false);
9107 if (Is_Private_Type (full_view
)
9108 && Present (Underlying_Full_View (full_view
)))
9110 full_view
= Underlying_Full_View (full_view
);
9111 save_gnu_tree (full_view
, NULL_TREE
, false);
9115 if (Is_Type (gnat_entity
)
9116 && Present (Class_Wide_Type (gnat_entity
))
9117 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
9118 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, false);
9121 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9122 && Present (Full_View (gnat_entity
)))
9124 Entity_Id full_view
= Full_View (gnat_entity
);
9126 if (Is_Private_Type (full_view
)
9127 && Present (Underlying_Full_View (full_view
)))
9128 full_view
= Underlying_Full_View (full_view
);
9130 gnu_new
= gnat_to_gnu_entity (full_view
, NULL_TREE
, true);
9132 /* Propagate back-annotations from full view to partial view. */
9133 if (Unknown_Alignment (gnat_entity
))
9134 Set_Alignment (gnat_entity
, Alignment (full_view
));
9136 if (Unknown_Esize (gnat_entity
))
9137 Set_Esize (gnat_entity
, Esize (full_view
));
9139 if (Unknown_RM_Size (gnat_entity
))
9140 Set_RM_Size (gnat_entity
, RM_Size (full_view
));
9142 /* The above call may have defined this entity (the simplest example
9143 of this is when we have a private enumeral type since the bounds
9144 will have the public view). */
9145 if (!present_gnu_tree (gnat_entity
))
9146 save_gnu_tree (gnat_entity
, gnu_new
, false);
9151 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
9152 && present_gnu_tree (Declaration_Node (gnat_entity
)))
9153 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
9155 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, true);
9158 if (Is_Type (gnat_entity
)
9159 && Present (Class_Wide_Type (gnat_entity
))
9160 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
9161 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, false);
9163 /* If we have an old type and we've made pointers to this type, update those
9164 pointers. If this is a Taft amendment type in the main unit, we need to
9165 mark the type as used since other units referencing it don't see the full
9166 declaration and, therefore, cannot mark it as used themselves. */
9169 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
9170 TREE_TYPE (gnu_new
));
9171 if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old
)))
9172 update_profiles_with (TREE_TYPE (gnu_old
));
9173 if (DECL_TAFT_TYPE_P (gnu_old
))
9174 used_types_insert (TREE_TYPE (gnu_new
));
9178 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
9179 We make two passes, one to elaborate anything other than bodies (but
9180 we declare a function if there was no spec). The second pass
9181 elaborates the bodies.
9183 GNAT_END_LIST gives the element in the list past the end. Normally,
9184 this is Empty, but can be First_Real_Statement for a
9185 Handled_Sequence_Of_Statements.
9187 We make a complete pass through both lists if PASS1P is true, then make
9188 the second pass over both lists if PASS2P is true. The lists usually
9189 correspond to the public and private parts of a package. */
9192 process_decls (List_Id gnat_decls
, List_Id gnat_decls2
,
9193 Node_Id gnat_end_list
, bool pass1p
, bool pass2p
)
9195 List_Id gnat_decl_array
[2];
9199 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
9202 for (i
= 0; i
<= 1; i
++)
9203 if (Present (gnat_decl_array
[i
]))
9204 for (gnat_decl
= First (gnat_decl_array
[i
]);
9205 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
9207 /* For package specs, we recurse inside the declarations,
9208 thus taking the two pass approach inside the boundary. */
9209 if (Nkind (gnat_decl
) == N_Package_Declaration
9210 && (Nkind (Specification (gnat_decl
)
9211 == N_Package_Specification
)))
9212 process_decls (Visible_Declarations (Specification (gnat_decl
)),
9213 Private_Declarations (Specification (gnat_decl
)),
9214 Empty
, true, false);
9216 /* Similarly for any declarations in the actions of a
9218 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
9220 process_freeze_entity (gnat_decl
);
9221 process_decls (Actions (gnat_decl
), Empty
, Empty
, true, false);
9224 /* Package bodies with freeze nodes get their elaboration deferred
9225 until the freeze node, but the code must be placed in the right
9226 place, so record the code position now. */
9227 else if (Nkind (gnat_decl
) == N_Package_Body
9228 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
9229 record_code_position (gnat_decl
);
9231 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
9232 && Present (Library_Unit (gnat_decl
))
9233 && Present (Freeze_Node
9236 (Library_Unit (gnat_decl
)))))))
9237 record_code_position
9238 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
9240 /* We defer most subprogram bodies to the second pass. */
9241 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
9243 if (Acts_As_Spec (gnat_decl
))
9245 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
9247 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
9248 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
9249 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, true);
9253 /* For bodies and stubs that act as their own specs, the entity
9254 itself must be elaborated in the first pass, because it may
9255 be used in other declarations. */
9256 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
9258 Node_Id gnat_subprog_id
9259 = Defining_Entity (Specification (gnat_decl
));
9261 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
9262 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
9263 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
9264 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, true);
9267 /* Concurrent stubs stand for the corresponding subprogram bodies,
9268 which are deferred like other bodies. */
9269 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
9270 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
9273 /* Renamed subprograms may not be elaborated yet at this point
9274 since renamings do not trigger freezing. Wait for the second
9275 pass to take care of them. */
9276 else if (Nkind (gnat_decl
) == N_Subprogram_Renaming_Declaration
)
9280 add_stmt (gnat_to_gnu (gnat_decl
));
9283 /* Here we elaborate everything we deferred above except for package bodies,
9284 which are elaborated at their freeze nodes. Note that we must also
9285 go inside things (package specs and freeze nodes) the first pass did. */
9287 for (i
= 0; i
<= 1; i
++)
9288 if (Present (gnat_decl_array
[i
]))
9289 for (gnat_decl
= First (gnat_decl_array
[i
]);
9290 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
9292 if (Nkind (gnat_decl
) == N_Subprogram_Body
9293 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
9294 || Nkind (gnat_decl
) == N_Task_Body_Stub
9295 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
9296 add_stmt (gnat_to_gnu (gnat_decl
));
9298 else if (Nkind (gnat_decl
) == N_Package_Declaration
9299 && (Nkind (Specification (gnat_decl
)
9300 == N_Package_Specification
)))
9301 process_decls (Visible_Declarations (Specification (gnat_decl
)),
9302 Private_Declarations (Specification (gnat_decl
)),
9303 Empty
, false, true);
9305 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
9306 process_decls (Actions (gnat_decl
), Empty
, Empty
, false, true);
9308 else if (Nkind (gnat_decl
) == N_Subprogram_Renaming_Declaration
)
9309 add_stmt (gnat_to_gnu (gnat_decl
));
9313 /* Make a unary operation of kind CODE using build_unary_op, but guard
9314 the operation by an overflow check. CODE can be one of NEGATE_EXPR
9315 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
9316 the operation is to be performed in that type. GNAT_NODE is the gnat
9317 node conveying the source location for which the error should be
9321 build_unary_op_trapv (enum tree_code code
, tree gnu_type
, tree operand
,
9324 gcc_assert (code
== NEGATE_EXPR
|| code
== ABS_EXPR
);
9326 operand
= gnat_protect_expr (operand
);
9328 return emit_check (build_binary_op (EQ_EXPR
, boolean_type_node
,
9329 operand
, TYPE_MIN_VALUE (gnu_type
)),
9330 build_unary_op (code
, gnu_type
, operand
),
9331 CE_Overflow_Check_Failed
, gnat_node
);
9334 /* Make a binary operation of kind CODE using build_binary_op, but guard
9335 the operation by an overflow check. CODE can be one of PLUS_EXPR,
9336 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
9337 Usually the operation is to be performed in that type. GNAT_NODE is
9338 the GNAT node conveying the source location for which the error should
9342 build_binary_op_trapv (enum tree_code code
, tree gnu_type
, tree left
,
9343 tree right
, Node_Id gnat_node
)
9345 const unsigned int precision
= TYPE_PRECISION (gnu_type
);
9346 tree lhs
= gnat_protect_expr (left
);
9347 tree rhs
= gnat_protect_expr (right
);
9348 tree type_max
= TYPE_MAX_VALUE (gnu_type
);
9349 tree type_min
= TYPE_MIN_VALUE (gnu_type
);
9350 tree gnu_expr
, check
;
9353 /* Assert that the precision is a power of 2. */
9354 gcc_assert ((precision
& (precision
- 1)) == 0);
9356 /* Prefer a constant on the RHS to simplify checks. */
9357 if (TREE_CODE (rhs
) != INTEGER_CST
9358 && TREE_CODE (lhs
) == INTEGER_CST
9359 && (code
== PLUS_EXPR
|| code
== MULT_EXPR
))
9366 gnu_expr
= build_binary_op (code
, gnu_type
, lhs
, rhs
);
9368 /* If we can fold the expression to a constant, just return it.
9369 The caller will deal with overflow, no need to generate a check. */
9370 if (TREE_CODE (gnu_expr
) == INTEGER_CST
)
9373 /* If no operand is a constant, we use the generic implementation. */
9374 if (TREE_CODE (lhs
) != INTEGER_CST
&& TREE_CODE (rhs
) != INTEGER_CST
)
9376 /* First convert the operands to the result type like build_binary_op.
9377 This is where the bias is made explicit for biased types. */
9378 lhs
= convert (gnu_type
, lhs
);
9379 rhs
= convert (gnu_type
, rhs
);
9381 /* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
9382 if (code
== MULT_EXPR
&& precision
== 64 && BITS_PER_WORD
< 64)
9384 tree int64
= gnat_type_for_size (64, 0);
9385 return convert (gnu_type
, build_call_n_expr (mulv64_decl
, 2,
9386 convert (int64
, lhs
),
9387 convert (int64
, rhs
)));
9390 /* Likewise for a 128-bit mult and a 64-bit target. */
9391 else if (code
== MULT_EXPR
&& precision
== 128 && BITS_PER_WORD
< 128)
9393 tree int128
= gnat_type_for_size (128, 0);
9394 return convert (gnu_type
, build_call_n_expr (mulv128_decl
, 2,
9395 convert (int128
, lhs
),
9396 convert (int128
, rhs
)));
9399 enum internal_fn icode
;
9404 icode
= IFN_ADD_OVERFLOW
;
9407 icode
= IFN_SUB_OVERFLOW
;
9410 icode
= IFN_MUL_OVERFLOW
;
9416 tree gnu_ctype
= build_complex_type (gnu_type
);
9418 = build_call_expr_internal_loc (UNKNOWN_LOCATION
, icode
, gnu_ctype
, 2,
9420 tree tgt
= save_expr (call
);
9421 gnu_expr
= build1 (REALPART_EXPR
, gnu_type
, tgt
);
9422 check
= fold_build2 (NE_EXPR
, boolean_type_node
,
9423 build1 (IMAGPART_EXPR
, gnu_type
, tgt
),
9424 build_int_cst (gnu_type
, 0));
9426 emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
9429 /* If one operand is a constant, we expose the overflow condition to enable
9430 a subsequent simplication or even elimination. */
9434 sgn
= tree_int_cst_sgn (rhs
);
9436 /* When rhs > 0, overflow when lhs > type_max - rhs. */
9437 check
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
9438 build_binary_op (MINUS_EXPR
, gnu_type
,
9441 /* When rhs < 0, overflow when lhs < type_min - rhs. */
9442 check
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
9443 build_binary_op (MINUS_EXPR
, gnu_type
,
9450 if (TREE_CODE (lhs
) == INTEGER_CST
)
9452 sgn
= tree_int_cst_sgn (lhs
);
9454 /* When lhs > 0, overflow when rhs < lhs - type_max. */
9455 check
= build_binary_op (LT_EXPR
, boolean_type_node
, rhs
,
9456 build_binary_op (MINUS_EXPR
, gnu_type
,
9459 /* When lhs < 0, overflow when rhs > lhs - type_min. */
9460 check
= build_binary_op (GT_EXPR
, boolean_type_node
, rhs
,
9461 build_binary_op (MINUS_EXPR
, gnu_type
,
9468 sgn
= tree_int_cst_sgn (rhs
);
9470 /* When rhs > 0, overflow when lhs < type_min + rhs. */
9471 check
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
9472 build_binary_op (PLUS_EXPR
, gnu_type
,
9475 /* When rhs < 0, overflow when lhs > type_max + rhs. */
9476 check
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
9477 build_binary_op (PLUS_EXPR
, gnu_type
,
9485 sgn
= tree_int_cst_sgn (rhs
);
9488 if (integer_onep (rhs
))
9491 tree lb
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
9492 tree ub
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
9494 /* When rhs > 1, overflow outside [type_min/rhs; type_max/rhs]. */
9496 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
9497 build_binary_op (LT_EXPR
, boolean_type_node
,
9499 build_binary_op (GT_EXPR
, boolean_type_node
,
9504 tree lb
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
9505 tree ub
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
9507 if (integer_minus_onep (rhs
))
9508 /* When rhs == -1, overflow if lhs == type_min. */
9510 = build_binary_op (EQ_EXPR
, boolean_type_node
, lhs
, type_min
);
9512 /* When rhs < -1, overflow outside [type_max/rhs; type_min/rhs]. */
9514 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
9515 build_binary_op (LT_EXPR
, boolean_type_node
,
9517 build_binary_op (GT_EXPR
, boolean_type_node
,
9528 return emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
9531 /* GNU_COND contains the condition corresponding to an index, overflow or
9532 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
9533 if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
9534 REASON is the code that says why the exception is raised. GNAT_NODE is
9535 the node conveying the source location for which the error should be
9538 We used to propagate TREE_SIDE_EFFECTS from GNU_EXPR to the COND_EXPR,
9539 overwriting the setting inherited from the call statement, on the ground
9540 that the expression need not be evaluated just for the check. However
9541 that's incorrect because, in the GCC type system, its value is presumed
9542 to be valid so its comparison against the type bounds always yields true
9543 and, therefore, could be done without evaluating it; given that it can
9544 be a computation that overflows the bounds, the language may require the
9545 check to fail and thus the expression to be evaluated in this case. */
9548 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
, Node_Id gnat_node
)
9551 = build_call_raise (reason
, gnat_node
, N_Raise_Constraint_Error
);
9553 fold_build3 (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
9554 build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_call
,
9555 SCALAR_FLOAT_TYPE_P (TREE_TYPE (gnu_expr
))
9556 ? build_real (TREE_TYPE (gnu_expr
), dconst0
)
9557 : build_int_cst (TREE_TYPE (gnu_expr
), 0)),
9561 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
9562 checks if OVERFLOW_P is true. If TRUNCATE_P is true, do a fp-to-integer
9563 conversion with truncation, otherwise round. GNAT_NODE is the GNAT node
9564 conveying the source location for which the error should be signaled. */
9567 convert_with_check (Entity_Id gnat_type
, tree gnu_expr
, bool overflow_p
,
9568 bool truncate_p
, Node_Id gnat_node
)
9570 tree gnu_type
= get_unpadded_type (gnat_type
);
9571 tree gnu_base_type
= get_base_type (gnu_type
);
9572 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
9573 tree gnu_in_base_type
= get_base_type (gnu_in_type
);
9574 tree gnu_result
= gnu_expr
;
9576 /* If we are not doing any checks, the output is an integral type and the
9577 input is not a floating-point type, just do the conversion. This is
9578 required for packed array types and is simpler in all cases anyway. */
9580 && INTEGRAL_TYPE_P (gnu_base_type
)
9581 && !FLOAT_TYPE_P (gnu_in_base_type
))
9582 return convert (gnu_type
, gnu_expr
);
9584 /* If the mode of the input base type is larger, then converting to it below
9585 may pessimize the final conversion step, for example generate a libcall
9586 instead of a simple instruction, so use a narrower type in this case. */
9587 if (TYPE_MODE (gnu_in_base_type
) != TYPE_MODE (gnu_in_type
)
9588 && !(TREE_CODE (gnu_in_type
) == INTEGER_TYPE
9589 && TYPE_BIASED_REPRESENTATION_P (gnu_in_type
)))
9590 gnu_in_base_type
= gnat_type_for_mode (TYPE_MODE (gnu_in_type
),
9591 TYPE_UNSIGNED (gnu_in_type
));
9593 /* First convert the expression to the base type. This will never generate
9594 code, but makes the tests below simpler. But don't do this if converting
9595 from an integer type to an unconstrained array type since then we need to
9596 get the bounds from the original (unpacked) type. */
9597 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
9598 gnu_result
= convert (gnu_in_base_type
, gnu_result
);
9600 /* If overflow checks are requested, we need to be sure the result will fit
9601 in the output base type. But don't do this if the input is integer and
9602 the output floating-point. */
9604 && !(FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_base_type
)))
9606 /* Ensure GNU_EXPR only gets evaluated once. */
9607 tree gnu_input
= gnat_protect_expr (gnu_result
);
9608 tree gnu_cond
= boolean_false_node
;
9609 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_base_type
);
9610 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_base_type
);
9611 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
9613 = (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
9614 && TYPE_MODULAR_P (gnu_base_type
))
9615 ? fold_build2 (MINUS_EXPR
, gnu_base_type
,
9616 TYPE_MODULUS (gnu_base_type
),
9617 build_int_cst (gnu_base_type
, 1))
9618 : TYPE_MAX_VALUE (gnu_base_type
);
9620 /* Convert the lower bounds to signed types, so we're sure we're
9621 comparing them properly. Likewise, convert the upper bounds
9622 to unsigned types. */
9623 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9624 && TYPE_UNSIGNED (gnu_in_base_type
))
9626 = convert (gnat_signed_type_for (gnu_in_base_type
), gnu_in_lb
);
9628 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9629 && !TYPE_UNSIGNED (gnu_in_base_type
))
9631 = convert (gnat_unsigned_type_for (gnu_in_base_type
), gnu_in_ub
);
9633 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
9635 = convert (gnat_signed_type_for (gnu_base_type
), gnu_out_lb
);
9637 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
9639 = convert (gnat_unsigned_type_for (gnu_base_type
), gnu_out_ub
);
9641 /* Check each bound separately and only if the result bound
9642 is tighter than the bound on the input type. Note that all the
9643 types are base types, so the bounds must be constant. Also,
9644 the comparison is done in the base type of the input, which
9645 always has the proper signedness. First check for input
9646 integer (which means output integer), output float (which means
9647 both float), or mixed, in which case we always compare.
9648 Note that we have to do the comparison which would *fail* in the
9649 case of an error since if it's an FP comparison and one of the
9650 values is a NaN or Inf, the comparison will fail. */
9651 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9652 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
9653 : (FLOAT_TYPE_P (gnu_base_type
)
9654 ? real_less (&TREE_REAL_CST (gnu_in_lb
),
9655 &TREE_REAL_CST (gnu_out_lb
))
9659 (build_binary_op (GE_EXPR
, boolean_type_node
,
9660 gnu_input
, convert (gnu_in_base_type
,
9663 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9664 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
9665 : (FLOAT_TYPE_P (gnu_base_type
)
9666 ? real_less (&TREE_REAL_CST (gnu_out_ub
),
9667 &TREE_REAL_CST (gnu_in_ub
))
9670 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, gnu_cond
,
9672 (build_binary_op (LE_EXPR
, boolean_type_node
,
9674 convert (gnu_in_base_type
,
9677 if (!integer_zerop (gnu_cond
))
9678 gnu_result
= emit_check (gnu_cond
, gnu_input
,
9679 CE_Overflow_Check_Failed
, gnat_node
);
9682 /* Now convert to the result base type. If this is a non-truncating
9683 float-to-integer conversion, round. */
9684 if (INTEGRAL_TYPE_P (gnu_base_type
)
9685 && FLOAT_TYPE_P (gnu_in_base_type
)
9688 REAL_VALUE_TYPE half_minus_pred_half
, pred_half
;
9689 tree gnu_conv
, gnu_zero
, gnu_comp
, calc_type
;
9690 tree gnu_pred_half
, gnu_add_pred_half
, gnu_subtract_pred_half
;
9691 const struct real_format
*fmt
;
9693 /* The following calculations depend on proper rounding to even
9694 of each arithmetic operation. In order to prevent excess
9695 precision from spoiling this property, use the widest hardware
9696 floating-point type if FP_ARITH_MAY_WIDEN is true. */
9698 = fp_arith_may_widen
? longest_float_type_node
: gnu_in_base_type
;
9700 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
9701 fmt
= REAL_MODE_FORMAT (TYPE_MODE (calc_type
));
9702 real_2expN (&half_minus_pred_half
, -(fmt
->p
) - 1, TYPE_MODE (calc_type
));
9703 real_arithmetic (&pred_half
, MINUS_EXPR
, &dconsthalf
,
9704 &half_minus_pred_half
);
9705 gnu_pred_half
= build_real (calc_type
, pred_half
);
9707 /* If the input is strictly negative, subtract this value
9708 and otherwise add it from the input. For 0.5, the result
9709 is exactly between 1.0 and the machine number preceding 1.0
9710 (for calc_type). Since the last bit of 1.0 is even, this 0.5
9711 will round to 1.0, while all other number with an absolute
9712 value less than 0.5 round to 0.0. For larger numbers exactly
9713 halfway between integers, rounding will always be correct as
9714 the true mathematical result will be closer to the higher
9715 integer compared to the lower one. So, this constant works
9716 for all floating-point numbers.
9718 The reason to use the same constant with subtract/add instead
9719 of a positive and negative constant is to allow the comparison
9720 to be scheduled in parallel with retrieval of the constant and
9721 conversion of the input to the calc_type (if necessary). */
9723 gnu_zero
= build_real (gnu_in_base_type
, dconst0
);
9724 gnu_result
= gnat_protect_expr (gnu_result
);
9725 gnu_conv
= convert (calc_type
, gnu_result
);
9727 = fold_build2 (GE_EXPR
, boolean_type_node
, gnu_result
, gnu_zero
);
9729 = fold_build2 (PLUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
9730 gnu_subtract_pred_half
9731 = fold_build2 (MINUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
9732 gnu_result
= fold_build3 (COND_EXPR
, calc_type
, gnu_comp
,
9733 gnu_add_pred_half
, gnu_subtract_pred_half
);
9736 if (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
9737 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type
)
9738 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
9739 gnu_result
= unchecked_convert (gnu_base_type
, gnu_result
, false);
9741 gnu_result
= convert (gnu_base_type
, gnu_result
);
9743 return convert (gnu_type
, gnu_result
);
9746 /* Return true if GNU_EXPR can be directly addressed. This is the case
9747 unless it is an expression involving computation or if it involves a
9748 reference to a bitfield or to an object not sufficiently aligned for
9749 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
9750 be directly addressed as an object of this type.
9752 *** Notes on addressability issues in the Ada compiler ***
9754 This predicate is necessary in order to bridge the gap between Gigi
9755 and the middle-end about addressability of GENERIC trees. A tree
9756 is said to be addressable if it can be directly addressed, i.e. if
9757 its address can be taken, is a multiple of the type's alignment on
9758 strict-alignment architectures and returns the first storage unit
9759 assigned to the object represented by the tree.
9761 In the C family of languages, everything is in practice addressable
9762 at the language level, except for bit-fields. This means that these
9763 compilers will take the address of any tree that doesn't represent
9764 a bit-field reference and expect the result to be the first storage
9765 unit assigned to the object. Even in cases where this will result
9766 in unaligned accesses at run time, nothing is supposed to be done
9767 and the program is considered as erroneous instead (see PR c/18287).
9769 The implicit assumptions made in the middle-end are in keeping with
9770 the C viewpoint described above:
9771 - the address of a bit-field reference is supposed to be never
9772 taken; the compiler (generally) will stop on such a construct,
9773 - any other tree is addressable if it is formally addressable,
9774 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
9776 In Ada, the viewpoint is the opposite one: nothing is addressable
9777 at the language level unless explicitly declared so. This means
9778 that the compiler will both make sure that the trees representing
9779 references to addressable ("aliased" in Ada parlance) objects are
9780 addressable and make no real attempts at ensuring that the trees
9781 representing references to non-addressable objects are addressable.
9783 In the first case, Ada is effectively equivalent to C and handing
9784 down the direct result of applying ADDR_EXPR to these trees to the
9785 middle-end works flawlessly. In the second case, Ada cannot afford
9786 to consider the program as erroneous if the address of trees that
9787 are not addressable is requested for technical reasons, unlike C;
9788 as a consequence, the Ada compiler must arrange for either making
9789 sure that this address is not requested in the middle-end or for
9790 compensating by inserting temporaries if it is requested in Gigi.
9792 The first goal can be achieved because the middle-end should not
9793 request the address of non-addressable trees on its own; the only
9794 exception is for the invocation of low-level block operations like
9795 memcpy, for which the addressability requirements are lower since
9796 the type's alignment can be disregarded. In practice, this means
9797 that Gigi must make sure that such operations cannot be applied to
9798 non-BLKmode bit-fields.
9800 The second goal is achieved by means of the addressable_p predicate,
9801 which computes whether a temporary must be inserted by Gigi when the
9802 address of a tree is requested; if so, the address of the temporary
9803 will be used in lieu of that of the original tree and some glue code
9804 generated to connect everything together. */
9807 addressable_p (tree gnu_expr
, tree gnu_type
)
9809 /* For an integral type, the size of the actual type of the object may not
9810 be greater than that of the expected type, otherwise an indirect access
9811 in the latter type wouldn't correctly set all the bits of the object. */
9813 && INTEGRAL_TYPE_P (gnu_type
)
9814 && smaller_form_type_p (gnu_type
, TREE_TYPE (gnu_expr
)))
9817 /* The size of the actual type of the object may not be smaller than that
9818 of the expected type, otherwise an indirect access in the latter type
9819 would be larger than the object. But only record types need to be
9820 considered in practice for this case. */
9822 && TREE_CODE (gnu_type
) == RECORD_TYPE
9823 && smaller_form_type_p (TREE_TYPE (gnu_expr
), gnu_type
))
9826 switch (TREE_CODE (gnu_expr
))
9832 /* All DECLs are addressable: if they are in a register, we can force
9836 case UNCONSTRAINED_ARRAY_REF
:
9838 /* Taking the address of a dereference yields the original pointer. */
9844 /* Taking the address yields a pointer to the constant pool. */
9848 /* Taking the address of a static constructor yields a pointer to the
9849 tree constant pool. */
9850 return TREE_STATIC (gnu_expr
) ? true : false;
9862 /* All rvalues are deemed addressable since taking their address will
9863 force a temporary to be created by the middle-end. */
9867 /* The address of a compound expression is that of its 2nd operand. */
9868 return addressable_p (TREE_OPERAND (gnu_expr
, 1), gnu_type
);
9871 /* We accept &COND_EXPR as soon as both operands are addressable and
9872 expect the outcome to be the address of the selected operand. */
9873 return (addressable_p (TREE_OPERAND (gnu_expr
, 1), NULL_TREE
)
9874 && addressable_p (TREE_OPERAND (gnu_expr
, 2), NULL_TREE
));
9877 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
9878 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
9879 the field is sufficiently aligned, in case it is subject
9880 to a pragma Component_Alignment. But we don't need to
9881 check the alignment of the containing record, as it is
9882 guaranteed to be not smaller than that of its most
9883 aligned field that is not a bit-field. */
9884 && (!STRICT_ALIGNMENT
9885 || DECL_ALIGN (TREE_OPERAND (gnu_expr
, 1))
9886 >= TYPE_ALIGN (TREE_TYPE (gnu_expr
))))
9887 /* The field of a padding record is always addressable. */
9888 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
9889 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
9891 case ARRAY_REF
: case ARRAY_RANGE_REF
:
9892 case REALPART_EXPR
: case IMAGPART_EXPR
:
9894 return addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
);
9897 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
9898 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
9900 case VIEW_CONVERT_EXPR
:
9902 /* This is addressable if we can avoid a copy. */
9903 tree type
= TREE_TYPE (gnu_expr
);
9904 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
9905 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
9906 && (!STRICT_ALIGNMENT
9907 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
9908 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
9909 || ((TYPE_MODE (type
) == BLKmode
9910 || TYPE_MODE (inner_type
) == BLKmode
)
9911 && (!STRICT_ALIGNMENT
9912 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
9913 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
9914 || TYPE_ALIGN_OK (type
)
9915 || TYPE_ALIGN_OK (inner_type
))))
9916 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
9924 /* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
9925 If a Freeze node exists for the entity, delay the bulk of the processing.
9926 Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
9929 process_type (Entity_Id gnat_entity
)
9932 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
9934 /* If we are to delay elaboration of this type, just do any elaboration
9935 needed for expressions within the declaration and make a dummy node
9936 for it and its Full_View (if any), in case something points to it.
9937 Do not do this if it has already been done (the only way that can
9938 happen is if the private completion is also delayed). */
9939 if (Present (Freeze_Node (gnat_entity
)))
9941 elaborate_entity (gnat_entity
);
9945 tree gnu_decl
= TYPE_STUB_DECL (make_dummy_type (gnat_entity
));
9946 save_gnu_tree (gnat_entity
, gnu_decl
, false);
9947 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9948 && Present (Full_View (gnat_entity
)))
9950 if (Has_Completion_In_Body (gnat_entity
))
9951 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
9952 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, false);
9959 /* If we saved away a dummy type for this node, it means that this made the
9960 type that corresponds to the full type of an incomplete type. Clear that
9961 type for now and then update the type in the pointers below. But, if the
9962 saved type is not dummy, it very likely means that we have a use before
9963 declaration for the type in the tree, what we really cannot handle. */
9966 gcc_assert (TREE_CODE (gnu_old
) == TYPE_DECL
9967 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)));
9969 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
9972 /* Now fully elaborate the type. */
9973 tree gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, true);
9974 gcc_assert (TREE_CODE (gnu_new
) == TYPE_DECL
);
9976 /* If we have an old type and we've made pointers to this type, update those
9977 pointers. If this is a Taft amendment type in the main unit, we need to
9978 mark the type as used since other units referencing it don't see the full
9979 declaration and, therefore, cannot mark it as used themselves. */
9982 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
9983 TREE_TYPE (gnu_new
));
9984 if (DECL_TAFT_TYPE_P (gnu_old
))
9985 used_types_insert (TREE_TYPE (gnu_new
));
9988 /* If this is a record type corresponding to a task or protected type
9989 that is a completion of an incomplete type, perform a similar update
9990 on the type. ??? Including protected types here is a guess. */
9991 if (Is_Record_Type (gnat_entity
)
9992 && Is_Concurrent_Record_Type (gnat_entity
)
9993 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
9996 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
9998 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
10000 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
10003 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
10004 TREE_TYPE (gnu_new
));
10008 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
10009 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
10010 associations that are from RECORD_TYPE. If we see an internal record, make
10011 a recursive call to fill it in as well. */
10014 extract_values (tree values
, tree record_type
)
10016 vec
<constructor_elt
, va_gc
> *v
= NULL
;
10019 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
10021 tree tem
, value
= NULL_TREE
;
10023 /* _Parent is an internal field, but may have values in the aggregate,
10024 so check for values first. */
10025 if ((tem
= purpose_member (field
, values
)))
10027 value
= TREE_VALUE (tem
);
10028 TREE_ADDRESSABLE (tem
) = 1;
10031 else if (DECL_INTERNAL_P (field
))
10033 value
= extract_values (values
, TREE_TYPE (field
));
10034 if (TREE_CODE (value
) == CONSTRUCTOR
10035 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value
)))
10039 /* If we have a record subtype, the names will match, but not the
10040 actual FIELD_DECLs. */
10041 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
10042 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
10044 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
10045 TREE_ADDRESSABLE (tem
) = 1;
10051 CONSTRUCTOR_APPEND_ELT (v
, field
, value
);
10054 return gnat_build_constructor (record_type
, v
);
10057 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
10058 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
10059 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
10062 assoc_to_constructor (Entity_Id gnat_entity
, Node_Id gnat_assoc
, tree gnu_type
)
10064 tree gnu_list
= NULL_TREE
, gnu_result
;
10066 /* We test for GNU_FIELD being empty in the case where a variant
10067 was the last thing since we don't take things off GNAT_ASSOC in
10068 that case. We check GNAT_ASSOC in case we have a variant, but it
10071 for (; Present (gnat_assoc
); gnat_assoc
= Next (gnat_assoc
))
10073 const Node_Id gnat_field
= First (Choices (gnat_assoc
));
10074 const Node_Id gnat_expr
= Expression (gnat_assoc
);
10075 tree gnu_field
= gnat_to_gnu_field_decl (Entity (gnat_field
));
10076 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
10078 /* The expander is supposed to put a single component selector name
10079 in every record component association. */
10080 gcc_assert (No (Next (gnat_field
)));
10082 /* Ignore discriminants that have Corresponding_Discriminants in tagged
10083 types since we'll be setting those fields in the parent subtype. */
10084 if (Ekind (Entity (gnat_field
)) == E_Discriminant
10085 && Present (Corresponding_Discriminant (Entity (gnat_field
)))
10086 && Is_Tagged_Type (Scope (Entity (gnat_field
))))
10089 /* Also ignore discriminants of Unchecked_Unions. */
10090 if (Ekind (Entity (gnat_field
)) == E_Discriminant
10091 && Is_Unchecked_Union (gnat_entity
))
10094 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
10096 /* Convert to the type of the field. */
10097 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
10099 /* Add the field and expression to the list. */
10100 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
10103 gnu_result
= extract_values (gnu_list
, gnu_type
);
10107 /* Verify that every entry in GNU_LIST was used. */
10108 for (; gnu_list
; gnu_list
= TREE_CHAIN (gnu_list
))
10109 gcc_assert (TREE_ADDRESSABLE (gnu_list
));
10115 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
10116 the first element of an array aggregate. It may itself be an aggregate.
10117 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate. */
10120 pos_to_constructor (Node_Id gnat_expr
, tree gnu_array_type
)
10122 tree gnu_index
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type
));
10123 vec
<constructor_elt
, va_gc
> *gnu_expr_vec
= NULL
;
10125 for (; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
10129 /* If the expression is itself an array aggregate then first build the
10130 innermost constructor if it is part of our array (multi-dimensional
10132 if (Nkind (gnat_expr
) == N_Aggregate
10133 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
10134 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
10135 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
10136 TREE_TYPE (gnu_array_type
));
10139 /* If the expression is a conversion to an unconstrained array type,
10140 skip it to avoid spilling to memory. */
10141 if (Nkind (gnat_expr
) == N_Type_Conversion
10142 && Is_Array_Type (Etype (gnat_expr
))
10143 && !Is_Constrained (Etype (gnat_expr
)))
10144 gnu_expr
= gnat_to_gnu (Expression (gnat_expr
));
10146 gnu_expr
= gnat_to_gnu (gnat_expr
);
10148 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
10151 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec
, gnu_index
,
10152 convert (TREE_TYPE (gnu_array_type
), gnu_expr
));
10154 gnu_index
= int_const_binop (PLUS_EXPR
, gnu_index
,
10155 convert (TREE_TYPE (gnu_index
),
10156 integer_one_node
));
10159 return gnat_build_constructor (gnu_array_type
, gnu_expr_vec
);
10162 /* Process a N_Validate_Unchecked_Conversion node. */
10165 validate_unchecked_conversion (Node_Id gnat_node
)
10167 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
10168 tree gnu_target_type
= gnat_to_gnu_type (Target_Type (gnat_node
));
10170 /* If the target is a pointer type, see if we are either converting from a
10171 non-pointer or from a pointer to a type with a different alias set and
10172 warn if so, unless the pointer has been marked to alias everything. */
10173 if (POINTER_TYPE_P (gnu_target_type
)
10174 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type
))
10176 tree gnu_source_desig_type
= POINTER_TYPE_P (gnu_source_type
)
10177 ? TREE_TYPE (gnu_source_type
)
10179 tree gnu_target_desig_type
= TREE_TYPE (gnu_target_type
);
10180 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
10182 if (target_alias_set
!= 0
10183 && (!POINTER_TYPE_P (gnu_source_type
)
10184 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
10185 target_alias_set
)))
10187 post_error_ne ("?possible aliasing problem for type&",
10188 gnat_node
, Target_Type (gnat_node
));
10189 post_error ("\\?use -fno-strict-aliasing switch for references",
10191 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
10192 gnat_node
, Target_Type (gnat_node
));
10196 /* Likewise if the target is a fat pointer type, but we have no mechanism to
10197 mitigate the problem in this case, so we unconditionally warn. */
10198 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type
))
10200 tree gnu_source_desig_type
10201 = TYPE_IS_FAT_POINTER_P (gnu_source_type
)
10202 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type
)))
10204 tree gnu_target_desig_type
10205 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type
)));
10206 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
10208 if (target_alias_set
!= 0
10209 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type
)
10210 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
10211 target_alias_set
)))
10213 post_error_ne ("?possible aliasing problem for type&",
10214 gnat_node
, Target_Type (gnat_node
));
10215 post_error ("\\?use -fno-strict-aliasing switch for references",
10221 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a
10222 source code location and false if it doesn't. If CLEAR_COLUMN is
10223 true, set the column information to 0. If DECL is given and SLOC
10224 refers to a File with an instance, map DECL to that instance. */
10227 Sloc_to_locus (Source_Ptr Sloc
, location_t
*locus
, bool clear_column
,
10230 if (Sloc
== No_Location
)
10233 if (Sloc
<= Standard_Location
)
10235 *locus
= BUILTINS_LOCATION
;
10239 Source_File_Index file
= Get_Source_File_Index (Sloc
);
10240 Line_Number_Type line
= Get_Logical_Line_Number (Sloc
);
10241 Column_Number_Type column
= (clear_column
? 0 : Get_Column_Number (Sloc
));
10242 line_map_ordinary
*map
= LINEMAPS_ORDINARY_MAP_AT (line_table
, file
- 1);
10244 /* We can have zero if pragma Source_Reference is in effect. */
10248 /* Translate the location. */
10250 = linemap_position_for_line_and_column (line_table
, map
, line
, column
);
10252 if (file_map
&& file_map
[file
- 1].Instance
)
10253 decl_to_instance_map
->put (decl
, file_map
[file
- 1].Instance
);
10258 /* Return whether GNAT_NODE is a defining identifier for a renaming that comes
10259 from the parameter association for the instantiation of a generic. We do
10260 not want to emit source location for them: the code generated for their
10261 initialization is likely to disturb debugging. */
10264 renaming_from_instantiation_p (Node_Id gnat_node
)
10266 if (Nkind (gnat_node
) != N_Defining_Identifier
10267 || !Is_Object (gnat_node
)
10268 || Comes_From_Source (gnat_node
)
10269 || !Present (Renamed_Object (gnat_node
)))
10272 /* Get the object declaration of the renamed object, if any and if the
10273 renamed object is a mere identifier. */
10274 gnat_node
= Renamed_Object (gnat_node
);
10275 if (Nkind (gnat_node
) != N_Identifier
)
10278 gnat_node
= Parent (Entity (gnat_node
));
10279 return (Present (gnat_node
)
10280 && Nkind (gnat_node
) == N_Object_Declaration
10281 && Present (Corresponding_Generic_Association (gnat_node
)));
10284 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
10285 don't do anything if it doesn't correspond to a source location. And,
10286 if CLEAR_COLUMN is true, set the column information to 0. */
10289 set_expr_location_from_node (tree node
, Node_Id gnat_node
, bool clear_column
)
10293 /* Do not set a location for constructs likely to disturb debugging. */
10294 if (Nkind (gnat_node
) == N_Defining_Identifier
)
10296 if (Is_Type (gnat_node
) && Is_Actual_Subtype (gnat_node
))
10299 if (renaming_from_instantiation_p (gnat_node
))
10303 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
, clear_column
))
10306 SET_EXPR_LOCATION (node
, locus
);
10309 /* More elaborate version of set_expr_location_from_node to be used in more
10310 general contexts, for example the result of the translation of a generic
10314 set_gnu_expr_location_from_node (tree node
, Node_Id gnat_node
)
10316 /* Set the location information on the node if it is a real expression.
10317 References can be reused for multiple GNAT nodes and they would get
10318 the location information of their last use. Also make sure not to
10319 overwrite an existing location as it is probably more precise. */
10321 switch (TREE_CODE (node
))
10324 case NON_LVALUE_EXPR
:
10328 case COMPOUND_EXPR
:
10329 if (EXPR_P (TREE_OPERAND (node
, 1)))
10330 set_gnu_expr_location_from_node (TREE_OPERAND (node
, 1), gnat_node
);
10332 /* ... fall through ... */
10335 if (!REFERENCE_CLASS_P (node
) && !EXPR_HAS_LOCATION (node
))
10337 set_expr_location_from_node (node
, gnat_node
);
10338 set_end_locus_from_node (node
, gnat_node
);
10344 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
10345 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
10346 most sense. Return true if a sensible assignment was performed. */
10349 set_end_locus_from_node (tree gnu_node
, Node_Id gnat_node
)
10351 Node_Id gnat_end_label
;
10352 location_t end_locus
;
10354 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
10355 end_locus when there is one. We consider only GNAT nodes with a possible
10356 End_Label attached. If the End_Label actually was unassigned, fallback
10357 on the original node. We'd better assign an explicit sloc associated with
10358 the outer construct in any case. */
10360 switch (Nkind (gnat_node
))
10362 case N_Package_Body
:
10363 case N_Subprogram_Body
:
10364 case N_Block_Statement
:
10365 gnat_end_label
= End_Label (Handled_Statement_Sequence (gnat_node
));
10368 case N_Package_Declaration
:
10369 gnat_end_label
= End_Label (Specification (gnat_node
));
10376 if (Present (gnat_end_label
))
10377 gnat_node
= gnat_end_label
;
10379 /* Some expanded subprograms have neither an End_Label nor a Sloc
10380 attached. Notify that to callers. For a block statement with no
10381 End_Label, clear column information, so that the tree for a
10382 transient block does not receive the sloc of a source condition. */
10383 if (!Sloc_to_locus (Sloc (gnat_node
), &end_locus
,
10384 No (gnat_end_label
)
10385 && (Nkind (gnat_node
) == N_Block_Statement
)))
10388 switch (TREE_CODE (gnu_node
))
10391 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node
)) = end_locus
;
10394 case FUNCTION_DECL
:
10395 DECL_STRUCT_FUNCTION (gnu_node
)->function_end_locus
= end_locus
;
10403 /* Return a colon-separated list of encodings contained in encoded Ada
10406 static const char *
10407 extract_encoding (const char *name
)
10409 char *encoding
= (char *) ggc_alloc_atomic (strlen (name
));
10410 get_encoding (name
, encoding
);
10414 /* Extract the Ada name from an encoded name. */
10416 static const char *
10417 decode_name (const char *name
)
10419 char *decoded
= (char *) ggc_alloc_atomic (strlen (name
) * 2 + 60);
10420 __gnat_decode (name
, decoded
, 0);
10424 /* Post an error message. MSG is the error message, properly annotated.
10425 NODE is the node at which to post the error and the node to use for the
10426 '&' substitution. */
10429 post_error (const char *msg
, Node_Id node
)
10431 String_Template temp
;
10437 temp
.Low_Bound
= 1;
10438 temp
.High_Bound
= strlen (msg
);
10441 Error_Msg_N (sp
, node
);
10444 /* Similar to post_error, but NODE is the node at which to post the error and
10445 ENT is the node to use for the '&' substitution. */
10448 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
10450 String_Template temp
;
10456 temp
.Low_Bound
= 1;
10457 temp
.High_Bound
= strlen (msg
);
10460 Error_Msg_NE (sp
, node
, ent
);
10463 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
10466 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int num
)
10468 Error_Msg_Uint_1
= UI_From_Int (num
);
10469 post_error_ne (msg
, node
, ent
);
10472 /* Similar to post_error_ne, but T is a GCC tree representing the number to
10473 write. If T represents a constant, the text inside curly brackets in
10474 MSG will be output (presumably including a '^'). Otherwise it will not
10475 be output and the text inside square brackets will be output instead. */
10478 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
10480 char *new_msg
= XALLOCAVEC (char, strlen (msg
) + 1);
10481 char start_yes
, end_yes
, start_no
, end_no
;
10485 if (TREE_CODE (t
) == INTEGER_CST
)
10487 Error_Msg_Uint_1
= UI_From_gnu (t
);
10488 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
10491 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
10493 for (p
= msg
, q
= new_msg
; *p
; p
++)
10495 if (*p
== start_yes
)
10496 for (p
++; *p
!= end_yes
; p
++)
10498 else if (*p
== start_no
)
10499 for (p
++; *p
!= end_no
; p
++)
10507 post_error_ne (new_msg
, node
, ent
);
10510 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
10513 post_error_ne_tree_2 (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
,
10516 Error_Msg_Uint_2
= UI_From_Int (num
);
10517 post_error_ne_tree (msg
, node
, ent
, t
);
10520 /* Return a label to branch to for the exception type in KIND or Empty
10524 get_exception_label (char kind
)
10528 case N_Raise_Constraint_Error
:
10529 return gnu_constraint_error_label_stack
.last ();
10531 case N_Raise_Storage_Error
:
10532 return gnu_storage_error_label_stack
.last ();
10534 case N_Raise_Program_Error
:
10535 return gnu_program_error_label_stack
.last ();
10541 gcc_unreachable ();
10544 /* Return the decl for the current elaboration procedure. */
10547 get_elaboration_procedure (void)
10549 return gnu_elab_proc_stack
->last ();
10552 /* Return the controlling type of a dispatching subprogram. */
10555 get_controlling_type (Entity_Id subprog
)
10557 /* This is modeled on Expand_Interface_Thunk. */
10558 Entity_Id controlling_type
= Etype (First_Formal (subprog
));
10559 if (Is_Access_Type (controlling_type
))
10560 controlling_type
= Directly_Designated_Type (controlling_type
);
10561 controlling_type
= Underlying_Type (controlling_type
);
10562 if (Is_Concurrent_Type (controlling_type
))
10563 controlling_type
= Corresponding_Record_Type (controlling_type
);
10564 controlling_type
= Base_Type (controlling_type
);
10565 return controlling_type
;
10568 /* Return whether we should use an alias for the TARGET of a thunk
10569 in order to make the call generated in the thunk local. */
10572 use_alias_for_thunk_p (tree target
)
10574 /* We cannot generate a local call in this case. */
10575 if (DECL_EXTERNAL (target
))
10578 /* The call is already local in this case. */
10579 if (TREE_CODE (DECL_CONTEXT (target
)) == FUNCTION_DECL
)
10582 return TARGET_USE_LOCAL_THUNK_ALIAS_P (target
);
10585 static GTY(()) unsigned long thunk_labelno
= 0;
10587 /* Create an alias for TARGET to be used as the target of a thunk. */
10590 make_alias_for_thunk (tree target
)
10593 targetm
.asm_out
.generate_internal_label (buf
, "LTHUNK", thunk_labelno
++);
10595 tree alias
= build_decl (DECL_SOURCE_LOCATION (target
), TREE_CODE (target
),
10596 get_identifier (buf
), TREE_TYPE (target
));
10598 DECL_LANG_SPECIFIC (alias
) = DECL_LANG_SPECIFIC (target
);
10599 DECL_CONTEXT (alias
) = DECL_CONTEXT (target
);
10600 TREE_READONLY (alias
) = TREE_READONLY (target
);
10601 TREE_THIS_VOLATILE (alias
) = TREE_THIS_VOLATILE (target
);
10602 DECL_ARTIFICIAL (alias
) = 1;
10603 DECL_INITIAL (alias
) = error_mark_node
;
10604 DECL_ARGUMENTS (alias
) = copy_list (DECL_ARGUMENTS (target
));
10605 TREE_ADDRESSABLE (alias
) = 1;
10606 SET_DECL_ASSEMBLER_NAME (alias
, DECL_NAME (alias
));
10608 cgraph_node
*n
= cgraph_node::create_same_body_alias (alias
, target
);
10614 /* Create the covariant part of the {GNAT,GNU}_THUNK. */
10617 make_covariant_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
)
10619 tree gnu_name
= create_concat_name (gnat_thunk
, "CV");
10621 = build_decl (DECL_SOURCE_LOCATION (gnu_thunk
), TREE_CODE (gnu_thunk
),
10622 gnu_name
, TREE_TYPE (gnu_thunk
));
10624 DECL_ARGUMENTS (gnu_cv_thunk
) = copy_list (DECL_ARGUMENTS (gnu_thunk
));
10625 DECL_RESULT (gnu_cv_thunk
) = copy_node (DECL_RESULT (gnu_thunk
));
10626 DECL_CONTEXT (DECL_RESULT (gnu_cv_thunk
)) = gnu_cv_thunk
;
10628 DECL_LANG_SPECIFIC (gnu_cv_thunk
) = DECL_LANG_SPECIFIC (gnu_thunk
);
10629 DECL_CONTEXT (gnu_cv_thunk
) = DECL_CONTEXT (gnu_thunk
);
10630 TREE_READONLY (gnu_cv_thunk
) = TREE_READONLY (gnu_thunk
);
10631 TREE_THIS_VOLATILE (gnu_cv_thunk
) = TREE_THIS_VOLATILE (gnu_thunk
);
10632 TREE_PUBLIC (gnu_cv_thunk
) = TREE_PUBLIC (gnu_thunk
);
10633 DECL_ARTIFICIAL (gnu_cv_thunk
) = 1;
10635 return gnu_cv_thunk
;
10638 /* Try to create a GNU thunk for {GNAT,GNU}_THUNK and return true on success.
10640 GNU thunks are more efficient than GNAT thunks because they don't call into
10641 the runtime to retrieve the offset used in the displacement operation, but
10642 they are tailored to C++ and thus too limited to support the full range of
10643 thunks generated in Ada. Here's the complete list of limitations:
10645 1. Multi-controlling thunks, i.e thunks with more than one controlling
10646 parameter, are simply not supported.
10648 2. Covariant thunks, i.e. thunks for which the result is also controlling,
10649 are split into a pair of (this, covariant-only) thunks.
10651 3. Variable-offset thunks, i.e. thunks for which the offset depends on the
10652 object and not only on its type, are supported as 2nd class citizens.
10654 4. External thunks, i.e. thunks for which the target is not declared in
10655 the same unit as the thunk, are supported as 2nd class citizens.
10657 5. Local thunks, i.e. thunks generated for a local type, are supported as
10658 2nd class citizens. */
10661 maybe_make_gnu_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
)
10663 const Entity_Id gnat_target
= Thunk_Entity (gnat_thunk
);
10665 /* Check that the first formal of the target is the only controlling one. */
10666 Entity_Id gnat_formal
= First_Formal (gnat_target
);
10667 if (!Is_Controlling_Formal (gnat_formal
))
10669 for (gnat_formal
= Next_Formal (gnat_formal
);
10670 Present (gnat_formal
);
10671 gnat_formal
= Next_Formal (gnat_formal
))
10672 if (Is_Controlling_Formal (gnat_formal
))
10675 /* Look for the types that control the target and the thunk. */
10676 const Entity_Id gnat_controlling_type
= get_controlling_type (gnat_target
);
10677 const Entity_Id gnat_interface_type
= get_controlling_type (gnat_thunk
);
10679 /* We must have an interface type at this point. */
10680 gcc_assert (Is_Interface (gnat_interface_type
));
10682 /* Now compute whether the former covers the latter. */
10683 const Entity_Id gnat_interface_tag
10684 = Find_Interface_Tag (gnat_controlling_type
, gnat_interface_type
);
10685 tree gnu_interface_tag
10686 = Present (gnat_interface_tag
)
10687 ? gnat_to_gnu_field_decl (gnat_interface_tag
)
10689 tree gnu_interface_offset
10690 = gnu_interface_tag
? byte_position (gnu_interface_tag
) : NULL_TREE
;
10692 /* There are three ways to retrieve the offset between the interface view
10693 and the base object. Either the controlling type covers the interface
10694 type and the offset of the corresponding tag is fixed, in which case it
10695 can be statically encoded in the thunk (see FIXED_OFFSET below). Or the
10696 controlling type doesn't cover the interface type but is of fixed size,
10697 in which case the offset is stored in the dispatch table, two pointers
10698 above the dispatch table address (see VIRTUAL_VALUE below). Otherwise,
10699 the offset is variable and is stored right after the tag in every object
10700 (see INDIRECT_OFFSET below). See also a-tags.ads for more details. */
10701 HOST_WIDE_INT fixed_offset
, virtual_value
, indirect_offset
;
10702 tree virtual_offset
;
10704 if (gnu_interface_offset
&& TREE_CODE (gnu_interface_offset
) == INTEGER_CST
)
10706 fixed_offset
= - tree_to_shwi (gnu_interface_offset
);
10708 virtual_offset
= NULL_TREE
;
10709 indirect_offset
= 0;
10711 else if (!gnu_interface_offset
10712 && !Is_Variable_Size_Record (gnat_controlling_type
))
10715 virtual_value
= - 2 * (HOST_WIDE_INT
) (POINTER_SIZE
/ BITS_PER_UNIT
);
10716 virtual_offset
= build_int_cst (integer_type_node
, virtual_value
);
10717 indirect_offset
= 0;
10721 /* Covariant thunks with variable offset are not supported. */
10722 if (Has_Controlling_Result (gnat_target
))
10727 virtual_offset
= NULL_TREE
;
10728 indirect_offset
= (HOST_WIDE_INT
) (POINTER_SIZE
/ BITS_PER_UNIT
);
10731 tree gnu_target
= gnat_to_gnu_entity (gnat_target
, NULL_TREE
, false);
10733 /* If the target is local, then thunk and target must have the same context
10734 because cgraph_node::expand_thunk can only forward the static chain. */
10735 if (DECL_STATIC_CHAIN (gnu_target
)
10736 && DECL_CONTEXT (gnu_thunk
) != DECL_CONTEXT (gnu_target
))
10739 /* If the target returns by invisible reference and is external, apply the
10740 same transformation as Subprogram_Body_to_gnu here. */
10741 if (TREE_ADDRESSABLE (TREE_TYPE (gnu_target
))
10742 && DECL_EXTERNAL (gnu_target
)
10743 && !POINTER_TYPE_P (TREE_TYPE (DECL_RESULT (gnu_target
))))
10745 TREE_TYPE (DECL_RESULT (gnu_target
))
10746 = build_reference_type (TREE_TYPE (DECL_RESULT (gnu_target
)));
10747 relayout_decl (DECL_RESULT (gnu_target
));
10750 /* The thunk expander requires the return types of thunk and target to be
10751 compatible, which is not fully the case with the CICO mechanism. */
10752 if (TYPE_CI_CO_LIST (TREE_TYPE (gnu_thunk
)))
10754 tree gnu_target_type
= TREE_TYPE (gnu_target
);
10755 gcc_assert (TYPE_CI_CO_LIST (gnu_target_type
));
10756 TYPE_CANONICAL (TREE_TYPE (TREE_TYPE (gnu_thunk
)))
10757 = TYPE_CANONICAL (TREE_TYPE (gnu_target_type
));
10760 cgraph_node
*target_node
= cgraph_node::get_create (gnu_target
);
10762 /* If the return type of the target is a controlling type, then we need
10763 both an usual this thunk and a covariant thunk in this order:
10765 this thunk --> covariant thunk --> target
10767 For covariant thunks, we can only handle a fixed offset. */
10768 if (Has_Controlling_Result (gnat_target
))
10770 gcc_assert (fixed_offset
< 0);
10771 tree gnu_cv_thunk
= make_covariant_thunk (gnat_thunk
, gnu_thunk
);
10772 target_node
->create_thunk (gnu_cv_thunk
, gnu_target
, false,
10773 - fixed_offset
, 0, 0,
10774 NULL_TREE
, gnu_target
);
10776 gnu_target
= gnu_cv_thunk
;
10779 /* We may also need to create an alias for the target in order to make
10780 the call local, depending on the linkage of the target. */
10781 tree gnu_alias
= use_alias_for_thunk_p (gnu_target
)
10782 ? make_alias_for_thunk (gnu_target
)
10785 target_node
->create_thunk (gnu_thunk
, gnu_target
, true,
10786 fixed_offset
, virtual_value
, indirect_offset
,
10787 virtual_offset
, gnu_alias
);
10792 /* Initialize the table that maps GNAT codes to GCC codes for simple
10793 binary and unary operations. */
10796 init_code_table (void)
10798 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
10799 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
10800 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
10801 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
10802 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
10803 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
10804 gnu_codes
[N_Op_Le
] = LE_EXPR
;
10805 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
10806 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
10807 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
10808 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
10809 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
10810 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
10811 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
10812 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
10813 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
10814 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
10815 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
10816 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
10817 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
10818 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
10819 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
10820 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
10821 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
10824 #include "gt-ada-trans.h"