1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2021, 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 Field_Offset
*Node_Offsets_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
;
115 /* Structure used to record information for a function. */
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
;
197 /* Structure used to record information for a loop. */
198 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
;
208 vec
<tree
, va_gc
> *invariants
;
211 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 /* This makes gigi's file_info_ptr visible in this translation unit,
255 so that Sloc_to_locus can look it up when deciding whether to map
256 decls to instances. */
258 static struct File_Info_Type
*file_map
;
260 /* Return the string of the identifier allocated for the file name Id. */
263 File_Name_to_gnu (Name_Id Id
)
265 /* __gnat_to_canonical_file_spec translates file names from pragmas
266 Source_Reference that contain host style syntax not understood by GDB. */
267 const char *name
= __gnat_to_canonical_file_spec (Get_Name_String (Id
));
269 /* Use the identifier table to make a permanent copy of the file name as
270 the name table gets reallocated after Gigi returns but before all the
271 debugging information is output. */
272 return IDENTIFIER_POINTER (get_identifier (name
));
275 /* This is the main program of the back-end. It sets up all the table
276 structures and then generates code. */
279 gigi (Node_Id gnat_root
,
281 int number_name ATTRIBUTE_UNUSED
,
282 Field_Offset
*node_offsets_ptr
,
284 Node_Id
*next_node_ptr
,
285 Node_Id
*prev_node_ptr
,
286 struct Elist_Header
*elists_ptr
,
287 struct Elmt_Item
*elmts_ptr
,
288 struct String_Entry
*strings_ptr
,
289 Char_Code
*string_chars_ptr
,
290 struct List_Header
*list_headers_ptr
,
292 struct File_Info_Type
*file_info_ptr
,
293 Entity_Id standard_boolean
,
294 Entity_Id standard_integer
,
295 Entity_Id standard_character
,
296 Entity_Id standard_long_long_float
,
297 Entity_Id standard_exception_type
,
298 Int gigi_operating_mode
)
301 Entity_Id gnat_literal
;
302 tree t
, ftype
, int64_type
;
303 struct elab_info
*info
;
306 max_gnat_nodes
= max_gnat_node
;
308 Node_Offsets_Ptr
= node_offsets_ptr
;
309 Slots_Ptr
= slots_ptr
;
310 Next_Node_Ptr
= next_node_ptr
;
311 Prev_Node_Ptr
= prev_node_ptr
;
312 Elists_Ptr
= elists_ptr
;
313 Elmts_Ptr
= elmts_ptr
;
314 Strings_Ptr
= strings_ptr
;
315 String_Chars_Ptr
= string_chars_ptr
;
316 List_Headers_Ptr
= list_headers_ptr
;
318 type_annotate_only
= (gigi_operating_mode
== 1);
320 if (Generate_SCO_Instance_Table
!= 0)
322 file_map
= file_info_ptr
;
323 maybe_create_decl_to_instance_map (number_file
);
326 for (i
= 0; i
< number_file
; i
++)
328 /* We rely on the order isomorphism between files and line maps. */
329 if ((int) LINEMAPS_ORDINARY_USED (line_table
) != i
)
332 error ("%s contains too many lines",
333 File_Name_to_gnu (file_info_ptr
[i
- 1].File_Name
));
336 /* We create the line map for a source file at once, with a fixed number
337 of columns chosen to avoid jumping over the next power of 2. */
338 linemap_add (line_table
, LC_ENTER
, 0,
339 File_Name_to_gnu (file_info_ptr
[i
].File_Name
), 1);
340 linemap_line_start (line_table
, file_info_ptr
[i
].Num_Source_Lines
, 252);
341 linemap_position_for_column (line_table
, 252 - 1);
342 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
345 gcc_assert (Nkind (gnat_root
) == N_Compilation_Unit
);
347 /* Declare the name of the compilation unit as the first global
348 name in order to make the middle-end fully deterministic. */
349 t
= create_concat_name (Defining_Entity (Unit (gnat_root
)), NULL
);
350 first_global_object_name
= ggc_strdup (IDENTIFIER_POINTER (t
));
352 /* Initialize ourselves. */
357 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
359 if (type_annotate_only
)
361 TYPE_SIZE (void_type_node
) = bitsize_zero_node
;
362 TYPE_SIZE_UNIT (void_type_node
) = size_zero_node
;
365 /* Enable GNAT stack checking method if needed */
366 if (!Stack_Check_Probes_On_Target
)
367 set_stack_check_libfunc ("_gnat_stack_check");
369 /* Retrieve alignment settings. */
370 double_float_alignment
= get_target_double_float_alignment ();
371 double_scalar_alignment
= get_target_double_scalar_alignment ();
373 /* Record the builtin types. Define `integer' and `character' first so that
374 dbx will output them first. */
375 record_builtin_type ("integer", integer_type_node
, false);
376 record_builtin_type ("character", char_type_node
, false);
377 record_builtin_type ("boolean", boolean_type_node
, false);
378 record_builtin_type ("void", void_type_node
, false);
380 /* Save the type we made for integer as the type for Standard.Integer. */
381 save_gnu_tree (Base_Type (standard_integer
),
382 TYPE_NAME (integer_type_node
),
385 /* Likewise for character as the type for Standard.Character. */
386 finish_character_type (char_type_node
);
387 save_gnu_tree (Base_Type (standard_character
),
388 TYPE_NAME (char_type_node
),
391 /* Likewise for boolean as the type for Standard.Boolean. */
392 save_gnu_tree (Base_Type (standard_boolean
),
393 TYPE_NAME (boolean_type_node
),
395 gnat_literal
= First_Literal (Base_Type (standard_boolean
));
396 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
397 gcc_assert (t
== boolean_false_node
);
398 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
399 boolean_type_node
, t
, true, false, false, false, false,
400 true, false, NULL
, gnat_literal
);
401 save_gnu_tree (gnat_literal
, t
, false);
402 gnat_literal
= Next_Literal (gnat_literal
);
403 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
404 gcc_assert (t
== boolean_true_node
);
405 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
406 boolean_type_node
, t
, true, false, false, false, false,
407 true, false, NULL
, gnat_literal
);
408 save_gnu_tree (gnat_literal
, t
, false);
410 /* Declare the building blocks of function nodes. */
411 void_list_node
= build_tree_list (NULL_TREE
, void_type_node
);
412 void_ftype
= build_function_type_list (void_type_node
, NULL_TREE
);
413 ptr_void_ftype
= build_pointer_type (void_ftype
);
415 /* Now declare run-time functions. */
417 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE
,
418 build_function_type_list (ptr_type_node
, sizetype
,
420 NULL_TREE
, is_default
, true, true, true, false,
422 DECL_IS_MALLOC (malloc_decl
) = 1;
425 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
426 build_function_type_list (void_type_node
,
427 ptr_type_node
, NULL_TREE
),
428 NULL_TREE
, is_default
, true, true, true, false,
432 = create_subprog_decl (get_identifier ("__gnat_realloc"), NULL_TREE
,
433 build_function_type_list (ptr_type_node
,
434 ptr_type_node
, sizetype
,
436 NULL_TREE
, is_default
, true, true, true, false,
439 /* This is used for 64-bit multiplication with overflow checking. */
440 int64_type
= gnat_type_for_size (64, 0);
442 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE
,
443 build_function_type_list (int64_type
, int64_type
,
444 int64_type
, NULL_TREE
),
445 NULL_TREE
, is_default
, true, true, true, false,
448 if (Enable_128bit_Types
)
450 tree int128_type
= gnat_type_for_size (128, 0);
452 = create_subprog_decl (get_identifier ("__gnat_mulv128"), NULL_TREE
,
453 build_function_type_list (int128_type
,
457 NULL_TREE
, is_default
, true, true, true, false,
461 /* Name of the _Parent field in tagged record types. */
462 parent_name_id
= get_identifier (Get_Name_String (Name_uParent
));
464 /* Name of the Exception_Data type defined in System.Standard_Library. */
465 exception_data_name_id
466 = get_identifier ("system__standard_library__exception_data");
468 /* Make the types and functions used for exception processing. */
469 except_type_node
= gnat_to_gnu_type (Base_Type (standard_exception_type
));
472 = build_array_type (gnat_type_for_mode (Pmode
, 0),
473 build_index_type (size_int (5)));
474 record_builtin_type ("JMPBUF_T", jmpbuf_type
, true);
475 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
477 /* Functions to get and set the jumpbuf pointer for the current thread. */
479 = create_subprog_decl
480 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
481 NULL_TREE
, build_function_type_list (jmpbuf_ptr_type
, NULL_TREE
),
482 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
485 = create_subprog_decl
486 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
487 NULL_TREE
, build_function_type_list (void_type_node
, jmpbuf_ptr_type
,
489 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
492 = create_subprog_decl
493 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE
,
494 build_function_type_list (build_pointer_type (except_type_node
),
496 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
498 not_handled_by_others_decl
= get_identifier ("not_handled_by_others");
499 for (t
= TYPE_FIELDS (except_type_node
); t
; t
= DECL_CHAIN (t
))
500 if (DECL_NAME (t
) == not_handled_by_others_decl
)
502 not_handled_by_others_decl
= t
;
505 gcc_assert (DECL_P (not_handled_by_others_decl
));
507 /* setjmp returns an integer and has one operand, which is a pointer to
510 = create_subprog_decl
511 (get_identifier ("__builtin_setjmp"), NULL_TREE
,
512 build_function_type_list (integer_type_node
, jmpbuf_ptr_type
,
514 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
515 set_decl_built_in_function (setjmp_decl
, BUILT_IN_NORMAL
, BUILT_IN_SETJMP
);
517 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
519 update_setjmp_buf_decl
520 = create_subprog_decl
521 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE
,
522 build_function_type_list (void_type_node
, jmpbuf_ptr_type
, NULL_TREE
),
523 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
524 set_decl_built_in_function (update_setjmp_buf_decl
, BUILT_IN_NORMAL
,
525 BUILT_IN_UPDATE_SETJMP_BUF
);
527 /* Indicate that it never returns. */
528 ftype
= build_function_type_list (void_type_node
,
529 build_pointer_type (except_type_node
),
531 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
533 = create_subprog_decl
534 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
, ftype
,
535 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
537 set_exception_parameter_decl
538 = create_subprog_decl
539 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE
,
540 build_function_type_list (void_type_node
, ptr_type_node
, ptr_type_node
,
542 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
544 /* Hooks to call when entering/leaving an exception handler. */
545 ftype
= build_function_type_list (ptr_type_node
,
546 ptr_type_node
, NULL_TREE
);
548 = create_subprog_decl (get_identifier ("__gnat_begin_handler_v1"),
549 NULL_TREE
, ftype
, NULL_TREE
,
550 is_default
, true, true, true, false, false, NULL
,
552 /* __gnat_begin_handler_v1 is not a dummy procedure, but we arrange
553 for it not to throw. */
554 TREE_NOTHROW (begin_handler_decl
) = 1;
556 ftype
= build_function_type_list (ptr_type_node
,
557 ptr_type_node
, ptr_type_node
,
558 ptr_type_node
, NULL_TREE
);
560 = create_subprog_decl (get_identifier ("__gnat_end_handler_v1"), NULL_TREE
,
562 is_default
, true, true, true, false, false, NULL
,
565 ftype
= build_function_type_list (void_type_node
, ptr_type_node
, NULL_TREE
);
566 unhandled_except_decl
567 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
568 NULL_TREE
, ftype
, NULL_TREE
,
569 is_default
, true, true, true, false, false, NULL
,
572 /* Indicate that it never returns. */
573 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
575 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE
,
577 is_default
, true, true, true, false, false, NULL
,
580 /* Dummy objects to materialize "others" and "all others" in the exception
581 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
584 = create_var_decl (get_identifier ("OTHERS"),
585 get_identifier ("__gnat_others_value"),
586 char_type_node
, NULL_TREE
,
587 true, false, true, false, false, true, false,
591 = create_var_decl (get_identifier ("ALL_OTHERS"),
592 get_identifier ("__gnat_all_others_value"),
593 char_type_node
, NULL_TREE
,
594 true, false, true, false, false, true, false,
597 unhandled_others_decl
598 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
599 get_identifier ("__gnat_unhandled_others_value"),
600 char_type_node
, NULL_TREE
,
601 true, false, true, false, false, true, false,
604 /* If in no exception handlers mode, all raise statements are redirected to
605 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
606 this procedure will never be called in this mode. */
607 if (No_Exception_Handlers_Set ())
609 /* Indicate that it never returns. */
610 ftype
= build_function_type_list (void_type_node
,
611 build_pointer_type (char_type_node
),
612 integer_type_node
, NULL_TREE
);
613 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
615 = create_subprog_decl
616 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
, ftype
,
617 NULL_TREE
, is_default
, true, true, true, false, false, NULL
,
619 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
620 gnat_raise_decls
[i
] = decl
;
624 /* Otherwise, make one decl for each exception reason. */
625 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
626 gnat_raise_decls
[i
] = build_raise_check (i
, exception_simple
);
627 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls_ext
); i
++)
628 gnat_raise_decls_ext
[i
]
629 = build_raise_check (i
,
630 i
== CE_Index_Check_Failed
631 || i
== CE_Range_Check_Failed
632 || i
== CE_Invalid_Data
633 ? exception_range
: exception_column
);
636 /* Build the special descriptor type and its null node if needed. */
637 if (TARGET_VTABLE_USES_DESCRIPTORS
)
639 tree null_node
= fold_convert (ptr_void_ftype
, null_pointer_node
);
640 tree field_list
= NULL_TREE
;
642 vec
<constructor_elt
, va_gc
> *null_vec
= NULL
;
643 constructor_elt
*elt
;
645 fdesc_type_node
= make_node (RECORD_TYPE
);
646 vec_safe_grow (null_vec
, TARGET_VTABLE_USES_DESCRIPTORS
, true);
647 elt
= (null_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
649 for (j
= 0; j
< TARGET_VTABLE_USES_DESCRIPTORS
; j
++)
652 = create_field_decl (NULL_TREE
, ptr_void_ftype
, fdesc_type_node
,
653 NULL_TREE
, NULL_TREE
, 0, 1);
654 DECL_CHAIN (field
) = field_list
;
657 elt
->value
= null_node
;
661 finish_record_type (fdesc_type_node
, nreverse (field_list
), 0, false);
662 record_builtin_type ("descriptor", fdesc_type_node
, true);
663 null_fdesc_node
= gnat_build_constructor (fdesc_type_node
, null_vec
);
666 longest_float_type_node
667 = get_unpadded_type (Base_Type (standard_long_long_float
));
669 main_identifier_node
= get_identifier ("main");
671 /* If we are using the GCC exception mechanism, let GCC know. */
672 if (Back_End_Exceptions ())
675 /* Initialize the GCC support for FP operations. */
678 /* Install the builtins we might need, either internally or as user-available
679 facilities for Intrinsic imports. Note that this must be done after the
680 GCC exception mechanism is initialized. */
681 gnat_install_builtins ();
683 vec_safe_push (gnu_except_ptr_stack
, NULL_TREE
);
685 gnu_constraint_error_label_stack
.safe_push (Empty
);
686 gnu_storage_error_label_stack
.safe_push (Empty
);
687 gnu_program_error_label_stack
.safe_push (Empty
);
689 /* Process any Pragma Ident for the main unit. */
690 if (Present (Ident_String (Main_Unit
)))
691 targetm
.asm_out
.output_ident
692 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
694 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
695 if (No_Strict_Aliasing_CP
)
696 flag_strict_aliasing
= 0;
698 /* Save the current optimization options again after the above possible
699 global_options changes. */
700 optimization_default_node
701 = build_optimization_node (&global_options
, &global_options_set
);
702 optimization_current_node
= optimization_default_node
;
704 /* Now translate the compilation unit proper. */
705 Compilation_Unit_to_gnu (gnat_root
);
707 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
708 the very end to avoid having to second-guess the front-end when we run
709 into dummy nodes during the regular processing. */
710 for (i
= 0; gnat_validate_uc_list
.iterate (i
, &gnat_iter
); i
++)
711 validate_unchecked_conversion (gnat_iter
);
712 gnat_validate_uc_list
.release ();
714 /* Finally see if we have any elaboration procedures to deal with. */
715 for (info
= elab_info_list
; info
; info
= info
->next
)
717 tree gnu_body
= DECL_SAVED_TREE (info
->elab_proc
);
719 /* We should have a BIND_EXPR but it may not have any statements in it.
720 If it doesn't have any, we have nothing to do except for setting the
721 flag on the GNAT node. Otherwise, process the function as others. */
722 tree gnu_stmts
= gnu_body
;
723 if (TREE_CODE (gnu_stmts
) == BIND_EXPR
)
724 gnu_stmts
= BIND_EXPR_BODY (gnu_stmts
);
725 if (!gnu_stmts
|| empty_stmt_list_p (gnu_stmts
))
726 Set_Has_No_Elaboration_Code (info
->gnat_node
, 1);
729 begin_subprog_body (info
->elab_proc
);
730 end_subprog_body (gnu_body
);
731 rest_of_subprog_body_compilation (info
->elab_proc
);
735 /* Destroy ourselves. */
737 destroy_gnat_decl ();
738 destroy_gnat_utils ();
740 /* We cannot track the location of errors past this point. */
741 Current_Error_Node
= Empty
;
744 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
745 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
748 build_raise_check (int check
, enum exception_info_kind kind
)
751 const char pfx
[] = "__gnat_rcheck_";
753 strcpy (Name_Buffer
, pfx
);
754 Name_Len
= sizeof (pfx
) - 1;
755 Get_RT_Exception_Name (check
);
757 if (kind
== exception_simple
)
759 Name_Buffer
[Name_Len
] = 0;
761 = build_function_type_list (void_type_node
,
762 build_pointer_type (char_type_node
),
763 integer_type_node
, NULL_TREE
);
767 tree t
= (kind
== exception_column
? NULL_TREE
: integer_type_node
);
769 strcpy (Name_Buffer
+ Name_Len
, "_ext");
770 Name_Buffer
[Name_Len
+ 4] = 0;
772 = build_function_type_list (void_type_node
,
773 build_pointer_type (char_type_node
),
774 integer_type_node
, integer_type_node
,
778 /* Indicate that it never returns. */
779 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
781 = create_subprog_decl (get_identifier (Name_Buffer
), NULL_TREE
, ftype
,
782 NULL_TREE
, is_default
, true, true, true, false,
788 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
789 an N_Attribute_Reference. */
792 lvalue_required_for_attribute_p (Node_Id gnat_node
)
794 switch (Get_Attribute_Id (Attribute_Name (gnat_node
)))
800 case Attr_Range_Length
:
802 case Attr_Object_Size
:
804 case Attr_Value_Size
:
805 case Attr_Component_Size
:
806 case Attr_Descriptor_Size
:
807 case Attr_Max_Size_In_Storage_Elements
:
810 case Attr_Null_Parameter
:
811 case Attr_Passed_By_Reference
:
812 case Attr_Mechanism_Code
:
819 case Attr_Unchecked_Access
:
820 case Attr_Unrestricted_Access
:
821 case Attr_Code_Address
:
822 case Attr_Pool_Address
:
824 case Attr_Bit_Position
:
830 case Attr_Asm_Output
:
836 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
837 is the type that will be used for GNAT_NODE in the translated GNU tree.
838 CONSTANT indicates whether the underlying object represented by GNAT_NODE
839 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
840 whether its value is the address of another constant. If it isn't, then
841 ADDRESS_OF_CONSTANT is ignored.
843 The function climbs up the GNAT tree starting from the node and returns 1
844 upon encountering a node that effectively requires an lvalue downstream.
845 It returns int instead of bool to facilitate usage in non-purely binary
849 lvalue_required_p (Node_Id gnat_node
, tree gnu_type
, bool constant
,
850 bool address_of_constant
)
852 Node_Id gnat_parent
= Parent (gnat_node
), gnat_temp
;
854 switch (Nkind (gnat_parent
))
859 case N_Attribute_Reference
:
860 return lvalue_required_for_attribute_p (gnat_parent
);
862 case N_Parameter_Association
:
863 case N_Function_Call
:
864 case N_Procedure_Call_Statement
:
865 /* If the parameter is by reference, an lvalue is required. */
867 || must_pass_by_ref (gnu_type
)
868 || default_pass_by_ref (gnu_type
));
870 case N_Indexed_Component
:
871 /* Only the array expression can require an lvalue. */
872 if (Prefix (gnat_parent
) != gnat_node
)
875 /* ??? Consider that referencing an indexed component with a variable
876 index forces the whole aggregate to memory. Note that testing only
877 for literals is conservative, any static expression in the RM sense
878 could probably be accepted with some additional work. */
879 for (gnat_temp
= First (Expressions (gnat_parent
));
881 gnat_temp
= Next (gnat_temp
))
882 if (Nkind (gnat_temp
) != N_Character_Literal
883 && Nkind (gnat_temp
) != N_Integer_Literal
884 && !(Is_Entity_Name (gnat_temp
)
885 && Ekind (Entity (gnat_temp
)) == E_Enumeration_Literal
))
888 /* ... fall through ... */
890 case N_Selected_Component
:
892 /* Only the prefix expression can require an lvalue. */
893 if (Prefix (gnat_parent
) != gnat_node
)
896 return lvalue_required_p (gnat_parent
,
897 get_unpadded_type (Etype (gnat_parent
)),
898 constant
, address_of_constant
);
900 case N_Object_Renaming_Declaration
:
901 /* We need to preserve addresses through a renaming. */
904 case N_Object_Declaration
:
905 /* We cannot use a constructor if this is an atomic object because
906 the actual assignment might end up being done component-wise. */
908 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
909 && Is_Full_Access (Defining_Entity (gnat_parent
)))
910 /* We don't use a constructor if this is a class-wide object
911 because the effective type of the object is the equivalent
912 type of the class-wide subtype and it smashes most of the
913 data into an array of bytes to which we cannot convert. */
914 || Ekind ((Etype (Defining_Entity (gnat_parent
))))
915 == E_Class_Wide_Subtype
);
917 case N_Assignment_Statement
:
918 /* We cannot use a constructor if the LHS is an atomic object because
919 the actual assignment might end up being done component-wise. */
921 || Name (gnat_parent
) == gnat_node
922 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
923 && Is_Entity_Name (Name (gnat_parent
))
924 && Is_Full_Access (Entity (Name (gnat_parent
)))));
926 case N_Unchecked_Type_Conversion
:
930 /* ... fall through ... */
932 case N_Type_Conversion
:
933 case N_Qualified_Expression
:
934 /* We must look through all conversions because we may need to bypass
935 an intermediate conversion that is meant to be purely formal. */
936 return lvalue_required_p (gnat_parent
,
937 get_unpadded_type (Etype (gnat_parent
)),
938 constant
, address_of_constant
);
940 case N_Explicit_Dereference
:
941 /* We look through dereferences for address of constant because we need
942 to handle the special cases listed above. */
943 if (constant
&& address_of_constant
)
944 return lvalue_required_p (gnat_parent
,
945 get_unpadded_type (Etype (gnat_parent
)),
948 /* ... fall through ... */
957 /* Return true if an lvalue should be used for GNAT_NODE. GNU_TYPE is the type
958 that will be used for GNAT_NODE in the translated GNU tree and is assumed to
959 be an aggregate type.
961 The function climbs up the GNAT tree starting from the node and returns true
962 upon encountering a node that makes it doable to decide. lvalue_required_p
963 should have been previously invoked on the arguments and returned false. */
966 lvalue_for_aggregate_p (Node_Id gnat_node
, tree gnu_type
)
968 Node_Id gnat_parent
= Parent (gnat_node
);
970 switch (Nkind (gnat_parent
))
972 case N_Parameter_Association
:
973 case N_Function_Call
:
974 case N_Procedure_Call_Statement
:
975 /* Even if the parameter is by copy, prefer an lvalue. */
978 case N_Simple_Return_Statement
:
979 /* Likewise for a return value. */
982 case N_Indexed_Component
:
983 case N_Selected_Component
:
984 /* If an elementary component is used, take it from the constant. */
985 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_parent
))))
988 /* ... fall through ... */
991 return lvalue_for_aggregate_p (gnat_parent
,
992 get_unpadded_type (Etype (gnat_parent
)));
994 case N_Object_Declaration
:
995 /* For an aggregate object declaration, return false consistently. */
998 case N_Assignment_Statement
:
999 /* For an aggregate assignment, decide based on the size. */
1001 const HOST_WIDE_INT size
= int_size_in_bytes (gnu_type
);
1002 return size
< 0 || size
>= param_large_stack_frame
/ 4;
1005 case N_Unchecked_Type_Conversion
:
1006 case N_Type_Conversion
:
1007 case N_Qualified_Expression
:
1008 return lvalue_for_aggregate_p (gnat_parent
,
1009 get_unpadded_type (Etype (gnat_parent
)));
1012 /* We should only reach here through the N_Qualified_Expression case.
1013 Force an lvalue for aggregate types since a block-copy to the newly
1014 allocated area of memory is made. */
1025 /* Return true if T is a constant DECL node that can be safely replaced
1026 by its initializer. */
1029 constant_decl_with_initializer_p (tree t
)
1031 if (!TREE_CONSTANT (t
) || !DECL_P (t
) || !DECL_INITIAL (t
))
1034 /* Return false for aggregate types that contain a placeholder since
1035 their initializers cannot be manipulated easily. */
1036 if (AGGREGATE_TYPE_P (TREE_TYPE (t
))
1037 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t
))
1038 && type_contains_placeholder_p (TREE_TYPE (t
)))
1044 /* Return an expression equivalent to EXP but where constant DECL nodes
1045 have been replaced by their initializer. */
1048 fold_constant_decl_in_expr (tree exp
)
1050 enum tree_code code
= TREE_CODE (exp
);
1057 if (!constant_decl_with_initializer_p (exp
))
1060 return DECL_INITIAL (exp
);
1063 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1064 if (op0
== TREE_OPERAND (exp
, 0))
1067 return fold_build3 (COMPONENT_REF
, TREE_TYPE (exp
), op0
,
1068 TREE_OPERAND (exp
, 1), NULL_TREE
);
1071 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1072 if (op0
== TREE_OPERAND (exp
, 0))
1075 return fold_build3 (BIT_FIELD_REF
, TREE_TYPE (exp
), op0
,
1076 TREE_OPERAND (exp
, 1), TREE_OPERAND (exp
, 2));
1079 case ARRAY_RANGE_REF
:
1080 /* If the index is not itself constant, then nothing can be folded. */
1081 if (!TREE_CONSTANT (TREE_OPERAND (exp
, 1)))
1083 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1084 if (op0
== TREE_OPERAND (exp
, 0))
1087 return fold (build4 (code
, TREE_TYPE (exp
), op0
, TREE_OPERAND (exp
, 1),
1088 TREE_OPERAND (exp
, 2), NULL_TREE
));
1092 case VIEW_CONVERT_EXPR
:
1093 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1094 if (op0
== TREE_OPERAND (exp
, 0))
1097 return fold_build1 (code
, TREE_TYPE (exp
), op0
);
1106 /* Return true if TYPE and DEF_TYPE are compatible GNAT types for Gigi. */
1109 Gigi_Types_Compatible (Entity_Id type
, Entity_Id def_type
)
1111 /* The trivial case. */
1112 if (type
== def_type
)
1115 /* A class-wide type is equivalent to a subtype of itself. */
1116 if (Is_Class_Wide_Type (type
))
1119 /* A packed array type is compatible with its implementation type. */
1120 if (Is_Packed (def_type
) && type
== Packed_Array_Impl_Type (def_type
))
1123 /* If both types are Itypes, one may be a copy of the other. */
1124 if (Is_Itype (def_type
) && Is_Itype (type
))
1127 /* If the type is incomplete and comes from a limited context, then also
1128 consider its non-limited view. */
1129 if (Is_Incomplete_Type (def_type
)
1130 && From_Limited_With (def_type
)
1131 && Present (Non_Limited_View (def_type
)))
1132 return Gigi_Types_Compatible (type
, Non_Limited_View (def_type
));
1134 /* If the type is incomplete/private, then also consider its full view. */
1135 if (Is_Incomplete_Or_Private_Type (def_type
)
1136 && Present (Full_View (def_type
)))
1137 return Gigi_Types_Compatible (type
, Full_View (def_type
));
1142 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
1143 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
1144 to where we should place the result type. */
1147 Identifier_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
1149 /* The entity of GNAT_NODE and its type. */
1150 Node_Id gnat_entity
= (Nkind (gnat_node
) == N_Defining_Identifier
1151 || Nkind (gnat_node
) == N_Defining_Operator_Symbol
)
1152 ? gnat_node
: Entity (gnat_node
);
1153 Node_Id gnat_entity_type
= Etype (gnat_entity
);
1154 /* If GNAT_NODE is a constant, whether we should use the initialization
1155 value instead of the constant entity, typically for scalars with an
1156 address clause when the parent doesn't require an lvalue. */
1157 bool use_constant_initializer
= false;
1158 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1159 specific circumstances only, so evaluated lazily. < 0 means
1160 unknown, > 0 means known true, 0 means known false. */
1161 int require_lvalue
= -1;
1162 Node_Id gnat_result_type
;
1163 tree gnu_result
, gnu_result_type
;
1165 /* If the Etype of this node is not the same as that of the Entity, then
1166 something went wrong, probably in generic instantiation. However, this
1167 does not apply to types. Since we sometime have strange Ekind's, just
1168 do this test for objects, except for discriminants because their type
1169 may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */
1170 gcc_assert (!Is_Object (gnat_entity
)
1171 || Ekind (gnat_entity
) == E_Discriminant
1172 || Etype (gnat_node
) == gnat_entity_type
1173 || Gigi_Types_Compatible (Etype (gnat_node
), gnat_entity_type
));
1175 /* If this is a reference to a deferred constant whose partial view is an
1176 unconstrained private type, the proper type is on the full view of the
1177 constant, not on the full view of the type, which may be unconstrained.
1179 This may be a reference to a type, for example in the prefix of the
1180 attribute Position, generated for dispatching code (see Make_DT in
1181 exp_disp,adb). In that case we need the type itself, not is parent,
1182 in particular if it is a derived type */
1183 if (Ekind (gnat_entity
) == E_Constant
1184 && Is_Private_Type (gnat_entity_type
)
1185 && (Has_Unknown_Discriminants (gnat_entity_type
)
1186 || (Present (Full_View (gnat_entity_type
))
1187 && Has_Discriminants (Full_View (gnat_entity_type
))))
1188 && Present (Full_View (gnat_entity
)))
1190 gnat_entity
= Full_View (gnat_entity
);
1191 gnat_result_type
= Etype (gnat_entity
);
1195 /* We use the Actual_Subtype only if it has already been elaborated,
1196 as we may be invoked precisely during its elaboration, otherwise
1197 the Etype. Avoid using it for packed arrays to simplify things,
1198 except in a return statement because we need the actual size and
1199 the front-end does not make it explicit in this case. */
1200 if ((Ekind (gnat_entity
) == E_Constant
1201 || Ekind (gnat_entity
) == E_Variable
1202 || Is_Formal (gnat_entity
))
1203 && !(Is_Array_Type (Etype (gnat_entity
))
1204 && Present (Packed_Array_Impl_Type (Etype (gnat_entity
)))
1205 && Nkind (Parent (gnat_node
)) != N_Simple_Return_Statement
)
1206 && Present (Actual_Subtype (gnat_entity
))
1207 && present_gnu_tree (Actual_Subtype (gnat_entity
)))
1208 gnat_result_type
= Actual_Subtype (gnat_entity
);
1210 gnat_result_type
= Etype (gnat_node
);
1213 /* Expand the type of this identifier first, in case it is an enumeral
1214 literal, which only get made when the type is expanded. There is no
1215 order-of-elaboration issue here. */
1216 gnu_result_type
= get_unpadded_type (gnat_result_type
);
1218 /* If this is a non-imported elementary constant with an address clause,
1219 retrieve the value instead of a pointer to be dereferenced unless
1220 an lvalue is required. This is generally more efficient and actually
1221 required if this is a static expression because it might be used
1222 in a context where a dereference is inappropriate, such as a case
1223 statement alternative or a record discriminant. There is no possible
1224 volatile-ness short-circuit here since Volatile constants must be
1225 imported per C.6. */
1226 if (Ekind (gnat_entity
) == E_Constant
1227 && Is_Elementary_Type (gnat_result_type
)
1228 && !Is_Imported (gnat_entity
)
1229 && Present (Address_Clause (gnat_entity
)))
1232 = lvalue_required_p (gnat_node
, gnu_result_type
, true, false);
1233 use_constant_initializer
= !require_lvalue
;
1236 if (use_constant_initializer
)
1238 /* If this is a deferred constant, the initializer is attached to
1240 if (Present (Full_View (gnat_entity
)))
1241 gnat_entity
= Full_View (gnat_entity
);
1243 gnu_result
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
1246 gnu_result
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
1248 /* Some objects (such as parameters passed by reference, globals of
1249 variable size, and renamed objects) actually represent the address
1250 of the object. In that case, we must do the dereference. Likewise,
1251 deal with parameters to foreign convention subprograms. */
1252 if (DECL_P (gnu_result
)
1253 && (DECL_BY_REF_P (gnu_result
)
1254 || (TREE_CODE (gnu_result
) == PARM_DECL
1255 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
1257 const bool read_only
= DECL_POINTS_TO_READONLY_P (gnu_result
);
1259 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1260 if (TREE_CODE (gnu_result
) == PARM_DECL
1261 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
1263 = convert (build_pointer_type (gnu_result_type
), gnu_result
);
1265 /* If it's a CONST_DECL, return the underlying constant like below. */
1266 else if (TREE_CODE (gnu_result
) == CONST_DECL
1267 && !(DECL_CONST_ADDRESS_P (gnu_result
)
1268 && lvalue_required_p (gnat_node
, gnu_result_type
, true,
1270 gnu_result
= DECL_INITIAL (gnu_result
);
1272 /* Do the final dereference. */
1273 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
1275 if ((TREE_CODE (gnu_result
) == INDIRECT_REF
1276 || TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
1277 && No (Address_Clause (gnat_entity
)))
1278 TREE_THIS_NOTRAP (gnu_result
) = 1;
1281 TREE_READONLY (gnu_result
) = 1;
1284 /* If we have a constant declaration and its initializer, try to return the
1285 latter to avoid the need to call fold in lots of places and the need for
1286 elaboration code if this identifier is used as an initializer itself. */
1287 if (constant_decl_with_initializer_p (gnu_result
))
1289 bool constant_only
= (TREE_CODE (gnu_result
) == CONST_DECL
1290 && !DECL_CONST_CORRESPONDING_VAR (gnu_result
));
1291 bool address_of_constant
= (TREE_CODE (gnu_result
) == CONST_DECL
1292 && DECL_CONST_ADDRESS_P (gnu_result
));
1294 /* If there is a (corresponding) variable or this is the address of a
1295 constant, we only want to return the initializer if an lvalue isn't
1296 required. Evaluate this now if we have not already done so. */
1297 if ((!constant_only
|| address_of_constant
) && require_lvalue
< 0)
1299 = lvalue_required_p (gnat_node
, gnu_result_type
, true,
1300 address_of_constant
)
1301 || (AGGREGATE_TYPE_P (gnu_result_type
)
1302 && lvalue_for_aggregate_p (gnat_node
, gnu_result_type
));
1304 /* Finally retrieve the initializer if this is deemed valid. */
1305 if ((constant_only
&& !address_of_constant
) || !require_lvalue
)
1306 gnu_result
= DECL_INITIAL (gnu_result
);
1309 /* But for a constant renaming we couldn't do that incrementally for its
1310 definition because of the need to return an lvalue so, if the present
1311 context doesn't itself require an lvalue, we try again here. */
1312 else if (Ekind (gnat_entity
) == E_Constant
1313 && Is_Elementary_Type (gnat_result_type
)
1314 && Present (Renamed_Object (gnat_entity
)))
1316 if (require_lvalue
< 0)
1318 = lvalue_required_p (gnat_node
, gnu_result_type
, true, false);
1319 if (!require_lvalue
)
1320 gnu_result
= fold_constant_decl_in_expr (gnu_result
);
1323 /* The GNAT tree has the type of a function set to its result type, so we
1324 adjust here. Also use the type of the result if the Etype is a subtype
1325 that is nominally unconstrained. Likewise if this is a deferred constant
1326 of a discriminated type whose full view can be elaborated statically, to
1327 avoid problematic conversions to the nominal subtype. But remove any
1328 padding from the resulting type. */
1329 if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_result
))
1330 || Is_Constr_Subt_For_UN_Aliased (gnat_result_type
)
1331 || (Ekind (gnat_entity
) == E_Constant
1332 && Present (Full_View (gnat_entity
))
1333 && Has_Discriminants (gnat_result_type
)
1334 && TREE_CODE (gnu_result
) == CONSTRUCTOR
))
1336 gnu_result_type
= TREE_TYPE (gnu_result
);
1337 if (TYPE_IS_PADDING_P (gnu_result_type
))
1338 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
1341 *gnu_result_type_p
= gnu_result_type
;
1346 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1347 any statements we generate. */
1350 Pragma_to_gnu (Node_Id gnat_node
)
1352 tree gnu_result
= alloc_stmt_list ();
1355 /* Check for (and ignore) unrecognized pragmas. */
1356 if (!Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node
))))
1359 const unsigned char id
1360 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)));
1362 /* Save the expression of pragma Compile_Time_{Error|Warning} for later. */
1363 if (id
== Pragma_Compile_Time_Error
|| id
== Pragma_Compile_Time_Warning
)
1365 gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1366 gnat_compile_time_expr_list
.safe_push (Expression (gnat_temp
));
1370 /* Stop there if we are just annotating types. */
1371 if (type_annotate_only
)
1376 case Pragma_Inspection_Point
:
1377 /* Do nothing at top level: all such variables are already viewable. */
1378 if (global_bindings_p ())
1381 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1382 Present (gnat_temp
);
1383 gnat_temp
= Next (gnat_temp
))
1385 Node_Id gnat_expr
= Expression (gnat_temp
);
1386 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1387 tree asm_constraint
= NULL_TREE
;
1388 #ifdef ASM_COMMENT_START
1391 gnu_expr
= maybe_unconstrained_array (gnu_expr
);
1392 gnat_mark_addressable (gnu_expr
);
1394 #ifdef ASM_COMMENT_START
1395 comment
= concat (ASM_COMMENT_START
,
1396 " inspection point: ",
1397 Get_Name_String (Chars (gnat_expr
)),
1400 asm_constraint
= build_string (strlen (comment
), comment
);
1403 gnu_expr
= build5 (ASM_EXPR
, void_type_node
,
1407 (build_tree_list (NULL_TREE
,
1408 build_string (1, "m")),
1409 gnu_expr
, NULL_TREE
),
1410 NULL_TREE
, NULL_TREE
);
1411 ASM_VOLATILE_P (gnu_expr
) = 1;
1412 set_expr_location_from_node (gnu_expr
, gnat_node
);
1413 append_to_statement_list (gnu_expr
, &gnu_result
);
1417 case Pragma_Loop_Optimize
:
1418 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1419 Present (gnat_temp
);
1420 gnat_temp
= Next (gnat_temp
))
1422 tree gnu_loop_stmt
= gnu_loop_stack
->last ()->stmt
;
1424 switch (Chars (Expression (gnat_temp
)))
1427 LOOP_STMT_IVDEP (gnu_loop_stmt
) = 1;
1430 case Name_No_Unroll
:
1431 LOOP_STMT_NO_UNROLL (gnu_loop_stmt
) = 1;
1435 LOOP_STMT_UNROLL (gnu_loop_stmt
) = 1;
1438 case Name_No_Vector
:
1439 LOOP_STMT_NO_VECTOR (gnu_loop_stmt
) = 1;
1443 LOOP_STMT_VECTOR (gnu_loop_stmt
) = 1;
1452 case Pragma_Optimize
:
1453 switch (Chars (Expression
1454 (First (Pragma_Argument_Associations (gnat_node
)))))
1458 post_error ("must specify -O0?", gnat_node
);
1463 post_error ("must specify -Os?", gnat_node
);
1468 post_error ("insufficient -O value?", gnat_node
);
1476 case Pragma_Reviewable
:
1477 if (write_symbols
== NO_DEBUG
)
1478 post_error ("must specify -g?", gnat_node
);
1481 case Pragma_Warning_As_Error
:
1482 case Pragma_Warnings
:
1485 /* Preserve the location of the pragma. */
1486 const location_t location
= input_location
;
1487 struct cl_option_handlers handlers
;
1488 unsigned int option_index
;
1492 gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1494 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1495 if (Nkind (Expression (gnat_temp
)) == N_String_Literal
)
1499 case Pragma_Warning_As_Error
:
1504 case Pragma_Warnings
:
1513 gnat_expr
= Expression (gnat_temp
);
1516 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1517 else if (Nkind (Expression (gnat_temp
)) == N_Identifier
)
1519 switch (Chars (Expression (gnat_temp
)))
1533 /* Deal with optional pattern (but ignore Reason => "..."). */
1534 if (Present (Next (gnat_temp
))
1535 && Chars (Next (gnat_temp
)) != Name_Reason
)
1537 /* pragma Warnings (On | Off, Name) is handled differently. */
1538 if (Nkind (Expression (Next (gnat_temp
))) != N_String_Literal
)
1541 gnat_expr
= Expression (Next (gnat_temp
));
1547 /* For pragma Warnings (Off), we save the current state... */
1548 if (kind
== DK_IGNORED
)
1549 diagnostic_push_diagnostics (global_dc
, location
);
1551 /* ...so that, for pragma Warnings (On), we do not enable all
1552 the warnings but just restore the previous state. */
1555 diagnostic_pop_diagnostics (global_dc
, location
);
1566 /* This is the same implementation as in the C family of compilers. */
1567 const unsigned int lang_mask
= CL_Ada
| CL_COMMON
;
1568 const char *arg
= NULL
;
1569 if (Present (gnat_expr
))
1571 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1572 const char *option_string
= TREE_STRING_POINTER (gnu_expr
);
1573 const int len
= TREE_STRING_LENGTH (gnu_expr
);
1574 if (len
< 3 || option_string
[0] != '-' || option_string
[1] != 'W')
1576 option_index
= find_opt (option_string
+ 1, lang_mask
);
1577 if (option_index
== OPT_SPECIAL_unknown
)
1579 post_error ("?unknown -W switch", gnat_node
);
1582 else if (!(cl_options
[option_index
].flags
& CL_WARNING
))
1584 post_error ("?-W switch does not control warning", gnat_node
);
1587 else if (!(cl_options
[option_index
].flags
& lang_mask
))
1589 post_error ("?-W switch not valid for Ada", gnat_node
);
1592 if (cl_options
[option_index
].flags
& CL_JOINED
)
1593 arg
= option_string
+ 1 + cl_options
[option_index
].opt_len
;
1598 set_default_handlers (&handlers
, NULL
);
1599 control_warning_option (option_index
, (int) kind
, arg
, imply
, location
,
1600 lang_mask
, &handlers
, &global_options
,
1601 &global_options_set
, global_dc
);
1612 /* Check the inline status of nested function FNDECL wrt its parent function.
1614 If a non-inline nested function is referenced from an inline external
1615 function, we cannot honor both requests at the same time without cloning
1616 the nested function in the current unit since it is private to its unit.
1617 We could inline it as well but it's probably better to err on the side
1618 of too little inlining.
1620 This must be done only on nested functions present in the source code
1621 and not on nested functions generated by the compiler, e.g. finalizers,
1622 because they may be not marked inline and we don't want them to block
1623 the inlining of the parent function. */
1626 check_inlining_for_nested_subprog (tree fndecl
)
1628 if (DECL_IGNORED_P (current_function_decl
) || DECL_IGNORED_P (fndecl
))
1631 if (DECL_DECLARED_INLINE_P (fndecl
))
1634 tree parent_decl
= decl_function_context (fndecl
);
1635 if (DECL_EXTERNAL (parent_decl
) && DECL_DECLARED_INLINE_P (parent_decl
))
1637 const location_t loc1
= DECL_SOURCE_LOCATION (fndecl
);
1638 const location_t loc2
= DECL_SOURCE_LOCATION (parent_decl
);
1640 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl
)))
1642 error_at (loc1
, "subprogram %q+F not marked %<Inline_Always%>",
1644 error_at (loc2
, "parent subprogram cannot be inlined");
1648 warning_at (loc1
, OPT_Winline
, "subprogram %q+F not marked %<Inline%>",
1650 warning_at (loc2
, OPT_Winline
, "parent subprogram cannot be inlined");
1653 DECL_DECLARED_INLINE_P (parent_decl
) = 0;
1654 DECL_UNINLINABLE (parent_decl
) = 1;
1658 /* Return an expression for the length of TYPE, an integral type, computed in
1659 RESULT_TYPE, another integral type.
1661 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
1662 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
1663 which would only overflow in much rarer cases, for extremely large arrays
1664 we expect never to encounter in practice. Besides, the former computation
1665 required the use of potentially constraining signed arithmetics while the
1666 latter does not. Note that the comparison must be done in the original
1667 base index type in order to avoid any overflow during the conversion. */
1670 get_type_length (tree type
, tree result_type
)
1672 tree comp_type
= get_base_type (result_type
);
1673 tree base_type
= maybe_character_type (get_base_type (type
));
1674 tree lb
= convert (base_type
, TYPE_MIN_VALUE (type
));
1675 tree hb
= convert (base_type
, TYPE_MAX_VALUE (type
));
1677 = build_binary_op (PLUS_EXPR
, comp_type
,
1678 build_binary_op (MINUS_EXPR
, comp_type
,
1679 convert (comp_type
, hb
),
1680 convert (comp_type
, lb
)),
1681 build_int_cst (comp_type
, 1));
1683 = build_cond_expr (result_type
,
1684 build_binary_op (GE_EXPR
, boolean_type_node
, hb
, lb
),
1685 convert (result_type
, length
),
1686 build_int_cst (result_type
, 0));
1690 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1691 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1692 where we should place the result type. ATTRIBUTE is the attribute ID. */
1695 Attribute_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, int attribute
)
1697 const Node_Id gnat_prefix
= Prefix (gnat_node
);
1698 tree gnu_prefix
= gnat_to_gnu (gnat_prefix
);
1699 tree gnu_type
= TREE_TYPE (gnu_prefix
);
1700 tree gnu_expr
, gnu_result_type
, gnu_result
= error_mark_node
;
1701 bool prefix_unused
= false;
1703 /* If the input is a NULL_EXPR, make a new one. */
1704 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1706 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1707 *gnu_result_type_p
= gnu_result_type
;
1708 return build1 (NULL_EXPR
, gnu_result_type
, TREE_OPERAND (gnu_prefix
, 0));
1715 /* These just add or subtract the constant 1 since representation
1716 clauses for enumeration types are handled in the front-end. */
1717 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1718 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1719 gnu_type
= maybe_character_type (gnu_result_type
);
1720 if (TREE_TYPE (gnu_expr
) != gnu_type
)
1721 gnu_expr
= convert (gnu_type
, gnu_expr
);
1723 = build_binary_op (attribute
== Attr_Pred
? MINUS_EXPR
: PLUS_EXPR
,
1724 gnu_type
, gnu_expr
, build_int_cst (gnu_type
, 1));
1728 case Attr_Unrestricted_Access
:
1729 /* Conversions don't change the address of references but can cause
1730 build_unary_op to miss the references below, so strip them off.
1731 On the contrary, if the address-of operation causes a temporary
1732 to be created, then it must be created with the proper type. */
1733 gnu_expr
= remove_conversions (gnu_prefix
,
1734 !Must_Be_Byte_Aligned (gnat_node
));
1735 if (REFERENCE_CLASS_P (gnu_expr
))
1736 gnu_prefix
= gnu_expr
;
1738 /* If we are taking 'Address of an unconstrained object, this is the
1739 pointer to the underlying array. */
1740 if (attribute
== Attr_Address
)
1741 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1743 /* If we are building a static dispatch table, we have to honor
1744 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1745 with the C++ ABI. We do it in the non-static case as well,
1746 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1747 else if (TARGET_VTABLE_USES_DESCRIPTORS
1748 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
1751 /* Descriptors can only be built here for top-level functions. */
1752 bool build_descriptor
= (global_bindings_p () != 0);
1754 vec
<constructor_elt
, va_gc
> *gnu_vec
= NULL
;
1755 constructor_elt
*elt
;
1757 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1759 /* If we're not going to build the descriptor, we have to retrieve
1760 the one which will be built by the linker (or by the compiler
1761 later if a static chain is requested). */
1762 if (!build_descriptor
)
1764 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_prefix
);
1765 gnu_result
= fold_convert (build_pointer_type (gnu_result_type
),
1767 gnu_result
= build1 (INDIRECT_REF
, gnu_result_type
, gnu_result
);
1770 vec_safe_grow (gnu_vec
, TARGET_VTABLE_USES_DESCRIPTORS
, true);
1771 elt
= (gnu_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
1772 for (gnu_field
= TYPE_FIELDS (gnu_result_type
), i
= 0;
1773 i
< TARGET_VTABLE_USES_DESCRIPTORS
;
1774 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
1776 if (build_descriptor
)
1778 t
= build2 (FDESC_EXPR
, TREE_TYPE (gnu_field
), gnu_prefix
,
1779 build_int_cst (NULL_TREE
, i
));
1780 TREE_CONSTANT (t
) = 1;
1783 t
= build3 (COMPONENT_REF
, ptr_void_ftype
, gnu_result
,
1784 gnu_field
, NULL_TREE
);
1786 elt
->index
= gnu_field
;
1791 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
1795 /* ... fall through ... */
1798 case Attr_Unchecked_Access
:
1799 case Attr_Code_Address
:
1800 /* Taking the address of a type does not make sense. */
1801 gcc_assert (TREE_CODE (gnu_prefix
) != TYPE_DECL
);
1803 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1805 = build_unary_op (((attribute
== Attr_Address
1806 || attribute
== Attr_Unrestricted_Access
)
1807 && !Must_Be_Byte_Aligned (gnat_node
))
1808 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1809 gnu_result_type
, gnu_prefix
);
1811 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1812 don't try to build a trampoline. */
1813 if (attribute
== Attr_Code_Address
)
1815 gnu_expr
= remove_conversions (gnu_result
, false);
1817 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1818 TREE_NO_TRAMPOLINE (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1820 /* On targets for which function symbols denote a descriptor, the
1821 code address is stored within the first slot of the descriptor
1822 so we do an additional dereference:
1823 result = *((result_type *) result)
1824 where we expect result to be of some pointer type already. */
1825 if (targetm
.calls
.custom_function_descriptors
== 0)
1827 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1828 convert (build_pointer_type (gnu_result_type
),
1832 /* For 'Access, issue an error message if the prefix is a C++ method
1833 since it can use a special calling convention on some platforms,
1834 which cannot be propagated to the access type. */
1835 else if (attribute
== Attr_Access
1836 && TREE_CODE (TREE_TYPE (gnu_prefix
)) == METHOD_TYPE
)
1837 post_error ("access to C++ constructor or member function not allowed",
1840 /* For other address attributes applied to a nested function,
1841 find an inner ADDR_EXPR and annotate it so that we can issue
1842 a useful warning with -Wtrampolines. */
1843 else if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_prefix
))
1844 && (gnu_expr
= remove_conversions (gnu_result
, false))
1845 && TREE_CODE (gnu_expr
) == ADDR_EXPR
1846 && decl_function_context (TREE_OPERAND (gnu_expr
, 0)))
1848 set_expr_location_from_node (gnu_expr
, gnat_node
);
1850 /* Also check the inlining status. */
1851 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr
, 0));
1853 /* Moreover, for 'Access or 'Unrestricted_Access with non-
1854 foreign-compatible representation, mark the ADDR_EXPR so
1855 that we can build a descriptor instead of a trampoline. */
1856 if ((attribute
== Attr_Access
1857 || attribute
== Attr_Unrestricted_Access
)
1858 && targetm
.calls
.custom_function_descriptors
> 0
1859 && Can_Use_Internal_Rep (Underlying_Type (Etype (gnat_node
))))
1860 FUNC_ADDR_BY_DESCRIPTOR (gnu_expr
) = 1;
1862 /* Otherwise, we need to check that we are not violating the
1863 No_Implicit_Dynamic_Code restriction. */
1864 else if (targetm
.calls
.custom_function_descriptors
!= 0)
1865 Check_Implicit_Dynamic_Code_Allowed (gnat_node
);
1869 case Attr_Pool_Address
:
1871 tree gnu_ptr
= gnu_prefix
;
1874 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1876 /* If this is fat pointer, the object must have been allocated with the
1877 template in front of the array. So compute the template address; do
1878 it by converting to a thin pointer. */
1879 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
1881 = convert (build_pointer_type
1882 (TYPE_OBJECT_RECORD_TYPE
1883 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
1886 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
1888 /* If this is a thin pointer, the object must have been allocated with
1889 the template in front of the array. So compute the template address
1891 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
1893 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
1895 fold_build1 (NEGATE_EXPR
, sizetype
,
1898 TYPE_FIELDS ((gnu_obj_type
)))));
1900 gnu_result
= convert (gnu_result_type
, gnu_ptr
);
1905 case Attr_Object_Size
:
1906 case Attr_Value_Size
:
1907 case Attr_Max_Size_In_Storage_Elements
:
1908 /* Strip NOPs, conversions between original and packable versions, and
1909 unpadding from GNU_PREFIX. Note that we cannot simply strip every
1910 VIEW_CONVERT_EXPR because some of them may give the actual size, e.g.
1911 for nominally unconstrained packed array. We use GNU_EXPR to see
1912 if a COMPONENT_REF was involved. */
1913 while (CONVERT_EXPR_P (gnu_prefix
)
1914 || TREE_CODE (gnu_prefix
) == NON_LVALUE_EXPR
1915 || (TREE_CODE (gnu_prefix
) == VIEW_CONVERT_EXPR
1916 && TREE_CODE (TREE_TYPE (gnu_prefix
)) == RECORD_TYPE
1917 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1919 && TYPE_NAME (TREE_TYPE (gnu_prefix
))
1920 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1921 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1922 gnu_expr
= gnu_prefix
;
1923 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1924 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
1925 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1926 prefix_unused
= true;
1927 gnu_type
= TREE_TYPE (gnu_prefix
);
1929 /* Replace an unconstrained array type with the type of the underlying
1930 array, except for 'Max_Size_In_Storage_Elements because we need to
1931 return the (maximum) size requested for an allocator. */
1932 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1934 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1935 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1936 gnu_type
= TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
1939 /* The type must be frozen at this point. */
1940 gcc_assert (COMPLETE_TYPE_P (gnu_type
));
1942 /* If we're looking for the size of a field, return the field size. */
1943 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1944 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1946 /* Otherwise, if the prefix is an object, or if we are looking for
1947 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1948 GCC size of the type. We make an exception for padded objects,
1949 as we do not take into account alignment promotions for the size.
1950 This is in keeping with the object case of gnat_to_gnu_entity. */
1951 else if ((TREE_CODE (gnu_prefix
) != TYPE_DECL
1952 && !(TYPE_IS_PADDING_P (gnu_type
)
1953 && TREE_CODE (gnu_expr
) == COMPONENT_REF
1954 && pad_type_has_rm_size (gnu_type
)))
1955 || attribute
== Attr_Object_Size
1956 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1958 /* If this is a dereference and we have a special dynamic constrained
1959 subtype on the prefix, use it to compute the size; otherwise, use
1960 the designated subtype. */
1961 if (Nkind (gnat_prefix
) == N_Explicit_Dereference
)
1963 Node_Id gnat_actual_subtype
1964 = Actual_Designated_Subtype (gnat_prefix
);
1966 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix
)));
1968 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
)
1969 && Present (gnat_actual_subtype
))
1971 tree gnu_actual_obj_type
1972 = gnat_to_gnu_type (gnat_actual_subtype
);
1974 = build_unc_object_type_from_ptr (gnu_ptr_type
,
1975 gnu_actual_obj_type
,
1976 get_identifier ("SIZE"),
1981 gnu_result
= TYPE_SIZE (gnu_type
);
1984 /* Otherwise, the result is the RM size of the type. */
1986 gnu_result
= rm_size (gnu_type
);
1988 /* Deal with a self-referential size by qualifying the size with the
1989 object or returning the maximum size for a type. */
1990 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1991 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
1992 else if (CONTAINS_PLACEHOLDER_P (gnu_result
))
1993 gnu_result
= max_size (gnu_result
, true);
1995 /* If the type contains a template, subtract the padded size of the
1996 template, except for 'Max_Size_In_Storage_Elements because we need
1997 to return the (maximum) size requested for an allocator. */
1998 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1999 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
2000 && attribute
!= Attr_Max_Size_In_Storage_Elements
)
2002 = size_binop (MINUS_EXPR
, gnu_result
,
2003 bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type
))));
2005 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
2006 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
2007 gnu_result
= size_binop (CEIL_DIV_EXPR
, gnu_result
, bitsize_unit_node
);
2009 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2012 case Attr_Alignment
:
2016 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2017 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
2018 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
2020 gnu_type
= TREE_TYPE (gnu_prefix
);
2021 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2022 prefix_unused
= true;
2024 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2025 align
= DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)) / BITS_PER_UNIT
;
2028 Entity_Id gnat_type
= Etype (gnat_prefix
);
2029 unsigned int double_align
;
2030 bool is_capped_double
, align_clause
;
2032 /* If the default alignment of "double" or larger scalar types is
2033 specifically capped and there is an alignment clause neither
2034 on the type nor on the prefix itself, return the cap. */
2035 if ((double_align
= double_float_alignment
) > 0)
2037 = is_double_float_or_array (gnat_type
, &align_clause
);
2038 else if ((double_align
= double_scalar_alignment
) > 0)
2040 = is_double_scalar_or_array (gnat_type
, &align_clause
);
2042 is_capped_double
= align_clause
= false;
2044 if (is_capped_double
2045 && Nkind (gnat_prefix
) == N_Identifier
2046 && Present (Alignment_Clause (Entity (gnat_prefix
))))
2047 align_clause
= true;
2049 if (is_capped_double
&& !align_clause
)
2050 align
= double_align
;
2052 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
2055 gnu_result
= size_int (align
);
2061 case Attr_Range_Length
:
2062 prefix_unused
= true;
2064 if (INTEGRAL_TYPE_P (gnu_type
) || SCALAR_FLOAT_TYPE_P (gnu_type
))
2066 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2068 if (attribute
== Attr_First
)
2069 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
2070 else if (attribute
== Attr_Last
)
2071 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
2073 gnu_result
= get_type_length (gnu_type
, gnu_result_type
);
2077 /* ... fall through ... */
2081 int Dimension
= (Present (Expressions (gnat_node
))
2082 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
2084 struct parm_attr_d
*pa
= NULL
;
2085 Entity_Id gnat_param
= Empty
;
2086 bool unconstrained_ptr_deref
= false;
2088 gnu_prefix
= maybe_padded_object (gnu_prefix
);
2089 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
2091 /* We treat unconstrained array In parameters specially. We also note
2092 whether we are dereferencing a pointer to unconstrained array. */
2093 if (!Is_Constrained (Etype (gnat_prefix
)))
2094 switch (Nkind (gnat_prefix
))
2097 /* This is the direct case. */
2098 if (Ekind (Entity (gnat_prefix
)) == E_In_Parameter
)
2099 gnat_param
= Entity (gnat_prefix
);
2102 case N_Explicit_Dereference
:
2103 /* This is the indirect case. Note that we need to be sure that
2104 the access value cannot be null as we'll hoist the load. */
2105 if (Nkind (Prefix (gnat_prefix
)) == N_Identifier
2106 && Ekind (Entity (Prefix (gnat_prefix
))) == E_In_Parameter
)
2108 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix
))))
2109 gnat_param
= Entity (Prefix (gnat_prefix
));
2112 unconstrained_ptr_deref
= true;
2119 /* If the prefix is the view conversion of a constrained array to an
2120 unconstrained form, we retrieve the constrained array because we
2121 might not be able to substitute the PLACEHOLDER_EXPR coming from
2122 the conversion. This can occur with the 'Old attribute applied
2123 to a parameter with an unconstrained type, which gets rewritten
2124 into a constrained local variable very late in the game. */
2125 if (TREE_CODE (gnu_prefix
) == VIEW_CONVERT_EXPR
2126 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix
)))
2127 && !CONTAINS_PLACEHOLDER_P
2128 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
2129 gnu_type
= TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0));
2131 gnu_type
= TREE_TYPE (gnu_prefix
);
2133 prefix_unused
= true;
2134 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2136 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
2141 for (ndim
= 1, gnu_type_temp
= gnu_type
;
2142 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
2143 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
2144 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
2147 Dimension
= ndim
+ 1 - Dimension
;
2150 for (i
= 1; i
< Dimension
; i
++)
2151 gnu_type
= TREE_TYPE (gnu_type
);
2153 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
2155 /* When not optimizing, look up the slot associated with the parameter
2156 and the dimension in the cache and create a new one on failure.
2157 Don't do this when the actual subtype needs debug info (this happens
2158 with -gnatD): in elaborate_expression_1, we create variables that
2159 hold the bounds, so caching attributes isn't very interesting and
2160 causes dependency issues between these variables and cached
2163 && Present (gnat_param
)
2164 && !(Present (Actual_Subtype (gnat_param
))
2165 && Needs_Debug_Info (Actual_Subtype (gnat_param
))))
2167 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache
, i
, pa
)
2168 if (pa
->id
== gnat_param
&& pa
->dim
== Dimension
)
2173 pa
= ggc_cleared_alloc
<parm_attr_d
> ();
2174 pa
->id
= gnat_param
;
2175 pa
->dim
= Dimension
;
2176 vec_safe_push (f_parm_attr_cache
, pa
);
2180 /* Return the cached expression or build a new one. */
2181 if (attribute
== Attr_First
)
2183 if (pa
&& pa
->first
)
2185 gnu_result
= pa
->first
;
2190 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
2193 else if (attribute
== Attr_Last
)
2197 gnu_result
= pa
->last
;
2202 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
2205 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2207 if (pa
&& pa
->length
)
2209 gnu_result
= pa
->length
;
2214 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)),
2218 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2219 handling. Note that these attributes could not have been used on
2220 an unconstrained array type. */
2221 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
2223 /* Cache the expression we have just computed. Since we want to do it
2224 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2225 create the temporary in the outermost binding level. We will make
2226 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2227 paths by forcing its evaluation on entry of the function. */
2231 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
2235 pa
->first
= gnu_result
;
2239 pa
->last
= gnu_result
;
2243 case Attr_Range_Length
:
2244 pa
->length
= gnu_result
;
2252 /* Otherwise, evaluate it each time it is referenced. */
2258 /* If we are dereferencing a pointer to unconstrained array, we
2259 need to capture the value because the pointed-to bounds may
2260 subsequently be released. */
2261 if (unconstrained_ptr_deref
)
2263 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
2267 case Attr_Range_Length
:
2268 /* Set the source location onto the predicate of the condition
2269 but not if the expression is cached to avoid messing up the
2271 if (TREE_CODE (gnu_result
) == COND_EXPR
2272 && EXPR_P (TREE_OPERAND (gnu_result
, 0)))
2273 set_expr_location_from_node (TREE_OPERAND (gnu_result
, 0),
2284 case Attr_Bit_Position
:
2286 case Attr_First_Bit
:
2293 tree gnu_field_bitpos
;
2294 tree gnu_field_offset
;
2297 int unsignedp
, reversep
, volatilep
;
2299 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2300 gnu_prefix
= remove_conversions (gnu_prefix
, true);
2301 prefix_unused
= true;
2303 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2304 the result is 0. Don't allow 'Bit on a bare component, though. */
2305 if (attribute
== Attr_Bit
2306 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
2307 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
2309 gnu_result
= integer_zero_node
;
2314 gcc_assert (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2315 || (attribute
== Attr_Bit_Position
2316 && TREE_CODE (gnu_prefix
) == FIELD_DECL
));
2318 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
2319 &mode
, &unsignedp
, &reversep
, &volatilep
);
2321 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2323 gnu_field_bitpos
= bit_position (TREE_OPERAND (gnu_prefix
, 1));
2324 gnu_field_offset
= byte_position (TREE_OPERAND (gnu_prefix
, 1));
2326 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
2327 TREE_CODE (gnu_inner
) == COMPONENT_REF
2328 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
2329 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
2332 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
2333 bit_position (TREE_OPERAND (gnu_inner
, 1)));
2335 = size_binop (PLUS_EXPR
, gnu_field_offset
,
2336 byte_position (TREE_OPERAND (gnu_inner
, 1)));
2339 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
2341 gnu_field_bitpos
= bit_position (gnu_prefix
);
2342 gnu_field_offset
= byte_position (gnu_prefix
);
2346 gnu_field_bitpos
= bitsize_zero_node
;
2347 gnu_field_offset
= size_zero_node
;
2353 gnu_result
= gnu_field_offset
;
2356 case Attr_First_Bit
:
2358 gnu_result
= size_int (num_trailing_bits (bitpos
));
2362 gnu_result
= bitsize_int (num_trailing_bits (bitpos
));
2363 gnu_result
= size_binop (PLUS_EXPR
, gnu_result
,
2364 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
2365 /* ??? Avoid a large unsigned result that will overflow when
2366 converted to the signed universal_integer. */
2367 if (integer_zerop (gnu_result
))
2368 gnu_result
= integer_minus_one_node
;
2371 = size_binop (MINUS_EXPR
, gnu_result
, bitsize_one_node
);
2374 case Attr_Bit_Position
:
2375 gnu_result
= gnu_field_bitpos
;
2379 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2381 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
2388 tree gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
2389 tree gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
2391 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2393 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2394 a NaN so we implement the semantics of C99 f{min,max} to make it
2395 predictable in this case: if either operand is a NaN, the other
2396 is returned; if both operands are NaN's, a NaN is returned. */
2397 if (SCALAR_FLOAT_TYPE_P (gnu_result_type
)
2398 && !Machine_Overflows_On_Target
)
2400 const bool lhs_side_effects_p
= TREE_SIDE_EFFECTS (gnu_lhs
);
2401 const bool rhs_side_effects_p
= TREE_SIDE_EFFECTS (gnu_rhs
);
2402 tree t
= builtin_decl_explicit (BUILT_IN_ISNAN
);
2403 tree lhs_is_nan
, rhs_is_nan
;
2405 /* If the operands have side-effects, they need to be evaluated
2406 only once in spite of the multiple references in the result. */
2407 if (lhs_side_effects_p
)
2408 gnu_lhs
= gnat_protect_expr (gnu_lhs
);
2409 if (rhs_side_effects_p
)
2410 gnu_rhs
= gnat_protect_expr (gnu_rhs
);
2412 lhs_is_nan
= fold_build2 (NE_EXPR
, boolean_type_node
,
2413 build_call_expr (t
, 1, gnu_lhs
),
2416 rhs_is_nan
= fold_build2 (NE_EXPR
, boolean_type_node
,
2417 build_call_expr (t
, 1, gnu_rhs
),
2420 gnu_result
= build_binary_op (attribute
== Attr_Min
2421 ? MIN_EXPR
: MAX_EXPR
,
2422 gnu_result_type
, gnu_lhs
, gnu_rhs
);
2423 gnu_result
= fold_build3 (COND_EXPR
, gnu_result_type
,
2424 rhs_is_nan
, gnu_lhs
, gnu_result
);
2425 gnu_result
= fold_build3 (COND_EXPR
, gnu_result_type
,
2426 lhs_is_nan
, gnu_rhs
, gnu_result
);
2428 /* If the operands have side-effects, they need to be evaluated
2429 before doing the tests above since the place they otherwise
2430 would end up being evaluated at run time could be wrong. */
2431 if (lhs_side_effects_p
)
2433 = build2 (COMPOUND_EXPR
, gnu_result_type
, gnu_lhs
, gnu_result
);
2435 if (rhs_side_effects_p
)
2437 = build2 (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs
, gnu_result
);
2440 gnu_result
= build_binary_op (attribute
== Attr_Min
2441 ? MIN_EXPR
: MAX_EXPR
,
2442 gnu_result_type
, gnu_lhs
, gnu_rhs
);
2446 case Attr_Passed_By_Reference
:
2447 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
2448 || must_pass_by_ref (gnu_type
));
2449 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2452 case Attr_Component_Size
:
2453 gnu_prefix
= maybe_padded_object (gnu_prefix
);
2454 gnu_type
= TREE_TYPE (gnu_prefix
);
2456 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
2457 gnu_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
2459 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
2460 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
2461 gnu_type
= TREE_TYPE (gnu_type
);
2463 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
2465 /* Note this size cannot be self-referential. */
2466 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
2467 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2468 prefix_unused
= true;
2471 case Attr_Descriptor_Size
:
2472 gnu_type
= TREE_TYPE (gnu_prefix
);
2473 gcc_assert (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
);
2475 /* Return the padded size of the template in the object record type. */
2476 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
2477 gnu_result
= bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
2478 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2479 prefix_unused
= true;
2482 case Attr_Null_Parameter
:
2483 /* This is just a zero cast to the pointer type for our prefix and
2485 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2487 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
2488 convert (build_pointer_type (gnu_result_type
),
2489 integer_zero_node
));
2492 case Attr_Mechanism_Code
:
2494 Entity_Id gnat_obj
= Entity (gnat_prefix
);
2497 prefix_unused
= true;
2498 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2499 if (Present (Expressions (gnat_node
)))
2501 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
2503 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
2504 i
--, gnat_obj
= Next_Formal (gnat_obj
))
2508 code
= Mechanism (gnat_obj
);
2509 if (code
== Default
)
2510 code
= ((present_gnu_tree (gnat_obj
)
2511 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
2512 || ((TREE_CODE (get_gnu_tree (gnat_obj
))
2514 && (DECL_BY_COMPONENT_PTR_P
2515 (get_gnu_tree (gnat_obj
))))))
2516 ? By_Reference
: By_Copy
);
2517 gnu_result
= convert (gnu_result_type
, size_int (- code
));
2522 /* We treat Model as identical to Machine. This is true for at least
2523 IEEE and some other nice floating-point systems. */
2525 /* ... fall through ... */
2528 /* The trick is to force the compiler to store the result in memory so
2529 that we do not have extra precision used. But do this only when this
2530 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2531 the type is lower than that of the longest floating-point type. */
2532 prefix_unused
= true;
2533 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2534 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2535 gnu_result
= convert (gnu_result_type
, gnu_expr
);
2537 if (TREE_CODE (gnu_result
) != REAL_CST
2538 && fp_arith_may_widen
2539 && TYPE_PRECISION (gnu_result_type
)
2540 < TYPE_PRECISION (longest_float_type_node
))
2542 tree rec_type
= make_node (RECORD_TYPE
);
2544 = create_field_decl (get_identifier ("OBJ"), gnu_result_type
,
2545 rec_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2546 tree rec_val
, asm_expr
;
2548 finish_record_type (rec_type
, field
, 0, false);
2550 rec_val
= build_constructor_single (rec_type
, field
, gnu_result
);
2551 rec_val
= build1 (SAVE_EXPR
, rec_type
, rec_val
);
2554 = build5 (ASM_EXPR
, void_type_node
,
2555 build_string (0, ""),
2556 tree_cons (build_tree_list (NULL_TREE
,
2557 build_string (2, "=m")),
2558 rec_val
, NULL_TREE
),
2559 tree_cons (build_tree_list (NULL_TREE
,
2560 build_string (1, "m")),
2561 rec_val
, NULL_TREE
),
2562 NULL_TREE
, NULL_TREE
);
2563 ASM_VOLATILE_P (asm_expr
) = 1;
2566 = build_compound_expr (gnu_result_type
, asm_expr
,
2567 build_component_ref (rec_val
, field
,
2573 prefix_unused
= true;
2574 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2575 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2576 /* This can be a random address so build an alias-all pointer type. */
2578 = convert (build_pointer_type_for_mode (gnu_result_type
, ptr_mode
,
2581 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_expr
);
2585 /* This abort means that we have an unimplemented attribute. */
2589 /* If this is an attribute where the prefix was unused, force a use of it if
2590 it has a side-effect. But don't do it if the prefix is just an entity
2591 name. However, if an access check is needed, we must do it. See second
2592 example in AARM 11.6(5.e). */
2594 && TREE_SIDE_EFFECTS (gnu_prefix
)
2595 && !Is_Entity_Name (gnat_prefix
))
2597 = build_compound_expr (TREE_TYPE (gnu_result
), gnu_prefix
, gnu_result
);
2599 *gnu_result_type_p
= gnu_result_type
;
2603 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2604 to a GCC tree, which is returned. */
2607 Case_Statement_to_gnu (Node_Id gnat_node
)
2609 tree gnu_result
, gnu_expr
, gnu_type
, gnu_label
;
2611 location_t end_locus
;
2612 bool may_fallthru
= false;
2614 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2615 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2616 gnu_expr
= maybe_character_value (gnu_expr
);
2617 gnu_type
= TREE_TYPE (gnu_expr
);
2619 /* We build a SWITCH_EXPR that contains the code with interspersed
2620 CASE_LABEL_EXPRs for each label. */
2621 if (!Sloc_to_locus (End_Location (gnat_node
), &end_locus
))
2622 end_locus
= input_location
;
2623 gnu_label
= create_artificial_label (end_locus
);
2624 start_stmt_group ();
2626 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2627 Present (gnat_when
);
2628 gnat_when
= Next_Non_Pragma (gnat_when
))
2630 bool choices_added_p
= false;
2631 Node_Id gnat_choice
;
2633 /* First compile all the different case choices for the current WHEN
2635 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2636 Present (gnat_choice
);
2637 gnat_choice
= Next (gnat_choice
))
2639 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2640 tree label
= create_artificial_label (input_location
);
2642 switch (Nkind (gnat_choice
))
2645 gnu_low
= gnat_to_gnu (Low_Bound (gnat_choice
));
2646 gnu_high
= gnat_to_gnu (High_Bound (gnat_choice
));
2649 case N_Subtype_Indication
:
2650 gnu_low
= gnat_to_gnu (Low_Bound (Range_Expression
2651 (Constraint (gnat_choice
))));
2652 gnu_high
= gnat_to_gnu (High_Bound (Range_Expression
2653 (Constraint (gnat_choice
))));
2657 case N_Expanded_Name
:
2658 /* This represents either a subtype range or a static value of
2659 some kind; Ekind says which. */
2660 if (Is_Type (Entity (gnat_choice
)))
2662 tree gnu_type
= get_unpadded_type (Entity (gnat_choice
));
2664 gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2665 gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2669 /* ... fall through ... */
2671 case N_Character_Literal
:
2672 case N_Integer_Literal
:
2673 gnu_low
= gnat_to_gnu (gnat_choice
);
2676 case N_Others_Choice
:
2683 /* Everything should be folded into constants at this point. */
2684 gcc_assert (!gnu_low
|| TREE_CODE (gnu_low
) == INTEGER_CST
);
2685 gcc_assert (!gnu_high
|| TREE_CODE (gnu_high
) == INTEGER_CST
);
2687 if (gnu_low
&& TREE_TYPE (gnu_low
) != gnu_type
)
2688 gnu_low
= convert (gnu_type
, gnu_low
);
2689 if (gnu_high
&& TREE_TYPE (gnu_high
) != gnu_type
)
2690 gnu_high
= convert (gnu_type
, gnu_high
);
2692 add_stmt_with_node (build_case_label (gnu_low
, gnu_high
, label
),
2694 choices_added_p
= true;
2697 /* This construct doesn't define a scope so we shouldn't push a binding
2698 level around the statement list. Except that we have always done so
2699 historically and this makes it possible to reduce stack usage. As a
2700 compromise, we keep doing it for case statements, for which this has
2701 never been problematic, but not for case expressions in Ada 2012. */
2702 if (choices_added_p
)
2704 const bool is_case_expression
2705 = (Nkind (Parent (gnat_node
)) == N_Expression_With_Actions
);
2707 = build_stmt_group (Statements (gnat_when
), !is_case_expression
);
2708 bool group_may_fallthru
= block_may_fallthru (group
);
2710 if (group_may_fallthru
)
2712 tree stmt
= build1 (GOTO_EXPR
, void_type_node
, gnu_label
);
2713 SET_EXPR_LOCATION (stmt
, end_locus
);
2715 may_fallthru
= true;
2720 /* Now emit a definition of the label the cases branch to, if any. */
2722 add_stmt (build1 (LABEL_EXPR
, void_type_node
, gnu_label
));
2723 gnu_result
= build2 (SWITCH_EXPR
, gnu_type
, gnu_expr
, end_stmt_group ());
2728 /* Return true if we are in the body of a loop. */
2731 inside_loop_p (void)
2733 return !vec_safe_is_empty (gnu_loop_stack
);
2736 /* Find out whether EXPR is a simple additive expression based on the iteration
2737 variable of some enclosing loop in the current function. If so, return the
2738 loop and set *DISP to the displacement and *NEG_P to true if this is for a
2739 subtraction; otherwise, return NULL. */
2741 static struct loop_info_d
*
2742 find_loop_for (tree expr
, tree
*disp
, bool *neg_p
)
2746 struct loop_info_d
*iter
= NULL
;
2749 if (is_simple_additive_expression (expr
, &add
, &cst
, &minus_p
))
2766 var
= remove_conversions (var
, false);
2768 if (TREE_CODE (var
) != VAR_DECL
)
2771 gcc_checking_assert (vec_safe_length (gnu_loop_stack
) > 0);
2773 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack
, i
, iter
)
2774 if (iter
->loop_var
== var
&& iter
->fndecl
== current_function_decl
)
2780 /* Return the innermost enclosing loop in the current function. */
2782 static struct loop_info_d
*
2785 struct loop_info_d
*iter
= NULL
;
2788 gcc_checking_assert (vec_safe_length (gnu_loop_stack
) > 0);
2790 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack
, i
, iter
)
2791 if (iter
->fndecl
== current_function_decl
)
2797 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2798 false, or the maximum value if MAX is true, of TYPE. */
2801 can_equal_min_or_max_val_p (tree val
, tree type
, bool max
)
2803 tree min_or_max_val
= (max
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
));
2805 if (TREE_CODE (min_or_max_val
) != INTEGER_CST
)
2808 if (TREE_CODE (val
) == NOP_EXPR
)
2810 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0)))
2811 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0))));
2813 if (TREE_CODE (val
) != INTEGER_CST
)
2817 return tree_int_cst_lt (val
, min_or_max_val
) == 0;
2819 return tree_int_cst_lt (min_or_max_val
, val
) == 0;
2822 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2823 If REVERSE is true, minimum value is taken as maximum value. */
2826 can_equal_min_val_p (tree val
, tree type
, bool reverse
)
2828 return can_equal_min_or_max_val_p (val
, type
, reverse
);
2831 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2832 If REVERSE is true, maximum value is taken as minimum value. */
2835 can_equal_max_val_p (tree val
, tree type
, bool reverse
)
2837 return can_equal_min_or_max_val_p (val
, type
, !reverse
);
2840 /* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
2841 true if both expressions have been replaced and false otherwise. */
2844 make_invariant (tree
*expr1
, tree
*expr2
)
2846 tree inv_expr1
= gnat_invariant_expr (*expr1
);
2847 tree inv_expr2
= gnat_invariant_expr (*expr2
);
2855 return inv_expr1
&& inv_expr2
;
2858 /* Helper function for walk_tree, used by independent_iterations_p below. */
2861 scan_rhs_r (tree
*tp
, int *walk_subtrees
, void *data
)
2863 bitmap
*params
= (bitmap
*)data
;
2866 /* No need to walk into types or decls. */
2867 if (IS_TYPE_OR_DECL_P (t
))
2870 if (TREE_CODE (t
) == PARM_DECL
&& bitmap_bit_p (*params
, DECL_UID (t
)))
2876 /* Return true if STMT_LIST generates independent iterations in a loop. */
2879 independent_iterations_p (tree stmt_list
)
2881 tree_stmt_iterator tsi
;
2882 bitmap params
= BITMAP_GGC_ALLOC();
2883 auto_vec
<tree
, 16> rhs
;
2887 if (TREE_CODE (stmt_list
) == BIND_EXPR
)
2888 stmt_list
= BIND_EXPR_BODY (stmt_list
);
2890 /* Scan the list and return false on anything that is not either a check
2891 or an assignment to a parameter with restricted aliasing. */
2892 for (tsi
= tsi_start (stmt_list
); !tsi_end_p (tsi
); tsi_next (&tsi
))
2894 tree stmt
= tsi_stmt (tsi
);
2896 switch (TREE_CODE (stmt
))
2900 if (COND_EXPR_ELSE (stmt
))
2902 if (TREE_CODE (COND_EXPR_THEN (stmt
)) != CALL_EXPR
)
2904 tree func
= get_callee_fndecl (COND_EXPR_THEN (stmt
));
2905 if (!(func
&& TREE_THIS_VOLATILE (func
)))
2912 tree lhs
= TREE_OPERAND (stmt
, 0);
2913 while (handled_component_p (lhs
))
2914 lhs
= TREE_OPERAND (lhs
, 0);
2915 if (TREE_CODE (lhs
) != INDIRECT_REF
)
2917 lhs
= TREE_OPERAND (lhs
, 0);
2918 if (!(TREE_CODE (lhs
) == PARM_DECL
2919 && DECL_RESTRICTED_ALIASING_P (lhs
)))
2921 bitmap_set_bit (params
, DECL_UID (lhs
));
2922 rhs
.safe_push (TREE_OPERAND (stmt
, 1));
2931 /* At this point we know that the list contains only statements that will
2932 modify parameters with restricted aliasing. Check that the statements
2933 don't at the time read from these parameters. */
2934 FOR_EACH_VEC_ELT (rhs
, i
, iter
)
2935 if (walk_tree_without_duplicates (&iter
, scan_rhs_r
, ¶ms
))
2941 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2942 to a GCC tree, which is returned. */
2945 Loop_Statement_to_gnu (Node_Id gnat_node
)
2947 const Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2948 struct loop_info_d
*gnu_loop_info
= ggc_cleared_alloc
<loop_info_d
> ();
2949 tree gnu_loop_stmt
= build4 (LOOP_STMT
, void_type_node
, NULL_TREE
,
2950 NULL_TREE
, NULL_TREE
, NULL_TREE
);
2951 tree gnu_loop_label
= create_artificial_label (input_location
);
2952 tree gnu_cond_expr
= NULL_TREE
, gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2955 /* Push the loop_info structure associated with the LOOP_STMT. */
2956 gnu_loop_info
->fndecl
= current_function_decl
;
2957 gnu_loop_info
->stmt
= gnu_loop_stmt
;
2958 vec_safe_push (gnu_loop_stack
, gnu_loop_info
);
2960 /* Set location information for statement and end label. */
2961 set_expr_location_from_node (gnu_loop_stmt
, gnat_node
);
2962 Sloc_to_locus (Sloc (End_Label (gnat_node
)),
2963 &DECL_SOURCE_LOCATION (gnu_loop_label
));
2964 LOOP_STMT_LABEL (gnu_loop_stmt
) = gnu_loop_label
;
2966 /* Set the condition under which the loop must keep going. If we have an
2967 explicit condition, use it to set the location information throughout
2968 the translation of the loop statement to avoid having multiple SLOCs.
2970 For the case "LOOP .... END LOOP;" the condition is always true. */
2971 if (No (gnat_iter_scheme
))
2974 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2975 else if (Present (Condition (gnat_iter_scheme
)))
2977 LOOP_STMT_COND (gnu_loop_stmt
)
2978 = gnat_to_gnu (Condition (gnat_iter_scheme
));
2980 set_expr_location_from_node (gnu_loop_stmt
, gnat_iter_scheme
);
2983 /* Otherwise we have an iteration scheme and the condition is given by the
2984 bounds of the subtype of the iteration variable. */
2987 Node_Id gnat_loop_spec
= Loop_Parameter_Specification (gnat_iter_scheme
);
2988 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2989 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2990 tree gnu_type
= get_unpadded_type (gnat_type
);
2991 tree gnu_base_type
= maybe_character_type (get_base_type (gnu_type
));
2992 tree gnu_one_node
= build_int_cst (gnu_base_type
, 1);
2993 tree gnu_loop_var
, gnu_loop_iv
, gnu_first
, gnu_last
, gnu_stmt
;
2994 enum tree_code update_code
, test_code
, shift_code
;
2995 bool reverse
= Reverse_Present (gnat_loop_spec
), use_iv
= false;
2997 gnu_low
= convert (gnu_base_type
, TYPE_MIN_VALUE (gnu_type
));
2998 gnu_high
= convert (gnu_base_type
, TYPE_MAX_VALUE (gnu_type
));
3000 /* We must disable modulo reduction for the iteration variable, if any,
3001 in order for the loop comparison to be effective. */
3004 gnu_first
= gnu_high
;
3006 update_code
= MINUS_NOMOD_EXPR
;
3007 test_code
= GE_EXPR
;
3008 shift_code
= PLUS_NOMOD_EXPR
;
3012 gnu_first
= gnu_low
;
3013 gnu_last
= gnu_high
;
3014 update_code
= PLUS_NOMOD_EXPR
;
3015 test_code
= LE_EXPR
;
3016 shift_code
= MINUS_NOMOD_EXPR
;
3019 /* We use two different strategies to translate the loop, depending on
3020 whether optimization is enabled.
3022 If it is, we generate the canonical loop form expected by the loop
3023 optimizer and the loop vectorizer, which is the do-while form:
3032 This avoids an implicit dependency on loop header copying and makes
3033 it possible to turn BOTTOM_COND into an inequality test.
3035 If optimization is disabled, loop header copying doesn't come into
3036 play and we try to generate the loop form with the fewer conditional
3037 branches. First, the default form, which is:
3045 It should catch most loops with constant ending point. Then, if we
3046 cannot, we try to generate the shifted form:
3054 which should catch loops with constant starting point. Otherwise, if
3055 we cannot, we generate the fallback form:
3064 which works in all cases. */
3066 if (optimize
&& !optimize_debug
)
3068 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
3070 if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
))
3073 /* Otherwise, use the do-while form with the help of a special
3074 induction variable in the unsigned version of the base type
3075 or the unsigned version of the size type, whichever is the
3076 largest, in order to have wrap-around arithmetics for it. */
3079 if (TYPE_PRECISION (gnu_base_type
)
3080 > TYPE_PRECISION (size_type_node
))
3082 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type
), 1);
3084 gnu_base_type
= size_type_node
;
3086 gnu_first
= convert (gnu_base_type
, gnu_first
);
3087 gnu_last
= convert (gnu_base_type
, gnu_last
);
3088 gnu_one_node
= build_int_cst (gnu_base_type
, 1);
3093 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
3095 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
3096 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
3100 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
3101 if (!can_equal_max_val_p (gnu_last
, gnu_base_type
, reverse
))
3104 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
3106 else if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
)
3107 && !can_equal_min_val_p (gnu_last
, gnu_base_type
, reverse
))
3110 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
3113 = build_binary_op (shift_code
, gnu_base_type
, gnu_last
,
3115 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
3118 /* Otherwise, use the fallback form. */
3120 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
3123 /* If we use the BOTTOM_COND, we can turn the test into an inequality
3124 test but we have to add ENTRY_COND to protect the empty loop. */
3125 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
))
3127 test_code
= NE_EXPR
;
3129 = build3 (COND_EXPR
, void_type_node
,
3130 build_binary_op (LE_EXPR
, boolean_type_node
,
3132 NULL_TREE
, alloc_stmt_list ());
3133 set_expr_location_from_node (gnu_cond_expr
, gnat_iter_scheme
);
3136 /* Open a new nesting level that will surround the loop to declare the
3137 iteration variable. */
3138 start_stmt_group ();
3141 /* If we use the special induction variable, create it and set it to
3142 its initial value. Morever, the regular iteration variable cannot
3143 itself be initialized, lest the initial value wrapped around. */
3147 = create_init_temporary ("I", gnu_first
, &gnu_stmt
, gnat_loop_var
);
3148 add_stmt (gnu_stmt
);
3149 gnu_first
= NULL_TREE
;
3152 gnu_loop_iv
= NULL_TREE
;
3154 /* Declare the iteration variable and set it to its initial value. */
3155 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, true);
3156 if (DECL_BY_REF_P (gnu_loop_var
))
3157 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_loop_var
);
3160 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var
));
3161 SET_DECL_INDUCTION_VAR (gnu_loop_var
, gnu_loop_iv
);
3163 gnu_loop_info
->loop_var
= gnu_loop_var
;
3164 gnu_loop_info
->low_bound
= gnu_low
;
3165 gnu_loop_info
->high_bound
= gnu_high
;
3167 /* Do all the arithmetics in the base type. */
3168 gnu_loop_var
= convert (gnu_base_type
, gnu_loop_var
);
3170 /* Set either the top or bottom exit condition. */
3172 LOOP_STMT_COND (gnu_loop_stmt
)
3173 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_iv
,
3176 LOOP_STMT_COND (gnu_loop_stmt
)
3177 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_var
,
3180 /* Set either the top or bottom update statement and give it the source
3181 location of the iteration for better coverage info. */
3185 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_iv
,
3186 build_binary_op (update_code
, gnu_base_type
,
3187 gnu_loop_iv
, gnu_one_node
));
3188 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3189 append_to_statement_list (gnu_stmt
,
3190 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
3192 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
3194 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3195 append_to_statement_list (gnu_stmt
,
3196 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
3201 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
3202 build_binary_op (update_code
, gnu_base_type
,
3203 gnu_loop_var
, gnu_one_node
));
3204 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3205 LOOP_STMT_UPDATE (gnu_loop_stmt
) = gnu_stmt
;
3208 set_expr_location_from_node (gnu_loop_stmt
, gnat_iter_scheme
);
3211 /* If the loop was named, have the name point to this loop. In this case,
3212 the association is not a DECL node, but the end label of the loop. */
3213 if (Present (Identifier (gnat_node
)))
3214 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_label
, true);
3216 /* Make the loop body into its own block, so any allocated storage will be
3217 released every iteration. This is needed for stack allocation. */
3218 LOOP_STMT_BODY (gnu_loop_stmt
)
3219 = build_stmt_group (Statements (gnat_node
), true);
3220 TREE_SIDE_EFFECTS (gnu_loop_stmt
) = 1;
3222 /* If we have an iteration scheme, then we are in a statement group. Add
3223 the LOOP_STMT to it, finish it and make it the "loop". */
3224 if (Present (gnat_iter_scheme
) && No (Condition (gnat_iter_scheme
)))
3226 /* First, if we have computed invariant conditions for range (or index)
3227 checks applied to the iteration variable, find out whether they can
3228 be evaluated to false at compile time; otherwise, if there are not
3229 too many of them, combine them with the original checks. If loop
3230 unswitching is enabled, do not require the loop bounds to be also
3231 invariant, as their evaluation will still be ahead of the loop. */
3232 if (vec_safe_length (gnu_loop_info
->checks
) > 0
3233 && (make_invariant (&gnu_low
, &gnu_high
) || optimize
>= 3))
3235 struct range_check_info_d
*rci
;
3236 unsigned int i
, n_remaining_checks
= 0;
3238 FOR_EACH_VEC_ELT (*gnu_loop_info
->checks
, i
, rci
)
3240 tree low_ok
, high_ok
;
3244 tree gnu_adjusted_low
= convert (rci
->type
, gnu_low
);
3247 = fold_build2 (rci
->neg_p
? MINUS_EXPR
: PLUS_EXPR
,
3248 rci
->type
, gnu_adjusted_low
, rci
->disp
);
3250 = build_binary_op (GE_EXPR
, boolean_type_node
,
3251 gnu_adjusted_low
, rci
->low_bound
);
3254 low_ok
= boolean_true_node
;
3256 if (rci
->high_bound
)
3258 tree gnu_adjusted_high
= convert (rci
->type
, gnu_high
);
3261 = fold_build2 (rci
->neg_p
? MINUS_EXPR
: PLUS_EXPR
,
3262 rci
->type
, gnu_adjusted_high
, rci
->disp
);
3264 = build_binary_op (LE_EXPR
, boolean_type_node
,
3265 gnu_adjusted_high
, rci
->high_bound
);
3268 high_ok
= boolean_true_node
;
3271 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
3275 = build_unary_op (TRUTH_NOT_EXPR
, boolean_type_node
, range_ok
);
3277 if (rci
->invariant_cond
== boolean_false_node
)
3278 TREE_OPERAND (rci
->inserted_cond
, 0) = rci
->invariant_cond
;
3280 n_remaining_checks
++;
3283 /* Note that loop unswitching can only be applied a small number of
3284 times to a given loop (PARAM_MAX_UNSWITCH_LEVEL default to 3). */
3285 if (IN_RANGE (n_remaining_checks
, 1, 3)
3288 FOR_EACH_VEC_ELT (*gnu_loop_info
->checks
, i
, rci
)
3289 if (rci
->invariant_cond
!= boolean_false_node
)
3291 TREE_OPERAND (rci
->inserted_cond
, 0) = rci
->invariant_cond
;
3294 add_stmt_with_node_force (rci
->inserted_cond
, gnat_node
);
3298 /* Second, if we have recorded invariants to be hoisted, emit them. */
3299 if (vec_safe_length (gnu_loop_info
->invariants
) > 0)
3303 FOR_EACH_VEC_ELT (*gnu_loop_info
->invariants
, i
, iter
)
3304 add_stmt_with_node_force (*iter
, gnat_node
);
3307 /* Third, if loop vectorization is enabled and the iterations of the
3308 loop can easily be proved as independent, mark the loop. */
3310 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt
)))
3311 LOOP_STMT_IVDEP (gnu_loop_stmt
) = 1;
3313 add_stmt (gnu_loop_stmt
);
3315 gnu_loop_stmt
= end_stmt_group ();
3318 /* If we have an outer COND_EXPR, that's our result and this loop is its
3319 "true" statement. Otherwise, the result is the LOOP_STMT. */
3322 COND_EXPR_THEN (gnu_cond_expr
) = gnu_loop_stmt
;
3323 TREE_SIDE_EFFECTS (gnu_cond_expr
) = 1;
3324 gnu_result
= gnu_cond_expr
;
3327 gnu_result
= gnu_loop_stmt
;
3329 gnu_loop_stack
->pop ();
3334 /* This page implements a form of Named Return Value optimization modeled
3335 on the C++ optimization of the same name. The main difference is that
3336 we disregard any semantical considerations when applying it here, the
3337 counterpart being that we don't try to apply it to semantically loaded
3338 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3340 We consider a function body of the following GENERIC form:
3344 RETURN_EXPR [<retval> = ...]
3346 RETURN_EXPR [<retval> = R1]
3350 RETURN_EXPR [<retval> = ...]
3352 RETURN_EXPR [<retval> = Ri]
3355 where the Ri are not addressable and we try to fulfill a simple criterion
3356 that would make it possible to replace one or several Ri variables by the
3357 single RESULT_DECL of the function.
3359 The first observation is that RETURN_EXPRs that don't directly reference
3360 any of the Ri variables on the RHS of their assignment are transparent wrt
3361 the optimization. This is because the Ri variables aren't addressable so
3362 any transformation applied to them doesn't affect the RHS; moreover, the
3363 assignment writes the full <retval> object so existing values are entirely
3366 This property can be extended to some forms of RETURN_EXPRs that reference
3367 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3368 case, in particular when function calls are involved.
3370 Therefore the algorithm is as follows:
3372 1. Collect the list of candidates for a Named Return Value (Ri variables
3373 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3374 other expressions on the RHS of such assignments.
3376 2. Prune the members of the first list (candidates) that are referenced
3377 by a member of the second list (expressions).
3379 3. Extract a set of candidates with non-overlapping live ranges from the
3380 first list. These are the Named Return Values.
3382 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3383 Named Return Values in the function with the RESULT_DECL.
3385 If the function returns an unconstrained type, things are a bit different
3386 because the anonymous return object is allocated on the secondary stack
3387 and RESULT_DECL is only a pointer to it. Each return object can be of a
3388 different size and is allocated separately so we need not care about the
3389 addressability and the aforementioned overlapping issues. Therefore, we
3390 don't collect the other expressions and skip step #2 in the algorithm. */
3397 hash_set
<tree
> *visited
;
3400 /* Return true if T is a Named Return Value. */
3403 is_nrv_p (bitmap nrv
, tree t
)
3405 return TREE_CODE (t
) == VAR_DECL
&& bitmap_bit_p (nrv
, DECL_UID (t
));
3408 /* Helper function for walk_tree, used by finalize_nrv below. */
3411 prune_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
3413 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3416 /* No need to walk into types or decls. */
3417 if (IS_TYPE_OR_DECL_P (t
))
3420 if (is_nrv_p (dp
->nrv
, t
))
3421 bitmap_clear_bit (dp
->nrv
, DECL_UID (t
));
3426 /* Prune Named Return Values in BLOCK and return true if there is still a
3427 Named Return Value in BLOCK or one of its sub-blocks. */
3430 prune_nrv_in_block (bitmap nrv
, tree block
)
3432 bool has_nrv
= false;
3435 /* First recurse on the sub-blocks. */
3436 for (t
= BLOCK_SUBBLOCKS (block
); t
; t
= BLOCK_CHAIN (t
))
3437 has_nrv
|= prune_nrv_in_block (nrv
, t
);
3439 /* Then make sure to keep at most one NRV per block. */
3440 for (t
= BLOCK_VARS (block
); t
; t
= DECL_CHAIN (t
))
3441 if (is_nrv_p (nrv
, t
))
3444 bitmap_clear_bit (nrv
, DECL_UID (t
));
3452 /* Helper function for walk_tree, used by finalize_nrv below. */
3455 finalize_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
3457 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3460 /* No need to walk into types. */
3464 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3465 nop, but differs from using NULL_TREE in that it indicates that we care
3466 about the value of the RESULT_DECL. */
3467 else if (TREE_CODE (t
) == RETURN_EXPR
3468 && TREE_CODE (TREE_OPERAND (t
, 0)) == INIT_EXPR
)
3470 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1);
3472 /* Strip useless conversions around the return value. */
3473 if (gnat_useless_type_conversion (ret_val
))
3474 ret_val
= TREE_OPERAND (ret_val
, 0);
3476 if (is_nrv_p (dp
->nrv
, ret_val
))
3477 TREE_OPERAND (t
, 0) = dp
->result
;
3480 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3482 else if (TREE_CODE (t
) == DECL_EXPR
3483 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
3485 tree var
= DECL_EXPR_DECL (t
), init
;
3487 if (DECL_INITIAL (var
))
3489 init
= build_binary_op (INIT_EXPR
, NULL_TREE
, dp
->result
,
3490 DECL_INITIAL (var
));
3491 SET_EXPR_LOCATION (init
, EXPR_LOCATION (t
));
3492 DECL_INITIAL (var
) = NULL_TREE
;
3495 init
= build_empty_stmt (EXPR_LOCATION (t
));
3498 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3499 SET_DECL_VALUE_EXPR (var
, dp
->result
);
3500 DECL_HAS_VALUE_EXPR_P (var
) = 1;
3501 /* ??? Kludge to avoid an assertion failure during inlining. */
3502 DECL_SIZE (var
) = bitsize_unit_node
;
3503 DECL_SIZE_UNIT (var
) = size_one_node
;
3506 /* And replace all uses of NRVs with the RESULT_DECL. */
3507 else if (is_nrv_p (dp
->nrv
, t
))
3508 *tp
= convert (TREE_TYPE (t
), dp
->result
);
3510 /* Avoid walking into the same tree more than once. Unfortunately, we
3511 can't just use walk_tree_without_duplicates because it would only
3512 call us for the first occurrence of NRVs in the function body. */
3513 if (dp
->visited
->add (*tp
))
3519 /* Likewise, but used when the function returns an unconstrained type. */
3522 finalize_nrv_unc_r (tree
*tp
, int *walk_subtrees
, void *data
)
3524 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3527 /* No need to walk into types. */
3531 /* We need to see the DECL_EXPR of NRVs before any other references so we
3532 walk the body of BIND_EXPR before walking its variables. */
3533 else if (TREE_CODE (t
) == BIND_EXPR
)
3534 walk_tree (&BIND_EXPR_BODY (t
), finalize_nrv_unc_r
, data
, NULL
);
3536 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3537 return value built by the allocator instead of the whole construct. */
3538 else if (TREE_CODE (t
) == RETURN_EXPR
3539 && TREE_CODE (TREE_OPERAND (t
, 0)) == INIT_EXPR
)
3541 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1);
3543 /* This is the construct returned by the allocator. */
3544 if (TREE_CODE (ret_val
) == COMPOUND_EXPR
3545 && TREE_CODE (TREE_OPERAND (ret_val
, 0)) == INIT_EXPR
)
3547 tree rhs
= TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 1);
3549 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val
)))
3550 ret_val
= CONSTRUCTOR_ELT (rhs
, 1)->value
;
3555 /* Strip useless conversions around the return value. */
3556 if (gnat_useless_type_conversion (ret_val
)
3557 || TREE_CODE (ret_val
) == VIEW_CONVERT_EXPR
)
3558 ret_val
= TREE_OPERAND (ret_val
, 0);
3560 /* Strip unpadding around the return value. */
3561 if (TREE_CODE (ret_val
) == COMPONENT_REF
3562 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
3563 ret_val
= TREE_OPERAND (ret_val
, 0);
3565 /* Assign the new return value to the RESULT_DECL. */
3566 if (is_nrv_p (dp
->nrv
, ret_val
))
3567 TREE_OPERAND (TREE_OPERAND (t
, 0), 1)
3568 = TREE_OPERAND (DECL_INITIAL (ret_val
), 0);
3571 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3572 into a new variable. */
3573 else if (TREE_CODE (t
) == DECL_EXPR
3574 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
3576 tree saved_current_function_decl
= current_function_decl
;
3577 tree var
= DECL_EXPR_DECL (t
);
3578 tree alloc
, p_array
, new_var
, new_ret
;
3579 vec
<constructor_elt
, va_gc
> *v
;
3582 /* Create an artificial context to build the allocation. */
3583 current_function_decl
= decl_function_context (var
);
3584 start_stmt_group ();
3587 /* This will return a COMPOUND_EXPR with the allocation in the first
3588 arm and the final return value in the second arm. */
3589 alloc
= build_allocator (TREE_TYPE (var
), DECL_INITIAL (var
),
3590 TREE_TYPE (dp
->result
),
3591 Procedure_To_Call (dp
->gnat_ret
),
3592 Storage_Pool (dp
->gnat_ret
),
3595 /* The new variable is built as a reference to the allocated space. */
3597 = build_decl (DECL_SOURCE_LOCATION (var
), VAR_DECL
, DECL_NAME (var
),
3598 build_reference_type (TREE_TYPE (var
)));
3599 DECL_BY_REFERENCE (new_var
) = 1;
3601 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc
)))
3603 tree cst
= TREE_OPERAND (alloc
, 1);
3605 /* The new initial value is a COMPOUND_EXPR with the allocation in
3606 the first arm and the value of P_ARRAY in the second arm. */
3607 DECL_INITIAL (new_var
)
3608 = build2 (COMPOUND_EXPR
, TREE_TYPE (new_var
),
3609 TREE_OPERAND (alloc
, 0),
3610 CONSTRUCTOR_ELT (cst
, 0)->value
);
3612 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3613 p_array
= TYPE_FIELDS (TREE_TYPE (alloc
));
3614 CONSTRUCTOR_APPEND_ELT (v
, p_array
,
3615 fold_convert (TREE_TYPE (p_array
), new_var
));
3616 CONSTRUCTOR_APPEND_ELT (v
, DECL_CHAIN (p_array
),
3617 CONSTRUCTOR_ELT (cst
, 1)->value
);
3618 new_ret
= build_constructor (TREE_TYPE (alloc
), v
);
3622 /* The new initial value is just the allocation. */
3623 DECL_INITIAL (new_var
) = alloc
;
3624 new_ret
= fold_convert (TREE_TYPE (alloc
), new_var
);
3627 gnat_pushdecl (new_var
, Empty
);
3629 /* Destroy the artificial context and insert the new statements. */
3631 *tp
= end_stmt_group ();
3632 current_function_decl
= saved_current_function_decl
;
3634 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3635 DECL_CHAIN (new_var
) = DECL_CHAIN (var
);
3636 DECL_CHAIN (var
) = new_var
;
3637 DECL_IGNORED_P (var
) = 1;
3639 /* Save the new return value and the dereference of NEW_VAR. */
3641 = build2 (COMPOUND_EXPR
, TREE_TYPE (var
), new_ret
,
3642 build1 (INDIRECT_REF
, TREE_TYPE (var
), new_var
));
3643 /* ??? Kludge to avoid messing up during inlining. */
3644 DECL_CONTEXT (var
) = NULL_TREE
;
3647 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3648 else if (is_nrv_p (dp
->nrv
, t
))
3649 *tp
= TREE_OPERAND (DECL_INITIAL (t
), 1);
3651 /* Avoid walking into the same tree more than once. Unfortunately, we
3652 can't just use walk_tree_without_duplicates because it would only
3653 call us for the first occurrence of NRVs in the function body. */
3654 if (dp
->visited
->add (*tp
))
3660 /* Apply FUNC to all the sub-trees of nested functions in NODE. FUNC is called
3661 with the DATA and the address of each sub-tree. If FUNC returns a non-NULL
3662 value, the traversal is stopped. */
3665 walk_nesting_tree (struct cgraph_node
*node
, walk_tree_fn func
, void *data
)
3667 for (node
= first_nested_function (node
);
3668 node
; node
= next_nested_function (node
))
3670 walk_tree_without_duplicates (&DECL_SAVED_TREE (node
->decl
), func
, data
);
3671 walk_nesting_tree (node
, func
, data
);
3675 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3676 contains the candidates for Named Return Value and OTHER is a list of
3677 the other return values. GNAT_RET is a representative return node. */
3680 finalize_nrv (tree fndecl
, bitmap nrv
, vec
<tree
, va_gc
> *other
, Node_Id gnat_ret
)
3682 struct nrv_data data
;
3687 /* We shouldn't be applying the optimization to return types that we aren't
3688 allowed to manipulate freely. */
3689 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl
))));
3691 /* Prune the candidates that are referenced by other return values. */
3693 data
.result
= NULL_TREE
;
3694 data
.gnat_ret
= Empty
;
3695 data
.visited
= NULL
;
3696 FOR_EACH_VEC_SAFE_ELT (other
, i
, iter
)
3697 walk_tree_without_duplicates (&iter
, prune_nrv_r
, &data
);
3698 if (bitmap_empty_p (nrv
))
3701 /* Prune also the candidates that are referenced by nested functions. */
3702 walk_nesting_tree (cgraph_node::get_create (fndecl
), prune_nrv_r
, &data
);
3703 if (bitmap_empty_p (nrv
))
3706 /* Extract a set of NRVs with non-overlapping live ranges. */
3707 if (!prune_nrv_in_block (nrv
, DECL_INITIAL (fndecl
)))
3710 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3712 data
.result
= DECL_RESULT (fndecl
);
3713 data
.gnat_ret
= gnat_ret
;
3714 data
.visited
= new hash_set
<tree
>;
3715 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl
)))
3716 func
= finalize_nrv_unc_r
;
3718 func
= finalize_nrv_r
;
3719 walk_tree (&DECL_SAVED_TREE (fndecl
), func
, &data
, NULL
);
3720 delete data
.visited
;
3723 /* Return true if RET_VAL can be used as a Named Return Value for the
3724 anonymous return object RET_OBJ. */
3727 return_value_ok_for_nrv_p (tree ret_obj
, tree ret_val
)
3729 if (TREE_CODE (ret_val
) != VAR_DECL
)
3732 if (TREE_THIS_VOLATILE (ret_val
))
3735 if (DECL_CONTEXT (ret_val
) != current_function_decl
)
3738 if (TREE_STATIC (ret_val
))
3741 /* For the constrained case, test for addressability. */
3742 if (ret_obj
&& TREE_ADDRESSABLE (ret_val
))
3745 /* For the constrained case, test for overalignment. */
3746 if (ret_obj
&& DECL_ALIGN (ret_val
) > DECL_ALIGN (ret_obj
))
3749 /* For the unconstrained case, test for bogus initialization. */
3751 && DECL_INITIAL (ret_val
)
3752 && TREE_CODE (DECL_INITIAL (ret_val
)) == NULL_EXPR
)
3758 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3759 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3760 around RESULT_OBJ, which may be null in this case. */
3763 build_return_expr (tree ret_obj
, tree ret_val
)
3769 /* The gimplifier explicitly enforces the following invariant:
3778 As a consequence, type consistency dictates that we use the type
3779 of the RET_OBJ as the operation type. */
3780 tree operation_type
= TREE_TYPE (ret_obj
);
3782 /* Convert the right operand to the operation type. Note that this is
3783 the transformation applied in the INIT_EXPR case of build_binary_op,
3784 with the assumption that the type cannot involve a placeholder. */
3785 if (operation_type
!= TREE_TYPE (ret_val
))
3786 ret_val
= convert (operation_type
, ret_val
);
3788 /* We always can use an INIT_EXPR for the return object. */
3789 result_expr
= build2 (INIT_EXPR
, void_type_node
, ret_obj
, ret_val
);
3791 /* If the function returns an aggregate type, find out whether this is
3792 a candidate for Named Return Value. If so, record it. Otherwise,
3793 if this is an expression of some kind, record it elsewhere. */
3796 && AGGREGATE_TYPE_P (operation_type
)
3797 && !TYPE_IS_FAT_POINTER_P (operation_type
)
3798 && TYPE_MODE (operation_type
) == BLKmode
3799 && aggregate_value_p (operation_type
, current_function_decl
))
3801 /* Strip useless conversions around the return value. */
3802 if (gnat_useless_type_conversion (ret_val
))
3803 ret_val
= TREE_OPERAND (ret_val
, 0);
3805 /* Now apply the test to the return value. */
3806 if (return_value_ok_for_nrv_p (ret_obj
, ret_val
))
3808 if (!f_named_ret_val
)
3809 f_named_ret_val
= BITMAP_GGC_ALLOC ();
3810 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
3813 /* Note that we need not care about CONSTRUCTORs here, as they are
3814 totally transparent given the read-compose-write semantics of
3815 assignments from CONSTRUCTORs. */
3816 else if (EXPR_P (ret_val
))
3817 vec_safe_push (f_other_ret_val
, ret_val
);
3821 result_expr
= ret_obj
;
3823 return build1 (RETURN_EXPR
, void_type_node
, result_expr
);
3826 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3827 don't return anything. */
3830 Subprogram_Body_to_gnu (Node_Id gnat_node
)
3832 /* Defining identifier of a parameter to the subprogram. */
3833 Entity_Id gnat_param
;
3834 /* The defining identifier for the subprogram body. Note that if a
3835 specification has appeared before for this body, then the identifier
3836 occurring in that specification will also be a defining identifier and all
3837 the calls to this subprogram will point to that specification. */
3838 Entity_Id gnat_subprog_id
3839 = (Present (Corresponding_Spec (gnat_node
))
3840 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
3841 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3842 tree gnu_subprog_decl
;
3843 /* Its RESULT_DECL node. */
3844 tree gnu_result_decl
;
3845 /* Its FUNCTION_TYPE node. */
3846 tree gnu_subprog_type
;
3847 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3849 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3850 tree gnu_return_var_elmt
= NULL_TREE
;
3853 struct language_function
*gnu_subprog_language
;
3854 vec
<parm_attr
, va_gc
> *cache
;
3856 /* If this is a generic object or if it has been eliminated,
3858 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
3859 || Ekind (gnat_subprog_id
) == E_Generic_Function
3860 || Is_Eliminated (gnat_subprog_id
))
3863 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3864 the already-elaborated tree node. However, if this subprogram had its
3865 elaboration deferred, we will already have made a tree node for it. So
3866 treat it as not being defined in that case. Such a subprogram cannot
3867 have an address clause or a freeze node, so this test is safe, though it
3868 does disable some otherwise-useful error checking. */
3870 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
3871 Acts_As_Spec (gnat_node
)
3872 && !present_gnu_tree (gnat_subprog_id
));
3873 DECL_FUNCTION_IS_DEF (gnu_subprog_decl
) = true;
3874 gnu_result_decl
= DECL_RESULT (gnu_subprog_decl
);
3875 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
3876 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3877 if (gnu_cico_list
&& TREE_VALUE (gnu_cico_list
) == void_type_node
)
3878 gnu_return_var_elmt
= gnu_cico_list
;
3880 /* If the function returns by invisible reference, make it explicit in the
3881 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
3882 if (TREE_ADDRESSABLE (gnu_subprog_type
))
3884 TREE_TYPE (gnu_result_decl
)
3885 = build_reference_type (TREE_TYPE (gnu_result_decl
));
3886 relayout_decl (gnu_result_decl
);
3889 /* Set the line number in the decl to correspond to that of the body. */
3890 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
, false, gnu_subprog_decl
))
3891 locus
= input_location
;
3892 DECL_SOURCE_LOCATION (gnu_subprog_decl
) = locus
;
3894 /* If the body comes from an expression function, arrange it to be inlined
3895 in almost all cases. */
3896 if (Was_Expression_Function (gnat_node
))
3897 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog_decl
) = 1;
3899 /* Try to create a bona-fide thunk and hand it over to the middle-end. */
3900 if (Is_Thunk (gnat_subprog_id
)
3901 && maybe_make_gnu_thunk (gnat_subprog_id
, gnu_subprog_decl
))
3904 /* Initialize the information structure for the function. */
3905 allocate_struct_function (gnu_subprog_decl
, false);
3906 gnu_subprog_language
= ggc_cleared_alloc
<language_function
> ();
3907 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->language
= gnu_subprog_language
;
3908 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->function_start_locus
= locus
;
3911 begin_subprog_body (gnu_subprog_decl
);
3913 /* If there are copy-in/copy-out parameters, we need to ensure that they are
3914 properly copied out by the return statement. We do this by making a new
3915 block and converting any return into a goto to a label at the end of the
3919 tree gnu_return_var
= NULL_TREE
;
3921 vec_safe_push (gnu_return_label_stack
,
3922 create_artificial_label (input_location
));
3924 start_stmt_group ();
3927 /* If this is a function with copy-in/copy-out parameters and which does
3928 not return by invisible reference, we also need a variable for the
3929 return value to be placed. */
3930 if (gnu_return_var_elmt
&& !TREE_ADDRESSABLE (gnu_subprog_type
))
3932 tree gnu_return_type
3933 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt
));
3936 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE
,
3937 gnu_return_type
, NULL_TREE
,
3938 false, false, false, false, false,
3939 true, false, NULL
, gnat_subprog_id
);
3940 TREE_VALUE (gnu_return_var_elmt
) = gnu_return_var
;
3943 vec_safe_push (gnu_return_var_stack
, gnu_return_var
);
3945 /* See whether there are parameters for which we don't have a GCC tree
3946 yet. These must be Out parameters. Make a VAR_DECL for them and
3947 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3948 We can match up the entries because TYPE_CI_CO_LIST is in the order
3949 of the parameters. */
3950 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
3951 Present (gnat_param
);
3952 gnat_param
= Next_Formal_With_Extras (gnat_param
))
3953 if (!present_gnu_tree (gnat_param
))
3955 tree gnu_cico_entry
= gnu_cico_list
;
3958 /* Skip any entries that have been already filled in; they must
3959 correspond to In Out parameters. */
3960 while (gnu_cico_entry
&& TREE_VALUE (gnu_cico_entry
))
3961 gnu_cico_entry
= TREE_CHAIN (gnu_cico_entry
);
3963 /* Do any needed dereferences for by-ref objects. */
3964 gnu_decl
= gnat_to_gnu_entity (gnat_param
, NULL_TREE
, true);
3965 gcc_assert (DECL_P (gnu_decl
));
3966 if (DECL_BY_REF_P (gnu_decl
))
3967 gnu_decl
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_decl
);
3969 /* Do any needed references for padded types. */
3970 TREE_VALUE (gnu_cico_entry
)
3971 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry
)), gnu_decl
);
3975 vec_safe_push (gnu_return_label_stack
, NULL_TREE
);
3977 /* Get a tree corresponding to the code for the subprogram. */
3978 start_stmt_group ();
3981 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
3983 /* Generate the code of the subprogram itself. A return statement will be
3984 present and any Out parameters will be handled there. */
3985 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
3987 gnu_result
= end_stmt_group ();
3989 /* Attempt setting the end_locus of our GCC body tree, typically a BIND_EXPR,
3990 then the end_locus of our GCC subprogram declaration tree. */
3991 set_end_locus_from_node (gnu_result
, gnat_node
);
3992 set_end_locus_from_node (gnu_subprog_decl
, gnat_node
);
3994 /* If we populated the parameter attributes cache, we need to make sure that
3995 the cached expressions are evaluated on all the possible paths leading to
3996 their uses. So we force their evaluation on entry of the function. */
3997 cache
= gnu_subprog_language
->parm_attr_cache
;
4000 struct parm_attr_d
*pa
;
4003 start_stmt_group ();
4005 FOR_EACH_VEC_ELT (*cache
, i
, pa
)
4008 add_stmt_with_node_force (pa
->first
, gnat_node
);
4010 add_stmt_with_node_force (pa
->last
, gnat_node
);
4012 add_stmt_with_node_force (pa
->length
, gnat_node
);
4015 add_stmt (gnu_result
);
4016 gnu_result
= end_stmt_group ();
4018 gnu_subprog_language
->parm_attr_cache
= NULL
;
4021 /* If we are dealing with a return from an Ada procedure with parameters
4022 passed by copy-in/copy-out, we need to return a record containing the
4023 final values of these parameters. If the list contains only one entry,
4024 return just that entry though.
4026 For a full description of the copy-in/copy-out parameter mechanism, see
4027 the part of the gnat_to_gnu_entity routine dealing with the translation
4030 We need to make a block that contains the definition of that label and
4031 the copying of the return value. It first contains the function, then
4032 the label and copy statement. */
4035 const Node_Id gnat_end_label
4036 = End_Label (Handled_Statement_Sequence (gnat_node
));
4038 gnu_return_var_stack
->pop ();
4040 add_stmt (gnu_result
);
4041 add_stmt (build1 (LABEL_EXPR
, void_type_node
,
4042 gnu_return_label_stack
->last ()));
4044 /* If this is a function which returns by invisible reference, the
4045 return value has already been dealt with at the return statements,
4046 so we only need to indirectly copy out the parameters. */
4047 if (TREE_ADDRESSABLE (gnu_subprog_type
))
4050 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result_decl
);
4053 gcc_assert (TREE_VALUE (gnu_cico_list
) == void_type_node
);
4055 for (t
= TREE_CHAIN (gnu_cico_list
); t
; t
= TREE_CHAIN (t
))
4057 tree gnu_field_deref
4058 = build_component_ref (gnu_ret_deref
, TREE_PURPOSE (t
), true);
4059 gnu_result
= build2 (MODIFY_EXPR
, void_type_node
,
4060 gnu_field_deref
, TREE_VALUE (t
));
4061 add_stmt_with_node (gnu_result
, gnat_end_label
);
4065 /* Otherwise, if this is a procedure or a function which does not return
4066 by invisible reference, we can do a direct block-copy out. */
4071 if (list_length (gnu_cico_list
) == 1)
4072 gnu_retval
= TREE_VALUE (gnu_cico_list
);
4075 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type
),
4078 gnu_result
= build_return_expr (gnu_result_decl
, gnu_retval
);
4079 add_stmt_with_node (gnu_result
, gnat_end_label
);
4083 gnu_result
= end_stmt_group ();
4086 gnu_return_label_stack
->pop ();
4088 /* On SEH targets, install an exception handler around the main entry
4089 point to catch unhandled exceptions. */
4090 if (DECL_NAME (gnu_subprog_decl
) == main_identifier_node
4091 && targetm_common
.except_unwind_info (&global_options
) == UI_SEH
)
4096 t
= build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
4097 1, integer_zero_node
);
4098 t
= build_call_n_expr (unhandled_except_decl
, 1, t
);
4100 etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, unhandled_others_decl
);
4101 etype
= tree_cons (NULL_TREE
, etype
, NULL_TREE
);
4103 t
= build2 (CATCH_EXPR
, void_type_node
, etype
, t
);
4104 gnu_result
= build2 (TRY_CATCH_EXPR
, TREE_TYPE (gnu_result
),
4108 end_subprog_body (gnu_result
);
4110 /* Finally annotate the parameters and disconnect the trees for parameters
4111 that we have turned into variables since they are now unusable. */
4112 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
4113 Present (gnat_param
);
4114 gnat_param
= Next_Formal_With_Extras (gnat_param
))
4116 tree gnu_param
= get_gnu_tree (gnat_param
);
4117 bool is_var_decl
= (TREE_CODE (gnu_param
) == VAR_DECL
);
4119 annotate_object (gnat_param
, TREE_TYPE (gnu_param
), NULL_TREE
,
4120 DECL_BY_REF_P (gnu_param
));
4123 save_gnu_tree (gnat_param
, NULL_TREE
, false);
4126 /* Disconnect the variable created for the return value. */
4127 if (gnu_return_var_elmt
)
4128 TREE_VALUE (gnu_return_var_elmt
) = void_type_node
;
4130 /* If the function returns an aggregate type and we have candidates for
4131 a Named Return Value, finalize the optimization. */
4132 if (optimize
&& !optimize_debug
&& gnu_subprog_language
->named_ret_val
)
4134 finalize_nrv (gnu_subprog_decl
,
4135 gnu_subprog_language
->named_ret_val
,
4136 gnu_subprog_language
->other_ret_val
,
4137 gnu_subprog_language
->gnat_ret
);
4138 gnu_subprog_language
->named_ret_val
= NULL
;
4139 gnu_subprog_language
->other_ret_val
= NULL
;
4142 /* If this is an inlined external function that has been marked uninlinable,
4143 drop the body and stop there. Otherwise compile the body. */
4144 if (DECL_EXTERNAL (gnu_subprog_decl
) && DECL_UNINLINABLE (gnu_subprog_decl
))
4145 DECL_SAVED_TREE (gnu_subprog_decl
) = NULL_TREE
;
4147 rest_of_subprog_body_compilation (gnu_subprog_decl
);
4150 /* The type of an atomic access. */
4152 typedef enum { NOT_ATOMIC
, SIMPLE_ATOMIC
, OUTER_ATOMIC
} atomic_acces_t
;
4154 /* Return true if GNAT_NODE references an Atomic entity. This is modeled on
4155 the Is_Atomic_Object predicate of the front-end, but additionally handles
4156 explicit dereferences. */
4159 node_is_atomic (Node_Id gnat_node
)
4161 Entity_Id gnat_entity
;
4163 switch (Nkind (gnat_node
))
4166 case N_Expanded_Name
:
4167 gnat_entity
= Entity (gnat_node
);
4168 if (Ekind (gnat_entity
) != E_Variable
)
4170 return Is_Atomic (gnat_entity
) || Is_Atomic (Etype (gnat_entity
));
4172 case N_Selected_Component
:
4173 return Is_Atomic (Etype (gnat_node
))
4174 || Is_Atomic (Entity (Selector_Name (gnat_node
)));
4176 case N_Indexed_Component
:
4177 return Is_Atomic (Etype (gnat_node
))
4178 || Has_Atomic_Components (Etype (Prefix (gnat_node
)))
4179 || (Is_Entity_Name (Prefix (gnat_node
))
4180 && Has_Atomic_Components (Entity (Prefix (gnat_node
))));
4182 case N_Explicit_Dereference
:
4183 return Is_Atomic (Etype (gnat_node
));
4192 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. This is
4193 modeled on the Is_Volatile_Full_Access_Object predicate of the front-end,
4194 but additionally handles explicit dereferences. */
4197 node_is_volatile_full_access (Node_Id gnat_node
)
4199 Entity_Id gnat_entity
;
4201 switch (Nkind (gnat_node
))
4204 case N_Expanded_Name
:
4205 gnat_entity
= Entity (gnat_node
);
4206 if (!Is_Object (gnat_entity
))
4208 return Is_Volatile_Full_Access (gnat_entity
)
4209 || Is_Volatile_Full_Access (Etype (gnat_entity
));
4211 case N_Selected_Component
:
4212 return Is_Volatile_Full_Access (Etype (gnat_node
))
4213 || Is_Volatile_Full_Access (Entity (Selector_Name (gnat_node
)));
4215 case N_Indexed_Component
:
4216 case N_Explicit_Dereference
:
4217 return Is_Volatile_Full_Access (Etype (gnat_node
));
4226 /* Return true if GNAT_NODE references a component of a larger object. */
4229 node_is_component (Node_Id gnat_node
)
4231 const Node_Kind k
= Nkind (gnat_node
);
4233 (k
== N_Indexed_Component
|| k
== N_Selected_Component
|| k
== N_Slice
);
4236 /* Compute whether GNAT_NODE requires atomic access and set TYPE to the type
4237 of access and SYNC according to the associated synchronization setting.
4239 We implement 3 different semantics of atomicity in this function:
4241 1. the Ada 95/2005/2012 semantics of the Atomic aspect/pragma,
4242 2. the Ada 2020 semantics of the Atomic aspect/pragma,
4243 3. the semantics of the Volatile_Full_Access GNAT aspect/pragma.
4245 They are mutually exclusive and the FE should have rejected conflicts. */
4248 get_atomic_access (Node_Id gnat_node
, atomic_acces_t
*type
, bool *sync
)
4250 Node_Id gnat_parent
, gnat_temp
;
4251 unsigned char attr_id
;
4253 /* First, scan the parent to filter out irrelevant cases. */
4254 gnat_parent
= Parent (gnat_node
);
4255 switch (Nkind (gnat_parent
))
4257 case N_Attribute_Reference
:
4258 attr_id
= Get_Attribute_Id (Attribute_Name (gnat_parent
));
4259 /* Do not mess up machine code insertions. */
4260 if (attr_id
== Attr_Asm_Input
|| attr_id
== Attr_Asm_Output
)
4263 /* Nothing to do if we are the prefix of an attribute, since we do not
4264 want an atomic access for things like 'Size. */
4266 /* ... fall through ... */
4269 /* The N_Reference node is like an attribute. */
4270 if (Prefix (gnat_parent
) == gnat_node
)
4274 case N_Object_Renaming_Declaration
:
4275 /* Nothing to do for the identifier in an object renaming declaration,
4276 the renaming itself does not need atomic access. */
4283 /* Now strip any type conversion from GNAT_NODE. */
4284 if (Nkind (gnat_node
) == N_Type_Conversion
4285 || Nkind (gnat_node
) == N_Unchecked_Type_Conversion
)
4286 gnat_node
= Expression (gnat_node
);
4288 /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as
4289 a whole require atomic access (RM C.6(15)). But, starting with Ada 2020,
4290 reads of or writes to a nonatomic subcomponent of the object also require
4291 atomic access (RM C.6(19)). */
4292 if (node_is_atomic (gnat_node
))
4294 bool as_a_whole
= true;
4296 /* If we are the prefix of the parent, then the access is partial. */
4297 for (gnat_temp
= gnat_node
, gnat_parent
= Parent (gnat_temp
);
4298 node_is_component (gnat_parent
) && Prefix (gnat_parent
) == gnat_temp
;
4299 gnat_temp
= gnat_parent
, gnat_parent
= Parent (gnat_temp
))
4300 if (Ada_Version
< Ada_2020
|| node_is_atomic (gnat_parent
))
4305 /* We consider that partial accesses are not sequential actions and,
4306 therefore, do not require synchronization. */
4307 *type
= SIMPLE_ATOMIC
;
4308 *sync
= as_a_whole
? Atomic_Sync_Required (gnat_node
) : false;
4312 /* Look for an outer atomic access of a nonatomic subcomponent. Note that,
4313 for VFA, we do this before looking at the node itself because we need to
4314 access the outermost VFA object atomically, unlike for Atomic where it is
4315 the innermost atomic object (RM C.6(19)). */
4316 for (gnat_temp
= gnat_node
;
4317 node_is_component (gnat_temp
);
4318 gnat_temp
= Prefix (gnat_temp
))
4319 if ((Ada_Version
>= Ada_2020
&& node_is_atomic (Prefix (gnat_temp
)))
4320 || node_is_volatile_full_access (Prefix (gnat_temp
)))
4322 *type
= OUTER_ATOMIC
;
4327 /* Unlike Atomic, accessing a VFA object always requires atomic access. */
4328 if (node_is_volatile_full_access (gnat_node
))
4330 *type
= SIMPLE_ATOMIC
;
4340 /* Return true if GNAT_NODE requires simple atomic access and, if so, set SYNC
4341 according to the associated synchronization setting. */
4344 simple_atomic_access_required_p (Node_Id gnat_node
, bool *sync
)
4346 atomic_acces_t type
;
4347 get_atomic_access (gnat_node
, &type
, sync
);
4348 return type
== SIMPLE_ATOMIC
;
4351 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4354 create_temporary (const char *prefix
, tree type
)
4357 = create_var_decl (create_tmp_var_name (prefix
), NULL_TREE
,
4359 false, false, false, false, false,
4360 true, false, NULL
, Empty
);
4364 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4365 Put the initialization statement into GNU_INIT_STMT and annotate it with
4366 the SLOC of GNAT_NODE. Return the temporary variable. */
4369 create_init_temporary (const char *prefix
, tree gnu_init
, tree
*gnu_init_stmt
,
4372 tree gnu_temp
= create_temporary (prefix
, TREE_TYPE (gnu_init
));
4374 *gnu_init_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_temp
, gnu_init
);
4375 set_expr_location_from_node (*gnu_init_stmt
, gnat_node
);
4380 /* Return true if TYPE is an array of scalar type. */
4383 is_array_of_scalar_type (tree type
)
4385 if (TREE_CODE (type
) != ARRAY_TYPE
)
4388 type
= TREE_TYPE (type
);
4390 return !AGGREGATE_TYPE_P (type
) && !POINTER_TYPE_P (type
);
4393 /* Helper function for walk_tree, used by return_slot_opt_for_pure_call_p. */
4396 find_decls_r (tree
*tp
, int *walk_subtrees
, void *data
)
4398 bitmap decls
= (bitmap
) data
;
4403 else if (DECL_P (*tp
))
4404 bitmap_set_bit (decls
, DECL_UID (*tp
));
4409 /* Return whether the assignment TARGET = CALL can be subject to the return
4410 slot optimization, under the assumption that the called function be pure
4411 in the Ada sense and return an array of scalar type. */
4414 return_slot_opt_for_pure_call_p (tree target
, tree call
)
4416 /* Check that the target is a DECL. */
4417 if (!DECL_P (target
))
4420 const bitmap decls
= BITMAP_GGC_ALLOC ();
4421 call_expr_arg_iterator iter
;
4424 /* Check that all the arguments have either a scalar type (we assume that
4425 this means by-copy passing mechanism) or array of scalar type. */
4426 FOR_EACH_CALL_EXPR_ARG (arg
, iter
, call
)
4428 tree arg_type
= TREE_TYPE (arg
);
4429 if (TREE_CODE (arg_type
) == REFERENCE_TYPE
)
4430 arg_type
= TREE_TYPE (arg_type
);
4432 if (is_array_of_scalar_type (arg_type
))
4433 walk_tree_without_duplicates (&arg
, find_decls_r
, decls
);
4435 else if (AGGREGATE_TYPE_P (arg_type
) || POINTER_TYPE_P (arg_type
))
4439 /* Check that the target is not referenced by the non-scalar arguments. */
4440 return !bitmap_bit_p (decls
, DECL_UID (target
));
4443 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
4444 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4445 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4446 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4447 N_Assignment_Statement and the result is to be placed into that object.
4448 ATOMIC_ACCESS is the type of atomic access to be used for the assignment
4449 to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment
4450 to GNU_TARGET requires atomic synchronization. */
4453 Call_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, tree gnu_target
,
4454 atomic_acces_t atomic_access
, bool atomic_sync
)
4456 const bool function_call
= (Nkind (gnat_node
) == N_Function_Call
);
4457 const bool returning_value
= (function_call
&& !gnu_target
);
4458 /* The GCC node corresponding to the GNAT subprogram name. This can either
4459 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
4460 or an indirect reference expression (an INDIRECT_REF node) pointing to a
4462 tree gnu_subprog
= gnat_to_gnu (Name (gnat_node
));
4463 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
4464 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog
);
4465 /* The return type of the FUNCTION_TYPE. */
4466 tree gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
4467 const bool frontend_builtin
4468 = (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
4469 && DECL_BUILT_IN_CLASS (gnu_subprog
) == BUILT_IN_FRONTEND
);
4470 auto_vec
<tree
, 16> gnu_actual_vec
;
4471 tree gnu_name_list
= NULL_TREE
;
4472 tree gnu_stmt_list
= NULL_TREE
;
4473 tree gnu_after_list
= NULL_TREE
;
4474 tree gnu_retval
= NULL_TREE
;
4475 tree gnu_call
, gnu_result
;
4476 bool went_into_elab_proc
= false;
4477 bool pushed_binding_level
= false;
4480 Entity_Id gnat_formal
;
4481 Node_Id gnat_actual
;
4482 atomic_acces_t aa_type
;
4485 gcc_assert (FUNC_OR_METHOD_TYPE_P (gnu_subprog_type
));
4487 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
4488 all our args first. */
4489 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
&& DECL_STUBBED_P (gnu_subprog
))
4491 tree call_expr
= build_call_raise (PE_Stubbed_Subprogram_Called
,
4492 gnat_node
, N_Raise_Program_Error
);
4494 for (gnat_actual
= First_Actual (gnat_node
);
4495 Present (gnat_actual
);
4496 gnat_actual
= Next_Actual (gnat_actual
))
4497 add_stmt (gnat_to_gnu (gnat_actual
));
4499 if (returning_value
)
4501 *gnu_result_type_p
= gnu_result_type
;
4502 return build1 (NULL_EXPR
, gnu_result_type
, call_expr
);
4508 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
)
4510 /* For a call to a nested function, check the inlining status. */
4511 if (decl_function_context (gnu_subprog
))
4512 check_inlining_for_nested_subprog (gnu_subprog
);
4514 /* For a recursive call, avoid explosion due to recursive inlining. */
4515 if (gnu_subprog
== current_function_decl
)
4516 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog
) = 0;
4519 /* The only way we can be making a call via an access type is if Name is an
4520 explicit dereference. In that case, get the list of formal args from the
4521 type the access type is pointing to. Otherwise, get the formals from the
4522 entity being called. */
4523 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
4525 const Entity_Id gnat_prefix_type
4526 = Underlying_Type (Etype (Prefix (Name (gnat_node
))));
4528 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
4529 variadic
= IN (Convention (gnat_prefix_type
), Convention_C_Variadic
);
4531 /* If the access type doesn't require foreign-compatible representation,
4532 be prepared for descriptors. */
4534 = targetm
.calls
.custom_function_descriptors
> 0
4535 && Can_Use_Internal_Rep (gnat_prefix_type
);
4537 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
4539 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4540 gnat_formal
= Empty
;
4542 by_descriptor
= false;
4546 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
4548 = IN (Convention (Entity (Name (gnat_node
))), Convention_C_Variadic
);
4549 by_descriptor
= false;
4552 /* The lifetime of the temporaries created for the call ends right after the
4553 return value is copied, so we can give them the scope of the elaboration
4554 routine at top level. */
4555 if (!current_function_decl
)
4557 current_function_decl
= get_elaboration_procedure ();
4558 went_into_elab_proc
= true;
4561 /* First, create the temporary for the return value when:
4563 1. There is no target and the function has copy-in/copy-out parameters,
4564 because we need to preserve the return value before copying back the
4567 2. There is no target and the call is made for neither the declaration
4568 of an object (regular or renaming), nor a return statement, nor an
4569 allocator, nor an aggregate, and the return type has variable size
4570 because in this case the gimplifier cannot create the temporary, or
4571 more generally is an aggregate type, because the gimplifier would
4572 create the temporary in the outermost scope instead of locally here.
4573 But there is an exception for an allocator of unconstrained record
4574 type with default discriminant because we allocate the actual size
4575 in this case, unlike in the other cases, so we need a temporary to
4576 fetch the discriminant and we create it here.
4578 3. There is a target and it is a slice or an array with fixed size,
4579 and the return type has variable size, because the gimplifier
4580 doesn't handle these cases.
4582 4. There is a target which is a bit-field and the function returns an
4583 unconstrained record type with default discriminant, because the
4584 return may copy more data than the bit-field can contain.
4586 5. There is no target and we have misaligned In Out or Out parameters
4587 passed by reference, because we need to preserve the return value
4588 before copying back the parameters. However, in this case, we'll
4589 defer creating the temporary, see below.
4591 This must be done before we push a binding level around the call, since
4592 we will pop it before copying the return value. */
4594 && ((!gnu_target
&& TYPE_CI_CO_LIST (gnu_subprog_type
))
4596 && Nkind (Parent (gnat_node
)) != N_Object_Declaration
4597 && Nkind (Parent (gnat_node
)) != N_Object_Renaming_Declaration
4598 && Nkind (Parent (gnat_node
)) != N_Simple_Return_Statement
4599 && (!(Nkind (Parent (gnat_node
)) == N_Qualified_Expression
4600 && Nkind (Parent (Parent (gnat_node
))) == N_Allocator
)
4601 || type_is_padding_self_referential (gnu_result_type
))
4602 && Nkind (Parent (gnat_node
)) != N_Aggregate
4603 && AGGREGATE_TYPE_P (gnu_result_type
)
4604 && !TYPE_IS_FAT_POINTER_P (gnu_result_type
))
4606 && (TREE_CODE (gnu_target
) == ARRAY_RANGE_REF
4607 || (TREE_CODE (TREE_TYPE (gnu_target
)) == ARRAY_TYPE
4608 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target
)))
4610 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
)
4612 && TREE_CODE (gnu_target
) == COMPONENT_REF
4613 && DECL_BIT_FIELD (TREE_OPERAND (gnu_target
, 1))
4614 && type_is_padding_self_referential (gnu_result_type
))))
4616 gnu_retval
= create_temporary ("R", gnu_result_type
);
4617 DECL_RETURN_VALUE_P (gnu_retval
) = 1;
4620 /* If we don't need a value or have already created it, push a binding level
4621 around the call. This will narrow the lifetime of the temporaries we may
4622 need to make when translating the parameters as much as possible. */
4623 if (!returning_value
|| gnu_retval
)
4625 start_stmt_group ();
4627 pushed_binding_level
= true;
4630 /* Create the list of the actual parameters as GCC expects it, namely a
4631 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4632 is an expression and the TREE_PURPOSE field is null. But skip Out
4633 parameters not passed by reference and that need not be copied in. */
4634 for (gnat_actual
= First_Actual (gnat_node
);
4635 Present (gnat_actual
);
4636 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
4637 gnat_actual
= Next_Actual (gnat_actual
))
4639 Entity_Id gnat_formal_type
= Etype (gnat_formal
);
4640 tree gnu_formal_type
= gnat_to_gnu_type (gnat_formal_type
);
4641 tree gnu_formal
= present_gnu_tree (gnat_formal
)
4642 ? get_gnu_tree (gnat_formal
) : NULL_TREE
;
4643 const bool in_param
= (Ekind (gnat_formal
) == E_In_Parameter
);
4644 const bool is_true_formal_parm
4645 = gnu_formal
&& TREE_CODE (gnu_formal
) == PARM_DECL
;
4646 const bool is_by_ref_formal_parm
4647 = is_true_formal_parm
4648 && (DECL_BY_REF_P (gnu_formal
)
4649 || DECL_BY_COMPONENT_PTR_P (gnu_formal
));
4650 /* In the In Out or Out case, we must suppress conversions that yield
4651 an lvalue but can nevertheless cause the creation of a temporary,
4652 because we need the real object in this case, either to pass its
4653 address if it's passed by reference or as target of the back copy
4654 done after the call if it uses the copy-in/copy-out mechanism.
4655 We do it in the In case too, except for an unchecked conversion
4656 to an elementary type or a constrained composite type because it
4657 alone can cause the actual to be misaligned and the addressability
4658 test is applied to the real object. */
4659 const bool suppress_type_conversion
4660 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
4662 || !is_by_ref_formal_parm
4663 || (Is_Composite_Type (Underlying_Type (gnat_formal_type
))
4664 && !Is_Constrained (Underlying_Type (gnat_formal_type
)))))
4665 || (Nkind (gnat_actual
) == N_Type_Conversion
4666 && Is_Composite_Type (Underlying_Type (gnat_formal_type
))));
4667 Node_Id gnat_name
= suppress_type_conversion
4668 ? Expression (gnat_actual
) : gnat_actual
;
4669 tree gnu_name
= gnat_to_gnu (gnat_name
), gnu_name_type
;
4671 /* If it's possible we may need to use this expression twice, make sure
4672 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4673 to force side-effects before the call. */
4674 if (!in_param
&& !is_by_ref_formal_parm
)
4676 tree init
= NULL_TREE
;
4677 gnu_name
= gnat_stabilize_reference (gnu_name
, true, &init
);
4680 = build_compound_expr (TREE_TYPE (gnu_name
), init
, gnu_name
);
4683 /* If we are passing a non-addressable parameter by reference, pass the
4684 address of a copy. In the In Out or Out case, set up to copy back
4685 out after the call. */
4686 if (is_by_ref_formal_parm
4687 && (gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
)))
4688 && !addressable_p (gnu_name
, gnu_name_type
))
4690 tree gnu_orig
= gnu_name
, gnu_temp
, gnu_stmt
;
4692 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4693 but sort of an instantiation for them. */
4694 if (TREE_CODE (remove_conversions (gnu_name
, true)) == CONSTRUCTOR
)
4697 /* If the formal is passed by reference, a copy is not allowed. */
4698 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type
)
4699 || Is_Aliased (gnat_formal
))
4700 post_error ("misaligned actual cannot be passed by reference",
4703 /* If the mechanism was forced to by-ref, a copy is not allowed but
4704 we issue only a warning because this case is not strict Ada. */
4705 else if (DECL_FORCED_BY_REF_P (gnu_formal
))
4706 post_error ("misaligned actual cannot be passed by reference??",
4709 /* If the actual type of the object is already the nominal type,
4710 we have nothing to do, except if the size is self-referential
4711 in which case we'll remove the unpadding below. */
4712 if (TREE_TYPE (gnu_name
) == gnu_name_type
4713 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type
)))
4716 /* Otherwise remove the unpadding from all the objects. */
4717 else if (TREE_CODE (gnu_name
) == COMPONENT_REF
4718 && TYPE_IS_PADDING_P
4719 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))
4720 gnu_orig
= gnu_name
= TREE_OPERAND (gnu_name
, 0);
4722 /* Otherwise convert to the nominal type of the object if needed.
4723 There are several cases in which we need to make the temporary
4724 using this type instead of the actual type of the object when
4725 they are distinct, because the expectations of the callee would
4726 otherwise not be met:
4727 - if it's a justified modular type,
4728 - if the actual type is a smaller form of it,
4729 - if it's a smaller form of the actual type. */
4730 else if ((TREE_CODE (gnu_name_type
) == RECORD_TYPE
4731 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type
)
4732 || smaller_form_type_p (TREE_TYPE (gnu_name
),
4734 || (INTEGRAL_TYPE_P (gnu_name_type
)
4735 && smaller_form_type_p (gnu_name_type
,
4736 TREE_TYPE (gnu_name
))))
4737 gnu_name
= convert (gnu_name_type
, gnu_name
);
4739 /* If this is an In Out or Out parameter and we're returning a value,
4740 we need to create a temporary for the return value because we must
4741 preserve it before copying back at the very end. */
4742 if (!in_param
&& returning_value
&& !gnu_retval
)
4744 gnu_retval
= create_temporary ("R", gnu_result_type
);
4745 DECL_RETURN_VALUE_P (gnu_retval
) = 1;
4748 /* If we haven't pushed a binding level, push it now. This will
4749 narrow the lifetime of the temporary we are about to make as
4750 much as possible. */
4751 if (!pushed_binding_level
&& (!returning_value
|| gnu_retval
))
4753 start_stmt_group ();
4755 pushed_binding_level
= true;
4758 /* Create an explicit temporary holding the copy. */
4759 /* Do not initialize it for the _Init parameter of an initialization
4760 procedure since no data is meant to be passed in. */
4761 if (Ekind (gnat_formal
) == E_Out_Parameter
4762 && Is_Entity_Name (Name (gnat_node
))
4763 && Is_Init_Proc (Entity (Name (gnat_node
))))
4764 gnu_name
= gnu_temp
= create_temporary ("A", TREE_TYPE (gnu_name
));
4766 /* Initialize it on the fly like for an implicit temporary in the
4767 other cases, as we don't necessarily have a statement list. */
4770 gnu_temp
= create_init_temporary ("A", gnu_name
, &gnu_stmt
,
4772 gnu_name
= build_compound_expr (TREE_TYPE (gnu_name
), gnu_stmt
,
4776 /* Set up to move the copy back to the original if needed. */
4779 /* If the original is a COND_EXPR whose first arm isn't meant to
4780 be further used, just deal with the second arm. This is very
4781 likely the conditional expression built for a check. */
4782 if (TREE_CODE (gnu_orig
) == COND_EXPR
4783 && TREE_CODE (TREE_OPERAND (gnu_orig
, 1)) == COMPOUND_EXPR
4785 (TREE_OPERAND (TREE_OPERAND (gnu_orig
, 1), 1)))
4786 gnu_orig
= TREE_OPERAND (gnu_orig
, 2);
4789 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_orig
, gnu_temp
);
4790 set_expr_location_from_node (gnu_stmt
, gnat_node
);
4792 append_to_statement_list (gnu_stmt
, &gnu_after_list
);
4796 /* Start from the real object and build the actual. */
4797 tree gnu_actual
= gnu_name
;
4799 /* If atomic access is required for an In or In Out actual parameter,
4800 build the atomic load. */
4801 if (is_true_formal_parm
4802 && !is_by_ref_formal_parm
4803 && Ekind (gnat_formal
) != E_Out_Parameter
4804 && simple_atomic_access_required_p (gnat_actual
, &aa_sync
))
4805 gnu_actual
= build_atomic_load (gnu_actual
, aa_sync
);
4807 /* If this was a procedure call, we may not have removed any padding.
4808 So do it here for the part we will use as an input, if any. */
4809 if (Ekind (gnat_formal
) != E_Out_Parameter
4810 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
4812 = convert (get_unpadded_type (Etype (gnat_actual
)), gnu_actual
);
4814 /* Put back the conversion we suppressed above in the computation of the
4815 real object. And even if we didn't suppress any conversion there, we
4816 may have suppressed a conversion to the Etype of the actual earlier,
4817 since the parent is a procedure call, so put it back here. Note that
4818 we might have a dummy type here if the actual is the dereference of a
4819 pointer to it, but that's OK when the formal is passed by reference.
4820 We also do not put back a conversion between an actual and a formal
4821 that are unconstrained array types to avoid creating local bounds. */
4822 tree gnu_actual_type
= get_unpadded_type (Etype (gnat_actual
));
4823 if (TYPE_IS_DUMMY_P (gnu_actual_type
))
4824 gcc_assert (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
));
4825 else if (suppress_type_conversion
4826 && Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
4827 gnu_actual
= unchecked_convert (gnu_actual_type
, gnu_actual
,
4828 No_Truncation (gnat_actual
));
4829 else if ((TREE_CODE (TREE_TYPE (gnu_actual
)) == UNCONSTRAINED_ARRAY_TYPE
4830 || (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
4831 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual
))))
4832 && TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4835 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
4837 gigi_checking_assert (!Do_Range_Check (gnat_actual
));
4839 /* First see if the parameter is passed by reference. */
4840 if (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
))
4844 /* In Out or Out parameters passed by reference don't use the
4845 copy-in/copy-out mechanism so the address of the real object
4846 must be passed to the function. */
4847 gnu_actual
= gnu_name
;
4849 /* If we have a padded type, be sure we've removed padding. */
4850 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
4851 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
4854 /* If we have the constructed subtype of an aliased object
4855 with an unconstrained nominal subtype, the type of the
4856 actual includes the template, although it is formally
4857 constrained. So we need to convert it back to the real
4858 constructed subtype to retrieve the constrained part
4859 and takes its address. */
4860 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
4861 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual
))
4862 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual
))
4863 && Is_Array_Type (Underlying_Type (Etype (gnat_actual
))))
4864 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
4867 /* There is no need to convert the actual to the formal's type before
4868 taking its address. The only exception is for unconstrained array
4869 types because of the way we build fat pointers. */
4870 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4872 /* Put back the conversion we suppressed above for In Out or Out
4873 parameters, since it may set the bounds of the actual. */
4874 if (!in_param
&& suppress_type_conversion
)
4875 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
4876 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4879 /* Take the address of the object and convert to the proper pointer
4881 gnu_formal_type
= TREE_TYPE (gnu_formal
);
4882 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4885 /* Then see if the parameter is an array passed to a foreign convention
4887 else if (is_true_formal_parm
&& DECL_BY_COMPONENT_PTR_P (gnu_formal
))
4889 gnu_actual
= maybe_padded_object (gnu_actual
);
4890 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
4892 /* Take the address of the object and convert to the proper pointer
4893 type. We'd like to actually compute the address of the beginning
4894 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4895 possibility that the ARRAY_REF might return a constant and we'd be
4896 getting the wrong address. Neither approach is exactly correct,
4897 but this is the most likely to work in all cases. */
4898 gnu_formal_type
= TREE_TYPE (gnu_formal
);
4899 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4902 /* Then see if the parameter is passed by copy. */
4903 else if (is_true_formal_parm
)
4906 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
4908 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4910 /* If this is a front-end built-in function, there is no need to
4911 convert to the type used to pass the argument. */
4912 if (!frontend_builtin
)
4913 gnu_actual
= convert (DECL_ARG_TYPE (gnu_formal
), gnu_actual
);
4916 /* Then see if this is an unnamed parameter in a variadic C function. */
4919 /* This is based on the processing done in gnat_to_gnu_param, but
4920 we expect the mechanism to be set in (almost) all cases. */
4921 const Mechanism_Type mech
= Mechanism (gnat_formal
);
4923 /* Strip off possible padding type. */
4924 if (TYPE_IS_PADDING_P (gnu_formal_type
))
4925 gnu_formal_type
= TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
4927 /* Arrays are passed as pointers to element type. First check for
4928 unconstrained array and get the underlying array. */
4929 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4932 (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_formal_type
))));
4934 /* Arrays are passed as pointers to element type. */
4935 if (mech
!= By_Copy
&& TREE_CODE (gnu_formal_type
) == ARRAY_TYPE
)
4937 gnu_actual
= maybe_padded_object (gnu_actual
);
4938 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
4940 /* Strip off any multi-dimensional entries, then strip
4941 off the last array to get the component type. */
4942 while (TREE_CODE (TREE_TYPE (gnu_formal_type
)) == ARRAY_TYPE
4943 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_formal_type
)))
4944 gnu_formal_type
= TREE_TYPE (gnu_formal_type
);
4946 gnu_formal_type
= TREE_TYPE (gnu_formal_type
);
4947 gnu_formal_type
= build_pointer_type (gnu_formal_type
);
4949 = build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4952 /* Fat pointers are passed as thin pointers. */
4953 else if (TYPE_IS_FAT_POINTER_P (gnu_formal_type
))
4955 = make_type_from_size (gnu_formal_type
,
4956 size_int (POINTER_SIZE
), 0);
4958 /* If we were requested or muss pass by reference, do so.
4959 If we were requested to pass by copy, do so.
4960 Otherwise, pass In Out or Out parameters or aggregates by
4962 else if (mech
== By_Reference
4963 || must_pass_by_ref (gnu_formal_type
)
4965 && (!in_param
|| AGGREGATE_TYPE_P (gnu_formal_type
))))
4967 gnu_formal_type
= build_reference_type (gnu_formal_type
);
4969 = build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4972 /* Otherwise pass by copy after applying default C promotions. */
4975 if (INTEGRAL_TYPE_P (gnu_formal_type
)
4976 && TYPE_PRECISION (gnu_formal_type
)
4977 < TYPE_PRECISION (integer_type_node
))
4978 gnu_formal_type
= integer_type_node
;
4980 else if (SCALAR_FLOAT_TYPE_P (gnu_formal_type
)
4981 && TYPE_PRECISION (gnu_formal_type
)
4982 < TYPE_PRECISION (double_type_node
))
4983 gnu_formal_type
= double_type_node
;
4986 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4989 /* If we didn't create a PARM_DECL for the formal, this means that
4990 it is an Out parameter not passed by reference and that need not
4991 be copied in. In this case, the value of the actual need not be
4992 read. However, we still need to make sure that its side-effects
4993 are evaluated before the call, so we evaluate its address. */
4997 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
4999 if (TREE_SIDE_EFFECTS (gnu_name
))
5001 tree addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_name
);
5002 append_to_statement_list (addr
, &gnu_stmt_list
);
5008 gnu_actual_vec
.safe_push (gnu_actual
);
5011 if (frontend_builtin
)
5013 tree pred_cst
= build_int_cst (integer_type_node
, PRED_BUILTIN_EXPECT
);
5014 enum internal_fn icode
= IFN_BUILTIN_EXPECT
;
5016 switch (DECL_FE_FUNCTION_CODE (gnu_subprog
))
5018 case BUILT_IN_EXPECT
:
5020 case BUILT_IN_LIKELY
:
5021 gnu_actual_vec
.safe_push (boolean_true_node
);
5023 case BUILT_IN_UNLIKELY
:
5024 gnu_actual_vec
.safe_push (boolean_false_node
);
5030 gnu_actual_vec
.safe_push (pred_cst
);
5033 = build_call_expr_internal_loc_array (UNKNOWN_LOCATION
,
5036 gnu_actual_vec
.length (),
5037 gnu_actual_vec
.begin ());
5042 = build_call_array_loc (UNKNOWN_LOCATION
,
5044 build_unary_op (ADDR_EXPR
, NULL_TREE
,
5046 gnu_actual_vec
.length (),
5047 gnu_actual_vec
.begin ());
5048 CALL_EXPR_BY_DESCRIPTOR (gnu_call
) = by_descriptor
;
5051 set_expr_location_from_node (gnu_call
, gnat_node
);
5053 /* If we have created a temporary for the return value, initialize it. */
5057 = build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_retval
, gnu_call
);
5058 set_expr_location_from_node (gnu_stmt
, gnat_node
);
5059 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
5060 gnu_call
= gnu_retval
;
5063 /* If this is a subprogram with copy-in/copy-out parameters, we need to
5064 unpack the valued returned from the function into the In Out or Out
5065 parameters. We deal with the function return (if this is an Ada
5067 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
5069 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
5070 copy-out parameters. */
5071 tree gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
5072 const int length
= list_length (gnu_cico_list
);
5074 /* The call sequence must contain one and only one call, even though the
5075 function is pure. Save the result into a temporary if needed. */
5082 = create_init_temporary ("P", gnu_call
, &gnu_stmt
, gnat_node
);
5083 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
5086 gnu_name_list
= nreverse (gnu_name_list
);
5089 /* The first entry is for the actual return value if this is a
5090 function, so skip it. */
5092 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
5094 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
5095 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
5097 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
5099 for (gnat_actual
= First_Actual (gnat_node
);
5100 Present (gnat_actual
);
5101 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
5102 gnat_actual
= Next_Actual (gnat_actual
))
5103 /* If we are dealing with a copy-in/copy-out parameter, we must
5104 retrieve its value from the record returned in the call. */
5105 if (!(present_gnu_tree (gnat_formal
)
5106 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
5107 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
5108 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))))
5109 && Ekind (gnat_formal
) != E_In_Parameter
)
5111 /* Get the value to assign to this In Out or Out parameter. It is
5112 either the result of the function if there is only a single such
5113 parameter or the appropriate field from the record returned. */
5117 : build_component_ref (gnu_call
, TREE_PURPOSE (gnu_cico_list
),
5120 /* If the actual is a conversion, get the inner expression, which
5121 will be the real destination, and convert the result to the
5122 type of the actual parameter. */
5124 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
5126 /* If the result is padded, remove the padding. */
5127 gnu_result
= maybe_padded_object (gnu_result
);
5129 /* If the actual is a type conversion, the real target object is
5130 denoted by the inner Expression and we need to convert the
5131 result to the associated type.
5132 We also need to convert our gnu assignment target to this type
5133 if the corresponding GNU_NAME was constructed from the GNAT
5134 conversion node and not from the inner Expression. */
5135 if (Nkind (gnat_actual
) == N_Type_Conversion
)
5137 const Node_Id gnat_expr
= Expression (gnat_actual
);
5139 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
5142 = convert_with_check (Etype (gnat_expr
), gnu_result
,
5143 Do_Overflow_Check (gnat_actual
),
5144 Float_Truncate (gnat_actual
),
5147 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal
))))
5148 gnu_actual
= convert (TREE_TYPE (gnu_result
), gnu_actual
);
5151 /* Unchecked conversions as actuals for Out parameters are not
5152 allowed in user code because they are not variables, but do
5153 occur in front-end expansions. The associated GNU_NAME is
5154 always obtained from the inner expression in such cases. */
5155 else if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
5156 gnu_result
= unchecked_convert (TREE_TYPE (gnu_actual
),
5158 No_Truncation (gnat_actual
));
5161 gigi_checking_assert (!Do_Range_Check (gnat_actual
));
5163 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
5164 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
5165 gnu_result
= convert (TREE_TYPE (gnu_actual
), gnu_result
);
5168 get_atomic_access (gnat_actual
, &aa_type
, &aa_sync
);
5170 /* If an outer atomic access is required for an actual parameter,
5171 build the load-modify-store sequence. */
5172 if (aa_type
== OUTER_ATOMIC
)
5174 = build_load_modify_store (gnu_actual
, gnu_result
, gnat_node
);
5176 /* Or else, if a simple atomic access is required, build the atomic
5178 else if (aa_type
== SIMPLE_ATOMIC
)
5180 = build_atomic_store (gnu_actual
, gnu_result
, aa_sync
);
5182 /* Otherwise build a regular assignment. */
5184 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5185 gnu_actual
, gnu_result
);
5187 if (EXPR_P (gnu_result
))
5188 set_expr_location_from_node (gnu_result
, gnat_node
);
5189 append_to_statement_list (gnu_result
, &gnu_stmt_list
);
5190 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
5191 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
5195 /* If this is a function call, the result is the call expression unless a
5196 target is specified, in which case we copy the result into the target
5197 and return the assignment statement. */
5200 /* If this is a function with copy-in/copy-out parameters, extract the
5201 return value from it and update the return type. */
5202 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
5204 tree gnu_elmt
= TYPE_CI_CO_LIST (gnu_subprog_type
);
5206 = build_component_ref (gnu_call
, TREE_PURPOSE (gnu_elmt
), false);
5207 gnu_result_type
= TREE_TYPE (gnu_call
);
5210 /* If the function returns an unconstrained array or by direct reference,
5211 we have to dereference the pointer. */
5212 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
)
5213 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
))
5214 gnu_call
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_call
);
5218 Node_Id gnat_parent
= Parent (gnat_node
);
5219 enum tree_code op_code
;
5221 gigi_checking_assert (!Do_Range_Check (gnat_node
));
5223 /* ??? If the return type has variable size, then force the return
5224 slot optimization as we would not be able to create a temporary.
5225 That's what has been done historically. */
5226 if (return_type_with_variable_size_p (gnu_result_type
))
5227 op_code
= INIT_EXPR
;
5229 /* If this is a call to a pure function returning an array of scalar
5230 type, try to apply the return slot optimization. */
5231 else if ((TYPE_READONLY (gnu_subprog_type
)
5232 || TYPE_RESTRICT (gnu_subprog_type
))
5233 && is_array_of_scalar_type (gnu_result_type
)
5234 && TYPE_MODE (gnu_result_type
) == BLKmode
5235 && aggregate_value_p (gnu_result_type
, gnu_subprog_type
)
5236 && return_slot_opt_for_pure_call_p (gnu_target
, gnu_call
))
5237 op_code
= INIT_EXPR
;
5240 op_code
= MODIFY_EXPR
;
5242 /* Use the required method to move the result to the target. */
5243 if (atomic_access
== OUTER_ATOMIC
)
5245 = build_load_modify_store (gnu_target
, gnu_call
, gnat_node
);
5246 else if (atomic_access
== SIMPLE_ATOMIC
)
5247 gnu_call
= build_atomic_store (gnu_target
, gnu_call
, atomic_sync
);
5250 = build_binary_op (op_code
, NULL_TREE
, gnu_target
, gnu_call
);
5252 if (EXPR_P (gnu_call
))
5253 set_expr_location_from_node (gnu_call
, gnat_parent
);
5254 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
5257 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
5260 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
5261 parameters, the result is just the call statement. */
5262 else if (!TYPE_CI_CO_LIST (gnu_subprog_type
))
5263 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
5265 /* Finally, add the copy back statements, if any. */
5266 append_to_statement_list (gnu_after_list
, &gnu_stmt_list
);
5268 if (went_into_elab_proc
)
5269 current_function_decl
= NULL_TREE
;
5271 /* If we have pushed a binding level, pop it and finish up the enclosing
5273 if (pushed_binding_level
)
5275 add_stmt (gnu_stmt_list
);
5277 gnu_result
= end_stmt_group ();
5280 /* Otherwise, retrieve the statement list, if any. */
5281 else if (gnu_stmt_list
)
5282 gnu_result
= gnu_stmt_list
;
5284 /* Otherwise, just return the call expression. */
5288 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
5289 But first simplify if we have only one statement in the list. */
5290 if (returning_value
)
5292 tree first
= expr_first (gnu_result
), last
= expr_last (gnu_result
);
5296 = build_compound_expr (TREE_TYPE (gnu_call
), gnu_result
, gnu_call
);
5302 /* Subroutine of gnat_to_gnu to translate gnat_node, an
5303 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
5306 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node
)
5308 /* If just annotating, ignore all EH and cleanups. */
5310 = (!type_annotate_only
5311 && Present (Exception_Handlers (gnat_node
))
5312 && Back_End_Exceptions ());
5313 const bool fe_sjlj_eh
5314 = (!type_annotate_only
5315 && Present (Exception_Handlers (gnat_node
))
5316 && Exception_Mechanism
== Front_End_SJLJ
);
5317 const bool at_end
= !type_annotate_only
&& Present (At_End_Proc (gnat_node
));
5318 const bool binding_for_block
= (at_end
|| gcc_eh
|| fe_sjlj_eh
);
5319 tree gnu_jmpsave_decl
= NULL_TREE
;
5320 tree gnu_jmpbuf_decl
= NULL_TREE
;
5321 tree gnu_inner_block
; /* The statement(s) for the block itself. */
5326 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
5327 and the front-end has its own SJLJ mechanism. To call the GCC mechanism,
5328 we call add_cleanup, and when we leave the binding, end_stmt_group will
5329 create the TRY_FINALLY_EXPR construct.
5331 ??? The region level calls down there have been specifically put in place
5332 for a ZCX context and currently the order in which things are emitted
5333 (region/handlers) is different from the SJLJ case. Instead of putting
5334 other calls with different conditions at other places for the SJLJ case,
5335 it seems cleaner to reorder things for the SJLJ case and generalize the
5336 condition to make it not ZCX specific.
5338 If there are any exceptions or cleanup processing involved, we need an
5339 outer statement group (for front-end SJLJ) and binding level. */
5340 if (binding_for_block
)
5342 start_stmt_group ();
5346 /* If using fe_sjlj_eh, make the variables for the setjmp buffer and save
5347 area for address of previous buffer. Do this first since we need to have
5348 the setjmp buf known for any decls in this block. */
5352 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
5354 build_call_n_expr (get_jmpbuf_decl
, 0),
5355 false, false, false, false, false, true, false,
5358 /* The __builtin_setjmp receivers will immediately reinstall it. Now
5359 because of the unstructured form of EH used by fe_sjlj_eh, there
5360 might be forward edges going to __builtin_setjmp receivers on which
5361 it is uninitialized, although they will never be actually taken. */
5362 TREE_NO_WARNING (gnu_jmpsave_decl
) = 1;
5364 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE
,
5367 false, false, false, false, false, true, false,
5370 set_block_jmpbuf_decl (gnu_jmpbuf_decl
);
5372 /* When we exit this block, restore the saved value. */
5373 add_cleanup (build_call_n_expr (set_jmpbuf_decl
, 1, gnu_jmpsave_decl
),
5374 Present (End_Label (gnat_node
))
5375 ? End_Label (gnat_node
) : gnat_node
);
5378 /* If we are to call a function when exiting this block, add a cleanup
5379 to the binding level we made above. Note that add_cleanup is FIFO
5380 so we must register this cleanup after the EH cleanup just above. */
5383 tree proc_decl
= gnat_to_gnu (At_End_Proc (gnat_node
));
5385 /* When not optimizing, disable inlining of finalizers as this can
5386 create a more complex CFG in the parent function. */
5387 if (!optimize
|| optimize_debug
)
5388 DECL_DECLARED_INLINE_P (proc_decl
) = 0;
5390 /* If there is no end label attached, we use the location of the At_End
5391 procedure because Expand_Cleanup_Actions might reset the location of
5392 the enclosing construct to that of an inner statement. */
5393 add_cleanup (build_call_n_expr (proc_decl
, 0),
5394 Present (End_Label (gnat_node
))
5395 ? End_Label (gnat_node
) : At_End_Proc (gnat_node
));
5398 /* Now build the tree for the declarations and statements inside this block.
5399 If this is SJLJ, set our jmp_buf as the current buffer. */
5400 start_stmt_group ();
5404 gnu_expr
= build_call_n_expr (set_jmpbuf_decl
, 1,
5405 build_unary_op (ADDR_EXPR
, NULL_TREE
,
5407 set_expr_location_from_node (gnu_expr
, gnat_node
);
5408 add_stmt (gnu_expr
);
5411 if (Present (First_Real_Statement (gnat_node
)))
5412 process_decls (Statements (gnat_node
), Empty
,
5413 First_Real_Statement (gnat_node
), true, true);
5415 /* Generate code for each statement in the block. */
5416 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
5417 ? First_Real_Statement (gnat_node
)
5418 : First (Statements (gnat_node
)));
5419 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
5420 add_stmt (gnat_to_gnu (gnat_temp
));
5422 gnu_inner_block
= end_stmt_group ();
5424 /* Now generate code for the two exception models, if either is relevant for
5428 tree
*gnu_else_ptr
= 0;
5431 /* Make a binding level for the exception handling declarations and code
5432 and set up gnu_except_ptr_stack for the handlers to use. */
5433 start_stmt_group ();
5436 vec_safe_push (gnu_except_ptr_stack
,
5437 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
5438 build_pointer_type (except_type_node
),
5439 build_call_n_expr (get_excptr_decl
, 0),
5440 false, false, false, false, false,
5441 true, false, NULL
, gnat_node
));
5443 /* Generate code for each handler. The N_Exception_Handler case does the
5444 real work and returns a COND_EXPR for each handler, which we chain
5446 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
5447 Present (gnat_temp
); gnat_temp
= Next_Non_Pragma (gnat_temp
))
5449 gnu_expr
= gnat_to_gnu (gnat_temp
);
5451 /* If this is the first one, set it as the outer one. Otherwise,
5452 point the "else" part of the previous handler to us. Then point
5453 to our "else" part. */
5455 add_stmt (gnu_expr
);
5457 *gnu_else_ptr
= gnu_expr
;
5459 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
5462 /* If none of the exception handlers did anything, re-raise but do not
5464 gnu_expr
= build_call_n_expr (raise_nodefer_decl
, 1,
5465 gnu_except_ptr_stack
->last ());
5466 set_expr_location_from_node
5468 Present (End_Label (gnat_node
)) ? End_Label (gnat_node
) : gnat_node
);
5471 *gnu_else_ptr
= gnu_expr
;
5473 add_stmt (gnu_expr
);
5475 /* End the binding level dedicated to the exception handlers and get the
5476 whole statement group. */
5477 gnu_except_ptr_stack
->pop ();
5479 gnu_handler
= end_stmt_group ();
5481 /* If the setjmp returns 1, we restore our incoming longjmp value and
5482 then check the handlers. */
5483 start_stmt_group ();
5484 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl
, 1,
5487 add_stmt (gnu_handler
);
5488 gnu_handler
= end_stmt_group ();
5490 /* This block is now "if (setjmp) ... <handlers> else <block>". */
5491 gnu_result
= build3 (COND_EXPR
, void_type_node
,
5494 build_unary_op (ADDR_EXPR
, NULL_TREE
,
5496 gnu_handler
, gnu_inner_block
);
5503 /* First make a block containing the handlers. */
5504 start_stmt_group ();
5505 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
5506 Present (gnat_temp
);
5507 gnat_temp
= Next_Non_Pragma (gnat_temp
))
5508 add_stmt (gnat_to_gnu (gnat_temp
));
5509 gnu_handlers
= end_stmt_group ();
5511 /* Now make the TRY_CATCH_EXPR for the block. */
5512 gnu_result
= build2 (TRY_CATCH_EXPR
, void_type_node
,
5513 gnu_inner_block
, gnu_handlers
);
5514 /* Set a location. We need to find a unique location for the dispatching
5515 code, otherwise we can get coverage or debugging issues. Try with
5516 the location of the end label. */
5517 if (Present (End_Label (gnat_node
))
5518 && Sloc_to_locus (Sloc (End_Label (gnat_node
)), &locus
))
5519 SET_EXPR_LOCATION (gnu_result
, locus
);
5521 /* Clear column information so that the exception handler of an
5522 implicit transient block does not incorrectly inherit the slocs
5523 of a decision, which would otherwise confuse control flow based
5524 coverage analysis tools. */
5525 set_expr_location_from_node (gnu_result
, gnat_node
, true);
5528 gnu_result
= gnu_inner_block
;
5530 /* Now close our outer block, if we had to make one. */
5531 if (binding_for_block
)
5533 add_stmt (gnu_result
);
5535 gnu_result
= end_stmt_group ();
5541 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5542 to a GCC tree, which is returned. This is the variant for front-end sjlj
5543 exception handling. */
5546 Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node
)
5548 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
5549 an "if" statement to select the proper exceptions. For "Others", exclude
5550 exceptions where Handled_By_Others is nonzero unless the All_Others flag
5551 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
5552 tree gnu_choice
= boolean_false_node
;
5553 tree gnu_body
= build_stmt_group (Statements (gnat_node
), false);
5556 for (gnat_temp
= First (Exception_Choices (gnat_node
));
5557 gnat_temp
; gnat_temp
= Next (gnat_temp
))
5561 if (Nkind (gnat_temp
) == N_Others_Choice
)
5563 if (All_Others (gnat_temp
))
5564 this_choice
= boolean_true_node
;
5568 (EQ_EXPR
, boolean_type_node
,
5573 (INDIRECT_REF
, NULL_TREE
,
5574 gnu_except_ptr_stack
->last ()),
5575 not_handled_by_others_decl
,
5580 else if (Nkind (gnat_temp
) == N_Identifier
5581 || Nkind (gnat_temp
) == N_Expanded_Name
)
5583 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
5586 /* Exception may be a renaming. Recover original exception which is
5587 the one elaborated and registered. */
5588 if (Present (Renamed_Object (gnat_ex_id
)))
5589 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
5591 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, false);
5595 (EQ_EXPR
, boolean_type_node
,
5596 gnu_except_ptr_stack
->last (),
5597 convert (TREE_TYPE (gnu_except_ptr_stack
->last ()),
5598 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
5603 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
5604 gnu_choice
, this_choice
);
5607 return build3 (COND_EXPR
, void_type_node
, gnu_choice
, gnu_body
, NULL_TREE
);
5610 /* Return true if no statement in GNAT_LIST can alter the control flow. */
5613 stmt_list_cannot_alter_control_flow_p (List_Id gnat_list
)
5618 /* This is very conservative, we reject everything except for simple
5619 assignments between identifiers or literals. */
5620 for (Node_Id gnat_node
= First (gnat_list
);
5621 Present (gnat_node
);
5622 gnat_node
= Next (gnat_node
))
5624 if (Nkind (gnat_node
) != N_Assignment_Statement
)
5627 if (Nkind (Name (gnat_node
)) != N_Identifier
)
5630 Node_Kind nkind
= Nkind (Expression (gnat_node
));
5631 if (nkind
!= N_Identifier
5632 && nkind
!= N_Integer_Literal
5633 && nkind
!= N_Real_Literal
)
5640 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5641 to a GCC tree, which is returned. This is the variant for GCC exception
5645 Exception_Handler_to_gnu_gcc (Node_Id gnat_node
)
5647 tree gnu_etypes_list
= NULL_TREE
;
5649 /* We build a TREE_LIST of nodes representing what exception types this
5650 handler can catch, with special cases for others and all others cases.
5652 Each exception type is actually identified by a pointer to the exception
5653 id, or to a dummy object for "others" and "all others". */
5654 for (Node_Id gnat_temp
= First (Exception_Choices (gnat_node
));
5656 gnat_temp
= Next (gnat_temp
))
5658 tree gnu_expr
, gnu_etype
;
5660 if (Nkind (gnat_temp
) == N_Others_Choice
)
5662 gnu_expr
= All_Others (gnat_temp
) ? all_others_decl
: others_decl
;
5663 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
5665 else if (Nkind (gnat_temp
) == N_Identifier
5666 || Nkind (gnat_temp
) == N_Expanded_Name
)
5668 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
5670 /* Exception may be a renaming. Recover original exception which is
5671 the one elaborated and registered. */
5672 if (Present (Renamed_Object (gnat_ex_id
)))
5673 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
5675 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, false);
5676 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
5681 /* The GCC interface expects NULL to be passed for catch all handlers, so
5682 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
5683 is integer_zero_node. It would not work, however, because GCC's
5684 notion of "catch all" is stronger than our notion of "others". Until
5685 we correctly use the cleanup interface as well, doing that would
5686 prevent the "all others" handlers from being seen, because nothing
5687 can be caught beyond a catch all from GCC's point of view. */
5688 gnu_etypes_list
= tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
5691 start_stmt_group ();
5694 /* Expand a call to the begin_handler hook at the beginning of the
5695 handler, and arrange for a call to the end_handler hook to occur
5696 on every possible exit path. GDB sets a breakpoint in the
5697 begin_handler for catchpoints.
5699 A v1 begin handler saves the cleanup from the exception object,
5700 and marks the exception as in use, so that it will not be
5701 released by other handlers. A v1 end handler restores the
5702 cleanup and releases the exception object, unless it is still
5703 claimed, or the exception is being propagated (reraised).
5705 __builtin_eh_pointer references the exception occurrence being
5706 handled or propagated. Within the handler region, it is the
5707 former, but within the else branch of the EH_ELSE_EXPR, i.e. the
5708 exceptional cleanup path, it is the latter, so we must save the
5709 occurrence being handled early on, so that, should an exception
5710 be (re)raised, we can release the current exception, or figure
5711 out we're not to release it because we're propagating a reraise
5714 We use local variables to retrieve the incoming value at handler
5715 entry time (EXPTR), the saved cleanup (EXCLN) and the token
5716 (EXVTK), and reuse them to feed the end_handler hook's argument
5719 /* CODE: void *EXPTR = __builtin_eh_pointer (0); */
5720 tree gnu_current_exc_ptr
5721 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
5722 1, integer_zero_node
);
5724 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
5725 ptr_type_node
, gnu_current_exc_ptr
,
5726 true, false, false, false, false, true, true,
5729 tree prev_gnu_incoming_exc_ptr
= gnu_incoming_exc_ptr
;
5730 gnu_incoming_exc_ptr
= exc_ptr
;
5732 /* begin_handler_decl must not throw, so we can use it as an
5733 initializer for a variable used in cleanups.
5735 CODE: void *EXCLN = __gnat_begin_handler_v1 (EXPTR); */
5737 = create_var_decl (get_identifier ("EXCLN"), NULL_TREE
,
5739 build_call_n_expr (begin_handler_decl
, 1,
5741 true, false, false, false, false,
5742 true, true, NULL
, gnat_node
);
5744 /* Declare and initialize the choice parameter, if present. */
5745 if (Present (Choice_Parameter (gnat_node
)))
5748 = gnat_to_gnu_entity (Choice_Parameter (gnat_node
), NULL_TREE
, true);
5750 /* CODE: __gnat_set_exception_parameter (&choice_param, EXPTR); */
5751 add_stmt (build_call_n_expr
5752 (set_exception_parameter_decl
, 2,
5753 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_param
),
5754 gnu_incoming_exc_ptr
));
5757 /* CODE: <handler proper> */
5758 add_stmt_list (Statements (gnat_node
));
5760 tree call
= build_call_n_expr (end_handler_decl
, 3,
5764 /* If the handler can only end by falling off the end, don't bother
5766 if (stmt_list_cannot_alter_control_flow_p (Statements (gnat_node
)))
5767 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, NULL); */
5768 add_stmt_with_node (call
, gnat_node
);
5769 /* Otherwise, all of the above is after
5772 The call above will appear after
5775 And the code below will appear after
5778 The else block to a finally block is taken instead of the finally
5779 block when an exception propagates out of the try block. */
5782 start_stmt_group ();
5784 /* CODE: void *EXPRP = __builtin_eh_handler (0); */
5786 = create_var_decl (get_identifier ("EXPRP"), NULL_TREE
,
5788 build_call_expr (builtin_decl_explicit
5789 (BUILT_IN_EH_POINTER
),
5790 1, integer_zero_node
),
5791 true, false, false, false, false,
5792 true, true, NULL
, gnat_node
);
5794 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, EXPRP); */
5795 tree ecall
= build_call_n_expr (end_handler_decl
, 3,
5800 add_stmt_with_node (ecall
, gnat_node
);
5804 tree eblk
= end_stmt_group ();
5805 tree ehls
= build2 (EH_ELSE_EXPR
, void_type_node
, call
, eblk
);
5806 add_cleanup (ehls
, gnat_node
);
5811 gnu_incoming_exc_ptr
= prev_gnu_incoming_exc_ptr
;
5814 build2 (CATCH_EXPR
, void_type_node
, gnu_etypes_list
, end_stmt_group ());
5817 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
5820 Compilation_Unit_to_gnu (Node_Id gnat_node
)
5822 const Node_Id gnat_unit
= Unit (gnat_node
);
5823 const bool body_p
= (Nkind (gnat_unit
) == N_Package_Body
5824 || Nkind (gnat_unit
) == N_Subprogram_Body
);
5825 const Entity_Id gnat_unit_entity
= Defining_Entity (gnat_unit
);
5826 Entity_Id gnat_entity
;
5827 Node_Id gnat_pragma
, gnat_iter
;
5828 /* Make the decl for the elaboration procedure. Emit debug info for it, so
5829 that users can break into their elaboration code in debuggers. Kludge:
5830 don't consider it as a definition so that we have a line map for its
5831 body, but no subprogram description in debug info. In addition, don't
5832 qualify it as artificial, even though it is not a user subprogram per se,
5833 in particular for specs. Unlike, say, clones created internally by the
5834 compiler, this subprogram materializes specific user code and flagging it
5835 artificial would take elab code away from gcov's analysis. */
5836 tree gnu_elab_proc_decl
5837 = create_subprog_decl
5838 (create_concat_name (gnat_unit_entity
, body_p
? "elabb" : "elabs"),
5839 NULL_TREE
, void_ftype
, NULL_TREE
,
5840 is_default
, true, false, false, true, false, NULL
, gnat_unit
);
5841 struct elab_info
*info
;
5843 vec_safe_push (gnu_elab_proc_stack
, gnu_elab_proc_decl
);
5844 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl
) = 1;
5846 /* Initialize the information structure for the function. */
5847 allocate_struct_function (gnu_elab_proc_decl
, false);
5850 current_function_decl
= NULL_TREE
;
5852 start_stmt_group ();
5855 /* For a body, first process the spec if there is one. */
5856 if (Nkind (gnat_unit
) == N_Package_Body
5857 || (Nkind (gnat_unit
) == N_Subprogram_Body
&& !Acts_As_Spec (gnat_node
)))
5858 add_stmt (gnat_to_gnu (Library_Unit (gnat_node
)));
5860 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
5862 elaborate_all_entities (gnat_node
);
5864 if (Nkind (gnat_unit
) == N_Subprogram_Declaration
5865 || Nkind (gnat_unit
) == N_Generic_Package_Declaration
5866 || Nkind (gnat_unit
) == N_Generic_Subprogram_Declaration
)
5870 /* Then process any pragmas and declarations preceding the unit. */
5871 for (gnat_pragma
= First (Context_Items (gnat_node
));
5872 Present (gnat_pragma
);
5873 gnat_pragma
= Next (gnat_pragma
))
5874 if (Nkind (gnat_pragma
) == N_Pragma
)
5875 add_stmt (gnat_to_gnu (gnat_pragma
));
5876 process_decls (Declarations (Aux_Decls_Node (gnat_node
)), Empty
, Empty
,
5879 /* Process the unit itself. */
5880 add_stmt (gnat_to_gnu (gnat_unit
));
5882 /* Generate code for all the inlined subprograms. */
5883 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
5884 Present (gnat_entity
);
5885 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
5889 /* Without optimization, process only the required subprograms. */
5890 if (!optimize
&& !Has_Pragma_Inline_Always (gnat_entity
))
5893 /* The set of inlined subprograms is computed from data recorded early
5894 during expansion and it can be a strict superset of the final set
5895 computed after semantic analysis, for example if a call to such a
5896 subprogram occurs in a pragma Assert and assertions are disabled.
5897 In that case, semantic analysis resets Is_Public to false but the
5898 entry for the subprogram in the inlining tables is stalled. */
5899 if (!Is_Public (gnat_entity
))
5902 gnat_body
= Parent (Declaration_Node (gnat_entity
));
5903 if (Nkind (gnat_body
) != N_Subprogram_Body
)
5905 /* ??? This happens when only the spec of a package is provided. */
5906 if (No (Corresponding_Body (gnat_body
)))
5910 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
5913 /* Define the entity first so we set DECL_EXTERNAL. */
5914 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
5915 add_stmt (gnat_to_gnu (gnat_body
));
5918 /* Process any pragmas and actions following the unit. */
5919 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node
)));
5920 add_stmt_list (Actions (Aux_Decls_Node (gnat_node
)));
5921 finalize_from_limited_with ();
5923 /* Then process the expressions of pragma Compile_Time_{Error|Warning} to
5924 annotate types referenced therein if they have not been annotated. */
5925 for (int i
= 0; gnat_compile_time_expr_list
.iterate (i
, &gnat_iter
); i
++)
5926 (void) gnat_to_gnu_external (gnat_iter
);
5927 gnat_compile_time_expr_list
.release ();
5929 /* Save away what we've made so far and finish it up. */
5930 set_current_block_context (gnu_elab_proc_decl
);
5932 DECL_SAVED_TREE (gnu_elab_proc_decl
) = end_stmt_group ();
5933 set_end_locus_from_node (gnu_elab_proc_decl
, gnat_unit
);
5934 gnu_elab_proc_stack
->pop ();
5936 /* Record this potential elaboration procedure for later processing. */
5937 info
= ggc_alloc
<elab_info
> ();
5938 info
->next
= elab_info_list
;
5939 info
->elab_proc
= gnu_elab_proc_decl
;
5940 info
->gnat_node
= gnat_node
;
5941 elab_info_list
= info
;
5943 /* Force the processing for all nodes that remain in the queue. */
5944 process_deferred_decl_context (true);
5947 /* Mark COND, a boolean expression, as predicating a call to a noreturn
5948 function, i.e. predict that it is very likely false, and return it.
5950 The compiler will automatically predict the last edge leading to a call
5951 to a noreturn function as very unlikely taken. This function makes it
5952 possible to extend the prediction to predecessors in case the condition
5953 is made up of several short-circuit operators. */
5956 build_noreturn_cond (tree cond
)
5958 tree pred_cst
= build_int_cst (integer_type_node
, PRED_NORETURN
);
5960 build_call_expr_internal_loc (UNKNOWN_LOCATION
, IFN_BUILTIN_EXPECT
,
5961 boolean_type_node
, 3, cond
,
5962 boolean_false_node
, pred_cst
);
5965 /* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a
5966 range of values, into GNU_LOW and GNU_HIGH bounds. */
5969 Range_to_gnu (Node_Id gnat_range
, tree
*gnu_low
, tree
*gnu_high
)
5971 /* GNAT_RANGE is either an N_Range or an identifier denoting a subtype. */
5972 switch (Nkind (gnat_range
))
5975 *gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
5976 *gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
5979 case N_Expanded_Name
:
5982 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
5983 tree gnu_range_base_type
= get_base_type (gnu_range_type
);
5986 = convert (gnu_range_base_type
, TYPE_MIN_VALUE (gnu_range_type
));
5988 = convert (gnu_range_base_type
, TYPE_MAX_VALUE (gnu_range_type
));
5997 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
5998 to a GCC tree and return it. GNU_RESULT_TYPE_P is a pointer to where
5999 we should place the result type. */
6002 Raise_Error_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
6004 const Node_Kind kind
= Nkind (gnat_node
);
6005 const Node_Id gnat_cond
= Condition (gnat_node
);
6006 const int reason
= UI_To_Int (Reason (gnat_node
));
6007 const bool with_extra_info
6008 = Exception_Extra_Info
6009 && !No_Exception_Handlers_Set ()
6010 && No (get_exception_label (kind
));
6011 tree gnu_result
= NULL_TREE
, gnu_cond
= NULL_TREE
;
6014 /* The following processing is not required for correctness. Its purpose is
6015 to give more precise error messages and to record some information. */
6018 case CE_Access_Check_Failed
:
6019 if (with_extra_info
)
6020 gnu_result
= build_call_raise_column (reason
, gnat_node
, kind
);
6023 case CE_Index_Check_Failed
:
6024 case CE_Range_Check_Failed
:
6025 case CE_Invalid_Data
:
6026 if (No (gnat_cond
) || Nkind (gnat_cond
) != N_Op_Not
)
6028 gnat_rcond
= Right_Opnd (gnat_cond
);
6029 if (Nkind (gnat_rcond
) == N_In
6030 || Nkind (gnat_rcond
) == N_Op_Ge
6031 || Nkind (gnat_rcond
) == N_Op_Le
)
6033 const Node_Id gnat_index
= Left_Opnd (gnat_rcond
);
6034 const Node_Id gnat_type
= Etype (gnat_index
);
6035 tree gnu_index
= gnat_to_gnu (gnat_index
);
6036 tree gnu_type
= get_unpadded_type (gnat_type
);
6037 tree gnu_low_bound
, gnu_high_bound
, disp
;
6038 struct loop_info_d
*loop
;
6041 switch (Nkind (gnat_rcond
))
6044 Range_to_gnu (Right_Opnd (gnat_rcond
),
6045 &gnu_low_bound
, &gnu_high_bound
);
6049 gnu_low_bound
= gnat_to_gnu (Right_Opnd (gnat_rcond
));
6050 gnu_high_bound
= TYPE_MAX_VALUE (gnu_type
);
6054 gnu_low_bound
= TYPE_MIN_VALUE (gnu_type
);
6055 gnu_high_bound
= gnat_to_gnu (Right_Opnd (gnat_rcond
));
6062 gnu_type
= maybe_character_type (gnu_type
);
6063 if (TREE_TYPE (gnu_index
) != gnu_type
)
6065 gnu_low_bound
= convert (gnu_type
, gnu_low_bound
);
6066 gnu_high_bound
= convert (gnu_type
, gnu_high_bound
);
6067 gnu_index
= convert (gnu_type
, gnu_index
);
6071 && Known_Esize (gnat_type
)
6072 && UI_To_Int (Esize (gnat_type
)) <= 32)
6074 = build_call_raise_range (reason
, gnat_node
, kind
, gnu_index
,
6075 gnu_low_bound
, gnu_high_bound
);
6077 /* If optimization is enabled and we are inside a loop, we try to
6078 compute invariant conditions for checks applied to the iteration
6079 variable, i.e. conditions that are independent of the variable
6080 and necessary in order for the checks to fail in the course of
6081 some iteration. If we succeed, we consider an alternative:
6083 1. If loop unswitching is enabled, we prepend these conditions
6084 to the original conditions of the checks. This will make it
6085 possible for the loop unswitching pass to replace the loop
6086 with two loops, one of which has the checks eliminated and
6087 the other has the original checks reinstated, and a prologue
6088 implementing a run-time selection. The former loop will be
6089 for example suitable for vectorization.
6091 2. Otherwise, we instead append the conditions to the original
6092 conditions of the checks. At worse, if the conditions cannot
6093 be evaluated at compile time, they will be evaluated as true
6094 at run time only when the checks have already failed, thus
6095 contributing negatively only to the size of the executable.
6096 But the hope is that these invariant conditions be evaluated
6097 at compile time to false, thus taking away the entire checks
6102 || (gnu_low_bound
= gnat_invariant_expr (gnu_low_bound
)))
6104 || (gnu_high_bound
= gnat_invariant_expr (gnu_high_bound
)))
6105 && (loop
= find_loop_for (gnu_index
, &disp
, &neg_p
)))
6107 struct range_check_info_d
*rci
= ggc_alloc
<range_check_info_d
> ();
6108 rci
->low_bound
= gnu_low_bound
;
6109 rci
->high_bound
= gnu_high_bound
;
6112 rci
->type
= gnu_type
;
6114 = build1 (SAVE_EXPR
, boolean_type_node
, boolean_true_node
);
6115 vec_safe_push (loop
->checks
, rci
);
6116 gnu_cond
= build_noreturn_cond (gnat_to_gnu (gnat_cond
));
6118 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6123 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6126 rci
->inserted_cond
);
6135 /* The following processing does the real work, but we must nevertheless make
6136 sure not to override the result of the previous processing. */
6138 gnu_result
= build_call_raise (reason
, gnat_node
, kind
);
6139 set_expr_location_from_node (gnu_result
, gnat_node
);
6141 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
6143 /* If the type is VOID, this is a statement, so we need to generate the code
6144 for the call. Handle a condition, if there is one. */
6145 if (VOID_TYPE_P (*gnu_result_type_p
))
6147 if (Present (gnat_cond
))
6150 gnu_cond
= gnat_to_gnu (gnat_cond
);
6151 gnu_result
= build3 (COND_EXPR
, void_type_node
, gnu_cond
, gnu_result
,
6152 alloc_stmt_list ());
6156 gnu_result
= build1 (NULL_EXPR
, *gnu_result_type_p
, gnu_result
);
6161 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
6162 parameter of a call. */
6165 lhs_or_actual_p (Node_Id gnat_node
)
6167 const Node_Id gnat_parent
= Parent (gnat_node
);
6168 const Node_Kind kind
= Nkind (gnat_parent
);
6170 if (kind
== N_Assignment_Statement
&& Name (gnat_parent
) == gnat_node
)
6173 if ((kind
== N_Procedure_Call_Statement
|| kind
== N_Function_Call
)
6174 && Name (gnat_parent
) != gnat_node
)
6177 if (kind
== N_Parameter_Association
)
6183 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
6184 of an assignment or an actual parameter of a call. */
6187 present_in_lhs_or_actual_p (Node_Id gnat_node
)
6189 if (lhs_or_actual_p (gnat_node
))
6192 const Node_Kind kind
= Nkind (Parent (gnat_node
));
6194 if ((kind
== N_Type_Conversion
|| kind
== N_Unchecked_Type_Conversion
)
6195 && lhs_or_actual_p (Parent (gnat_node
)))
6201 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
6202 as gigi is concerned. This is used to avoid conversions on the LHS. */
6205 unchecked_conversion_nop (Node_Id gnat_node
)
6207 Entity_Id from_type
, to_type
;
6209 /* The conversion must be on the LHS of an assignment or an actual parameter
6210 of a call. Otherwise, even if the conversion was essentially a no-op, it
6211 could de facto ensure type consistency and this should be preserved. */
6212 if (!lhs_or_actual_p (gnat_node
))
6215 from_type
= Etype (Expression (gnat_node
));
6217 /* We're interested in artificial conversions generated by the front-end
6218 to make private types explicit, e.g. in Expand_Assign_Array. */
6219 if (!Is_Private_Type (from_type
))
6222 from_type
= Underlying_Type (from_type
);
6223 to_type
= Etype (gnat_node
);
6225 /* The direct conversion to the underlying type is a no-op. */
6226 if (to_type
== from_type
)
6229 /* For an array subtype, the conversion to the PAIT is a no-op. */
6230 if (Ekind (from_type
) == E_Array_Subtype
6231 && to_type
== Packed_Array_Impl_Type (from_type
))
6234 /* For a record subtype, the conversion to the type is a no-op. */
6235 if (Ekind (from_type
) == E_Record_Subtype
6236 && to_type
== Etype (from_type
))
6242 /* Return true if GNAT_NODE represents a statement. */
6245 statement_node_p (Node_Id gnat_node
)
6247 const Node_Kind kind
= Nkind (gnat_node
);
6249 if (kind
== N_Label
)
6252 if (IN (kind
, N_Statement_Other_Than_Procedure_Call
))
6255 if (kind
== N_Procedure_Call_Statement
)
6258 if (IN (kind
, N_Raise_xxx_Error
) && Ekind (Etype (gnat_node
)) == E_Void
)
6264 /* This function is the driver of the GNAT to GCC tree transformation process.
6265 It is the entry point of the tree transformer. GNAT_NODE is the root of
6266 some GNAT tree. Return the root of the corresponding GCC tree. If this
6267 is an expression, return the GCC equivalent of the expression. If this
6268 is a statement, return the statement or add it to the current statement
6269 group, in which case anything returned is to be interpreted as occurring
6270 after anything added. */
6273 gnat_to_gnu (Node_Id gnat_node
)
6275 const Node_Kind kind
= Nkind (gnat_node
);
6276 bool went_into_elab_proc
= false;
6277 tree gnu_result
= error_mark_node
; /* Default to no value. */
6278 tree gnu_result_type
= void_type_node
;
6279 tree gnu_expr
, gnu_lhs
, gnu_rhs
;
6281 atomic_acces_t aa_type
;
6284 /* Save node number for error message and set location information. */
6285 Current_Error_Node
= gnat_node
;
6286 Sloc_to_locus (Sloc (gnat_node
), &input_location
);
6288 /* If we are only annotating types and this node is a statement, return
6289 an empty statement list. */
6290 if (type_annotate_only
&& statement_node_p (gnat_node
))
6291 return alloc_stmt_list ();
6293 /* If we are only annotating types and this node is a subexpression, return
6294 a NULL_EXPR, but filter out nodes appearing in the expressions attached
6295 to packed array implementation types. */
6296 if (type_annotate_only
6297 && IN (kind
, N_Subexpr
)
6298 && !(((IN (kind
, N_Op
) && kind
!= N_Op_Expon
)
6299 || kind
== N_Type_Conversion
)
6300 && Is_Integer_Type (Etype (gnat_node
)))
6301 && !(kind
== N_Attribute_Reference
6302 && (Get_Attribute_Id (Attribute_Name (gnat_node
)) == Attr_Length
6303 || Get_Attribute_Id (Attribute_Name (gnat_node
)) == Attr_Size
)
6304 && Is_Constrained (Etype (Prefix (gnat_node
)))
6305 && !Is_Constr_Subt_For_U_Nominal (Etype (Prefix (gnat_node
))))
6306 && kind
!= N_Expanded_Name
6307 && kind
!= N_Identifier
6308 && !Compile_Time_Known_Value (gnat_node
))
6309 return build1 (NULL_EXPR
, get_unpadded_type (Etype (gnat_node
)),
6310 build_call_raise (CE_Range_Check_Failed
, gnat_node
,
6311 N_Raise_Constraint_Error
));
6313 if ((statement_node_p (gnat_node
) && kind
!= N_Null_Statement
)
6314 || kind
== N_Handled_Sequence_Of_Statements
6315 || kind
== N_Implicit_Label_Declaration
)
6317 tree current_elab_proc
= get_elaboration_procedure ();
6319 /* If this is a statement and we are at top level, it must be part of
6320 the elaboration procedure, so mark us as being in that procedure. */
6321 if (!current_function_decl
)
6323 current_function_decl
= current_elab_proc
;
6324 went_into_elab_proc
= true;
6327 /* If we are in the elaboration procedure, check if we are violating a
6328 No_Elaboration_Code restriction by having a statement there. Don't
6329 check for a possible No_Elaboration_Code restriction violation on
6330 N_Handled_Sequence_Of_Statements, as we want to signal an error on
6331 every nested real statement instead. This also avoids triggering
6332 spurious errors on dummy (empty) sequences created by the front-end
6333 for package bodies in some cases. */
6334 if (current_function_decl
== current_elab_proc
6335 && kind
!= N_Handled_Sequence_Of_Statements
6336 && kind
!= N_Implicit_Label_Declaration
)
6337 Check_Elaboration_Code_Allowed (gnat_node
);
6342 /********************************/
6343 /* Chapter 2: Lexical Elements */
6344 /********************************/
6347 case N_Expanded_Name
:
6348 case N_Operator_Symbol
:
6349 case N_Defining_Identifier
:
6350 case N_Defining_Operator_Symbol
:
6351 gnu_result
= Identifier_to_gnu (gnat_node
, &gnu_result_type
);
6353 /* If atomic access is required on the RHS, build the atomic load. */
6354 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6355 && !present_in_lhs_or_actual_p (gnat_node
))
6356 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6359 case N_Integer_Literal
:
6363 /* Get the type of the result, looking inside any padding and
6364 justified modular types. Then get the value in that type. */
6365 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6367 if (TREE_CODE (gnu_type
) == RECORD_TYPE
6368 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
6369 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
6371 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
6373 /* If the result overflows (meaning it doesn't fit in its base type),
6374 abort, unless this is for a named number because that's not fatal.
6375 We would like to check that the value is within the range of the
6376 subtype, but that causes problems with subtypes whose usage will
6377 raise Constraint_Error and also with biased representation. */
6378 if (TREE_OVERFLOW (gnu_result
))
6380 if (Nkind (Parent (gnat_node
)) == N_Number_Declaration
)
6381 gnu_result
= error_mark_node
;
6388 case N_Character_Literal
:
6389 /* If a Entity is present, it means that this was one of the
6390 literals in a user-defined character type. In that case,
6391 just return the value in the CONST_DECL. Otherwise, use the
6392 character code. In that case, the base type should be an
6393 INTEGER_TYPE, but we won't bother checking for that. */
6394 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6395 if (Present (Entity (gnat_node
)))
6396 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
6399 = build_int_cst (gnu_result_type
,
6400 UI_To_CC (Char_Literal_Value (gnat_node
)));
6403 case N_Real_Literal
:
6404 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6406 /* If this is of a fixed-point type, the value we want is the value of
6407 the corresponding integer. */
6408 if (Is_Fixed_Point_Type (Underlying_Type (Etype (gnat_node
))))
6410 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
6412 gcc_assert (!TREE_OVERFLOW (gnu_result
));
6417 Ureal ur_realval
= Realval (gnat_node
);
6419 /* First convert the value to a machine number if it isn't already.
6420 That will force the base to 2 for non-zero values and simplify
6421 the rest of the logic. */
6422 if (!Is_Machine_Number (gnat_node
))
6424 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
6425 ur_realval
, Round_Even
, gnat_node
);
6427 if (UR_Is_Zero (ur_realval
))
6428 gnu_result
= build_real (gnu_result_type
, dconst0
);
6431 REAL_VALUE_TYPE tmp
;
6433 gnu_result
= UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
6435 /* The base must be 2 as Machine guarantees this, so we scale
6436 the value, which we know can fit in the mantissa of the type
6437 (hence the use of that type above). */
6438 gcc_assert (Rbase (ur_realval
) == 2);
6439 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
6440 - UI_To_Int (Denominator (ur_realval
)));
6441 gnu_result
= build_real (gnu_result_type
, tmp
);
6444 /* Now see if we need to negate the result. Do it this way to
6445 properly handle -0. */
6446 if (UR_Is_Negative (Realval (gnat_node
)))
6448 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
6454 case N_String_Literal
:
6455 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6456 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
6458 String_Id gnat_string
= Strval (gnat_node
);
6459 int length
= String_Length (gnat_string
);
6462 if (length
>= ALLOCA_THRESHOLD
)
6463 string
= XNEWVEC (char, length
);
6465 string
= (char *) alloca (length
);
6467 /* Build the string with the characters in the literal. Note
6468 that Ada strings are 1-origin. */
6469 for (i
= 0; i
< length
; i
++)
6470 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
6472 gnu_result
= build_string (length
, string
);
6474 /* Strings in GCC don't normally have types, but we want
6475 this to not be converted to the array type. */
6476 TREE_TYPE (gnu_result
) = gnu_result_type
;
6478 if (length
>= ALLOCA_THRESHOLD
)
6483 /* Build a list consisting of each character, then make
6485 String_Id gnat_string
= Strval (gnat_node
);
6486 int length
= String_Length (gnat_string
);
6488 tree gnu_idx
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
6489 tree gnu_one_node
= convert (TREE_TYPE (gnu_idx
), integer_one_node
);
6490 vec
<constructor_elt
, va_gc
> *gnu_vec
;
6491 vec_alloc (gnu_vec
, length
);
6493 for (i
= 0; i
< length
; i
++)
6495 tree t
= build_int_cst (TREE_TYPE (gnu_result_type
),
6496 Get_String_Char (gnat_string
, i
+ 1));
6498 CONSTRUCTOR_APPEND_ELT (gnu_vec
, gnu_idx
, t
);
6499 gnu_idx
= int_const_binop (PLUS_EXPR
, gnu_idx
, gnu_one_node
);
6502 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
6507 gnu_result
= Pragma_to_gnu (gnat_node
);
6510 /**************************************/
6511 /* Chapter 3: Declarations and Types */
6512 /**************************************/
6514 case N_Subtype_Declaration
:
6515 case N_Full_Type_Declaration
:
6516 case N_Incomplete_Type_Declaration
:
6517 case N_Private_Type_Declaration
:
6518 case N_Private_Extension_Declaration
:
6519 case N_Task_Type_Declaration
:
6520 process_type (Defining_Entity (gnat_node
));
6521 gnu_result
= alloc_stmt_list ();
6524 case N_Object_Declaration
:
6525 case N_Number_Declaration
:
6526 case N_Exception_Declaration
:
6527 gnat_temp
= Defining_Entity (gnat_node
);
6528 gnu_result
= alloc_stmt_list ();
6530 /* If we are just annotating types and this object has an unconstrained
6531 or task type, don't elaborate it. */
6532 if (type_annotate_only
6533 && (((Is_Array_Type (Etype (gnat_temp
))
6534 || Is_Record_Type (Etype (gnat_temp
)))
6535 && !Is_Constrained (Etype (gnat_temp
)))
6536 || Is_Concurrent_Type (Etype (gnat_temp
))))
6539 if (Present (Expression (gnat_node
))
6540 && !(kind
== N_Object_Declaration
&& No_Initialization (gnat_node
))
6541 && (!type_annotate_only
6542 || Compile_Time_Known_Value (Expression (gnat_node
))))
6544 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node
)));
6546 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
6548 /* First deal with erroneous expressions. */
6549 if (TREE_CODE (gnu_expr
) == ERROR_MARK
)
6551 /* If this is a named number for which we cannot manipulate
6552 the value, just skip the declaration altogether. */
6553 if (kind
== N_Number_Declaration
)
6555 else if (type_annotate_only
)
6556 gnu_expr
= NULL_TREE
;
6559 /* Then a special case: we do not want the SLOC of the expression
6560 of the tag to pop up every time it is referenced somewhere. */
6561 else if (EXPR_P (gnu_expr
) && Is_Tag (gnat_temp
))
6562 SET_EXPR_LOCATION (gnu_expr
, UNKNOWN_LOCATION
);
6565 gnu_expr
= NULL_TREE
;
6567 /* If this is a deferred constant with an address clause, we ignore the
6568 full view since the clause is on the partial view and we cannot have
6569 2 different GCC trees for the object. The only bits of the full view
6570 we will use is the initializer, but it will be directly fetched. */
6571 if (Ekind (gnat_temp
) == E_Constant
6572 && Present (Address_Clause (gnat_temp
))
6573 && Present (Full_View (gnat_temp
)))
6574 save_gnu_tree (Full_View (gnat_temp
), error_mark_node
, true);
6576 /* If this object has its elaboration delayed, we must force evaluation
6577 of GNU_EXPR now and save it for the freeze point. Note that we need
6578 not do anything special at the global level since the lifetime of the
6579 temporary is fully contained within the elaboration routine. */
6580 if (Present (Freeze_Node (gnat_temp
)))
6584 gnu_result
= gnat_save_expr (gnu_expr
);
6585 save_gnu_tree (gnat_node
, gnu_result
, true);
6589 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, true);
6592 case N_Object_Renaming_Declaration
:
6593 gnat_temp
= Defining_Entity (gnat_node
);
6594 gnu_result
= alloc_stmt_list ();
6596 /* Don't do anything if this renaming is handled by the front end and it
6597 does not need debug info. Note that we consider renamings don't need
6598 debug info when optimizing: our way to describe them has a
6599 memory/elaboration footprint.
6601 Don't do anything neither if we are just annotating types and this
6602 object has a composite or task type, don't elaborate it. */
6603 if ((!Is_Renaming_Of_Object (gnat_temp
)
6604 || (Needs_Debug_Info (gnat_temp
)
6606 && can_materialize_object_renaming_p
6607 (Renamed_Object (gnat_temp
))))
6608 && ! (type_annotate_only
6609 && (Is_Array_Type (Etype (gnat_temp
))
6610 || Is_Record_Type (Etype (gnat_temp
))
6611 || Is_Concurrent_Type (Etype (gnat_temp
)))))
6612 gnat_to_gnu_entity (gnat_temp
,
6613 gnat_to_gnu (Renamed_Object (gnat_temp
)),
6617 case N_Exception_Renaming_Declaration
:
6618 gnat_temp
= Defining_Entity (gnat_node
);
6619 gnu_result
= alloc_stmt_list ();
6621 if (Present (Renamed_Entity (gnat_temp
)))
6622 gnat_to_gnu_entity (gnat_temp
,
6623 gnat_to_gnu (Renamed_Entity (gnat_temp
)),
6627 case N_Subprogram_Renaming_Declaration
:
6629 const Node_Id gnat_renaming
= Defining_Entity (gnat_node
);
6630 const Node_Id gnat_renamed
= Renamed_Entity (gnat_renaming
);
6632 gnu_result
= alloc_stmt_list ();
6634 /* Materializing renamed subprograms will only benefit the debugging
6635 information as they aren't referenced in the generated code. So
6636 skip them when they aren't needed. Avoid doing this if:
6638 - there is a freeze node: in this case the renamed entity is not
6640 - the renamed subprogram is intrinsic: it will not be available in
6641 the debugging information (note that both or only one of the
6642 renaming and the renamed subprograms can be intrinsic). */
6643 if (!type_annotate_only
6644 && Needs_Debug_Info (gnat_renaming
)
6645 && No (Freeze_Node (gnat_renaming
))
6646 && Present (gnat_renamed
)
6647 && (Ekind (gnat_renamed
) == E_Function
6648 || Ekind (gnat_renamed
) == E_Procedure
)
6649 && !Is_Intrinsic_Subprogram (gnat_renaming
)
6650 && !Is_Intrinsic_Subprogram (gnat_renamed
))
6651 gnat_to_gnu_entity (gnat_renaming
, gnat_to_gnu (gnat_renamed
), true);
6655 case N_Implicit_Label_Declaration
:
6656 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, true);
6657 gnu_result
= alloc_stmt_list ();
6660 case N_Package_Renaming_Declaration
:
6661 /* These are fully handled in the front end. */
6662 /* ??? For package renamings, find a way to use GENERIC namespaces so
6663 that we get proper debug information for them. */
6664 gnu_result
= alloc_stmt_list ();
6667 /*************************************/
6668 /* Chapter 4: Names and Expressions */
6669 /*************************************/
6671 case N_Explicit_Dereference
:
6672 /* Make sure the designated type is complete before dereferencing. */
6673 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6674 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
6675 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
6677 /* If atomic access is required on the RHS, build the atomic load. */
6678 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6679 && !present_in_lhs_or_actual_p (gnat_node
))
6680 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6683 case N_Indexed_Component
:
6685 tree gnu_array_object
= gnat_to_gnu ((Prefix (gnat_node
)));
6688 Node_Id
*gnat_expr_array
;
6690 gnu_array_object
= maybe_padded_object (gnu_array_object
);
6691 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
6693 /* Convert vector inputs to their representative array type, to fit
6694 what the code below expects. */
6695 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object
)))
6697 if (present_in_lhs_or_actual_p (gnat_node
))
6698 gnat_mark_addressable (gnu_array_object
);
6699 gnu_array_object
= maybe_vector_array (gnu_array_object
);
6702 /* The failure of this assertion will very likely come from a missing
6703 expansion for a packed array access. */
6704 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object
)) == ARRAY_TYPE
);
6706 /* First compute the number of dimensions of the array, then
6707 fill the expression array, the order depending on whether
6708 this is a Convention_Fortran array or not. */
6709 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
6710 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
6711 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
6712 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
6715 gnat_expr_array
= XALLOCAVEC (Node_Id
, ndim
);
6717 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
6718 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
6720 i
--, gnat_temp
= Next (gnat_temp
))
6721 gnat_expr_array
[i
] = gnat_temp
;
6723 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
6725 i
++, gnat_temp
= Next (gnat_temp
))
6726 gnat_expr_array
[i
] = gnat_temp
;
6728 /* Start with the prefix and build the successive references. */
6729 gnu_result
= gnu_array_object
;
6731 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
6733 i
++, gnu_type
= TREE_TYPE (gnu_type
))
6735 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
6736 gnat_temp
= gnat_expr_array
[i
];
6737 gnu_expr
= maybe_character_value (gnat_to_gnu (gnat_temp
));
6740 = build_binary_op (ARRAY_REF
, NULL_TREE
, gnu_result
, gnu_expr
);
6743 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6745 /* If atomic access is required on the RHS, build the atomic load. */
6746 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6747 && !present_in_lhs_or_actual_p (gnat_node
))
6748 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6754 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
6756 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6758 gnu_array_object
= maybe_padded_object (gnu_array_object
);
6759 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
6761 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
6762 gnu_expr
= maybe_character_value (gnu_expr
);
6764 /* If this is a slice with non-constant size of an array with constant
6765 size, set the maximum size for the allocation of temporaries. */
6766 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type
))
6767 && TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object
))))
6768 TYPE_ARRAY_MAX_SIZE (gnu_result_type
)
6769 = TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object
));
6771 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
6772 gnu_array_object
, gnu_expr
);
6776 case N_Selected_Component
:
6778 const Entity_Id gnat_prefix
= Prefix (gnat_node
);
6779 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
6780 tree gnu_prefix
= gnat_to_gnu (gnat_prefix
);
6782 gnu_prefix
= maybe_padded_object (gnu_prefix
);
6784 /* gnat_to_gnu_entity does not save the GNU tree made for renamed
6785 discriminants so avoid making recursive calls on each reference
6786 to them by following the appropriate link directly here. */
6787 if (Ekind (gnat_field
) == E_Discriminant
)
6789 /* For discriminant references in tagged types always substitute
6790 the corresponding discriminant as the actual component. */
6791 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix
))))
6792 while (Present (Corresponding_Discriminant (gnat_field
)))
6793 gnat_field
= Corresponding_Discriminant (gnat_field
);
6795 /* For discriminant references in untagged types always substitute
6796 the corresponding stored discriminant. */
6797 else if (Present (Corresponding_Discriminant (gnat_field
)))
6798 gnat_field
= Original_Record_Component (gnat_field
);
6801 /* Handle extracting the real or imaginary part of a complex.
6802 The real part is the first field and the imaginary the last. */
6803 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
6804 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
6805 ? REALPART_EXPR
: IMAGPART_EXPR
,
6806 NULL_TREE
, gnu_prefix
);
6809 tree gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
6811 struct loop_info_d
*loop
;
6814 = build_component_ref (gnu_prefix
, gnu_field
,
6815 (Nkind (Parent (gnat_node
))
6816 == N_Attribute_Reference
)
6817 && lvalue_required_for_attribute_p
6818 (Parent (gnat_node
)));
6820 /* If optimization is enabled and we are inside a loop, we try to
6821 hoist nonconstant but invariant offset computations outside of
6822 the loop, since they very likely contain loads that could turn
6823 out to be hard to move if they end up in active EH regions. */
6826 && TREE_CODE (gnu_result
) == COMPONENT_REF
6827 && (gnu_offset
= component_ref_field_offset (gnu_result
))
6828 && !TREE_CONSTANT (gnu_offset
)
6829 && (gnu_offset
= gnat_invariant_expr (gnu_offset
))
6830 && (loop
= find_loop ()))
6833 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_offset
), gnu_offset
);
6834 vec_safe_push (loop
->invariants
, invariant
);
6835 tree field
= TREE_OPERAND (gnu_result
, 1);
6837 = size_int (DECL_OFFSET_ALIGN (field
) / BITS_PER_UNIT
);
6838 /* Divide the offset by its alignment. */
6839 TREE_OPERAND (gnu_result
, 2)
6840 = size_binop (EXACT_DIV_EXPR
, invariant
, factor
);
6844 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6846 /* If atomic access is required on the RHS, build the atomic load. */
6847 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6848 && !present_in_lhs_or_actual_p (gnat_node
))
6849 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6853 case N_Attribute_Reference
:
6855 /* The attribute designator. */
6856 const int attr
= Get_Attribute_Id (Attribute_Name (gnat_node
));
6858 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
6859 is a unit, not an object with a GCC equivalent. */
6860 if (attr
== Attr_Elab_Spec
|| attr
== Attr_Elab_Body
)
6862 create_subprog_decl (create_concat_name
6863 (Entity (Prefix (gnat_node
)),
6864 attr
== Attr_Elab_Body
? "elabb" : "elabs"),
6865 NULL_TREE
, void_ftype
, NULL_TREE
, is_default
,
6866 true, true, true, true, false, NULL
,
6869 gnu_result
= Attribute_to_gnu (gnat_node
, &gnu_result_type
, attr
);
6874 /* Like 'Access as far as we are concerned. */
6875 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
6876 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
6877 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6881 case N_Extension_Aggregate
:
6885 /* Check that this aggregate has not slipped through the cracks. */
6886 gcc_assert (!Expansion_Delayed (gnat_node
));
6888 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6890 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
6891 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
6893 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type
)));
6894 else if (TREE_CODE (gnu_result_type
) == VECTOR_TYPE
)
6895 gnu_aggr_type
= TYPE_REPRESENTATIVE_ARRAY (gnu_result_type
);
6897 gnu_aggr_type
= gnu_result_type
;
6899 if (Null_Record_Present (gnat_node
))
6900 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL
);
6902 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
6903 || TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
6905 = assoc_to_constructor (Etype (gnat_node
),
6906 First (Component_Associations (gnat_node
)),
6908 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
6909 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
6911 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
6914 (COMPLEX_EXPR
, gnu_aggr_type
,
6915 gnat_to_gnu (Expression (First
6916 (Component_Associations (gnat_node
)))),
6917 gnat_to_gnu (Expression
6919 (First (Component_Associations (gnat_node
))))));
6923 gnu_result
= convert (gnu_result_type
, gnu_result
);
6928 if (TARGET_VTABLE_USES_DESCRIPTORS
6929 && Ekind (Etype (gnat_node
)) == E_Access_Subprogram_Type
6930 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
6931 gnu_result
= null_fdesc_node
;
6933 gnu_result
= null_pointer_node
;
6934 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6937 case N_Type_Conversion
:
6938 case N_Qualified_Expression
:
6939 gnu_expr
= maybe_character_value (gnat_to_gnu (Expression (gnat_node
)));
6940 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6942 /* If this is a qualified expression for a tagged type, we mark the type
6943 as used. Because of polymorphism, this might be the only reference to
6944 the tagged type in the program while objects have it as dynamic type.
6945 The debugger needs to see it to display these objects properly. */
6946 if (kind
== N_Qualified_Expression
&& Is_Tagged_Type (Etype (gnat_node
)))
6947 used_types_insert (gnu_result_type
);
6949 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node
)));
6952 = convert_with_check (Etype (gnat_node
), gnu_expr
,
6953 Do_Overflow_Check (gnat_node
),
6954 kind
== N_Type_Conversion
6955 && Float_Truncate (gnat_node
), gnat_node
);
6958 case N_Unchecked_Type_Conversion
:
6959 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6960 gnu_expr
= maybe_character_value (gnat_to_gnu (Expression (gnat_node
)));
6962 /* Skip further processing if the conversion is deemed a no-op. */
6963 if (unchecked_conversion_nop (gnat_node
))
6965 gnu_result
= gnu_expr
;
6966 gnu_result_type
= TREE_TYPE (gnu_result
);
6970 /* If the result is a pointer type, see if we are improperly
6971 converting to a stricter alignment. */
6972 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
6973 && Is_Access_Type (Etype (gnat_node
)))
6975 unsigned int align
= known_alignment (gnu_expr
);
6976 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
6977 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
6979 if (align
!= 0 && align
< oalign
&& !TYPE_ALIGN_OK (gnu_obj_type
))
6980 post_error_ne_tree_2
6981 ("?source alignment (^) '< alignment of & (^)",
6982 gnat_node
, Designated_Type (Etype (gnat_node
)),
6983 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
6986 /* If we are converting a descriptor to a function pointer, first
6987 build the pointer. */
6988 if (TARGET_VTABLE_USES_DESCRIPTORS
6989 && TREE_TYPE (gnu_expr
) == fdesc_type_node
6990 && POINTER_TYPE_P (gnu_result_type
))
6991 gnu_expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
6993 gnu_result
= unchecked_convert (gnu_result_type
, gnu_expr
,
6994 No_Truncation (gnat_node
));
7000 tree gnu_obj
= gnat_to_gnu (Left_Opnd (gnat_node
));
7001 tree gnu_low
, gnu_high
;
7003 Range_to_gnu (Right_Opnd (gnat_node
), &gnu_low
, &gnu_high
);
7004 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7006 tree gnu_op_type
= maybe_character_type (TREE_TYPE (gnu_obj
));
7007 if (TREE_TYPE (gnu_obj
) != gnu_op_type
)
7009 gnu_obj
= convert (gnu_op_type
, gnu_obj
);
7010 gnu_low
= convert (gnu_op_type
, gnu_low
);
7011 gnu_high
= convert (gnu_op_type
, gnu_high
);
7014 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
7015 ensure that GNU_OBJ is evaluated only once and perform a full range
7017 if (operand_equal_p (gnu_low
, gnu_high
, 0))
7019 = build_binary_op (EQ_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
7023 gnu_obj
= gnat_protect_expr (gnu_obj
);
7024 t1
= build_binary_op (GE_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
7026 set_expr_location_from_node (t1
, gnat_node
);
7027 t2
= build_binary_op (LE_EXPR
, gnu_result_type
, gnu_obj
, gnu_high
);
7029 set_expr_location_from_node (t2
, gnat_node
);
7031 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
, t1
, t2
);
7034 if (kind
== N_Not_In
)
7036 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result
), gnu_result
);
7041 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
7042 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
7043 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7044 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
7046 : (Rounded_Result (gnat_node
)
7047 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
7048 gnu_result_type
, gnu_lhs
, gnu_rhs
);
7062 case N_Op_Rotate_Left
:
7063 case N_Op_Rotate_Right
:
7064 case N_Op_Shift_Left
:
7065 case N_Op_Shift_Right
:
7066 case N_Op_Shift_Right_Arithmetic
:
7073 enum tree_code code
= gnu_codes
[kind
];
7074 bool ignore_lhs_overflow
= false;
7075 location_t saved_location
= input_location
;
7076 tree gnu_type
, gnu_max_shift
= NULL_TREE
;
7078 /* Fix operations set up for boolean types in GNU_CODES above. */
7079 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node
))))
7083 code
= BIT_AND_EXPR
;
7086 code
= BIT_IOR_EXPR
;
7089 code
= BIT_XOR_EXPR
;
7095 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
7096 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
7097 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7099 /* If this is a shift, take the count as unsigned since that is what
7100 most machines do and will generate simpler adjustments below. */
7101 if (IN (kind
, N_Op_Shift
))
7104 = gnat_unsigned_type_for (get_base_type (TREE_TYPE (gnu_rhs
)));
7105 gnu_rhs
= convert (gnu_count_type
, gnu_rhs
);
7107 = convert (TREE_TYPE (gnu_rhs
), TYPE_SIZE (gnu_type
));
7110 /* Pending generic support for efficient vector logical operations in
7111 GCC, convert vectors to their representative array type view and
7113 gnu_lhs
= maybe_vector_array (gnu_lhs
);
7114 gnu_rhs
= maybe_vector_array (gnu_rhs
);
7116 /* If this is a comparison operator, convert any references to an
7117 unconstrained array value into a reference to the actual array. */
7118 if (TREE_CODE_CLASS (code
) == tcc_comparison
)
7120 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
7121 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
7123 tree gnu_op_type
= maybe_character_type (TREE_TYPE (gnu_lhs
));
7124 if (TREE_TYPE (gnu_lhs
) != gnu_op_type
)
7126 gnu_lhs
= convert (gnu_op_type
, gnu_lhs
);
7127 gnu_rhs
= convert (gnu_op_type
, gnu_rhs
);
7131 /* If this is a shift whose count is not guaranteed to be correct,
7132 we need to adjust the shift count. */
7133 if ((kind
== N_Op_Rotate_Left
|| kind
== N_Op_Rotate_Right
)
7134 && !Shift_Count_OK (gnat_node
))
7135 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, TREE_TYPE (gnu_rhs
),
7136 gnu_rhs
, gnu_max_shift
);
7137 else if (kind
== N_Op_Shift_Right_Arithmetic
7138 && !Shift_Count_OK (gnat_node
))
7140 = build_binary_op (MIN_EXPR
, TREE_TYPE (gnu_rhs
),
7141 build_binary_op (MINUS_EXPR
,
7142 TREE_TYPE (gnu_rhs
),
7145 (TREE_TYPE (gnu_rhs
), 1)),
7148 /* For right shifts, the type says what kind of shift to do,
7149 so we may need to choose a different type. In this case,
7150 we have to ignore integer overflow lest it propagates all
7151 the way down and causes a CE to be explicitly raised. */
7152 if (kind
== N_Op_Shift_Right
&& !TYPE_UNSIGNED (gnu_type
))
7154 gnu_type
= gnat_unsigned_type_for (gnu_type
);
7155 ignore_lhs_overflow
= true;
7157 else if (kind
== N_Op_Shift_Right_Arithmetic
7158 && TYPE_UNSIGNED (gnu_type
))
7160 gnu_type
= gnat_signed_type_for (gnu_type
);
7161 ignore_lhs_overflow
= true;
7164 if (gnu_type
!= gnu_result_type
)
7166 tree gnu_old_lhs
= gnu_lhs
;
7167 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
7168 if (TREE_CODE (gnu_lhs
) == INTEGER_CST
&& ignore_lhs_overflow
)
7169 TREE_OVERFLOW (gnu_lhs
) = TREE_OVERFLOW (gnu_old_lhs
);
7170 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
7172 gnu_max_shift
= convert (gnu_type
, gnu_max_shift
);
7175 /* For signed integer addition, subtraction and multiplication, do an
7176 overflow check if required. */
7177 if (Do_Overflow_Check (gnat_node
)
7178 && (code
== PLUS_EXPR
|| code
== MINUS_EXPR
|| code
== MULT_EXPR
)
7179 && !TYPE_UNSIGNED (gnu_type
)
7180 && !FLOAT_TYPE_P (gnu_type
))
7182 = build_binary_op_trapv (code
, gnu_type
, gnu_lhs
, gnu_rhs
,
7186 /* Some operations, e.g. comparisons of arrays, generate complex
7187 trees that need to be annotated while they are being built. */
7188 input_location
= saved_location
;
7189 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
7192 /* If this is a logical shift with the shift count not verified,
7193 we must return zero if it is too large. We cannot compensate
7194 beforehand in this case. */
7195 if ((kind
== N_Op_Shift_Left
|| kind
== N_Op_Shift_Right
)
7196 && !Shift_Count_OK (gnat_node
))
7198 = build_cond_expr (gnu_type
,
7199 build_binary_op (GE_EXPR
, boolean_type_node
,
7200 gnu_rhs
, gnu_max_shift
),
7201 build_int_cst (gnu_type
, 0),
7206 case N_If_Expression
:
7208 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
7209 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
7211 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
7213 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7215 = build_cond_expr (gnu_result_type
, gnu_cond
, gnu_true
, gnu_false
);
7220 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
7221 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7225 /* This case can apply to a boolean or a modular type.
7226 Fall through for a boolean operand since GNU_CODES is set
7227 up to handle this. */
7228 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node
))))
7230 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
7231 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7232 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
7237 /* ... fall through ... */
7241 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
7242 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7244 /* For signed integer negation and absolute value, do an overflow check
7246 if (Do_Overflow_Check (gnat_node
)
7247 && !TYPE_UNSIGNED (gnu_result_type
)
7248 && !FLOAT_TYPE_P (gnu_result_type
))
7250 = build_unary_op_trapv (gnu_codes
[kind
], gnu_result_type
, gnu_expr
,
7254 = build_unary_op (gnu_codes
[kind
], gnu_result_type
, gnu_expr
);
7259 tree gnu_type
, gnu_init
;
7260 bool ignore_init_type
;
7262 gnat_temp
= Expression (gnat_node
);
7264 /* The expression can be either an N_Identifier or an Expanded_Name,
7265 which must represent a type, or a N_Qualified_Expression, which
7266 contains both the type and an initial value for the object. */
7267 if (Nkind (gnat_temp
) == N_Identifier
7268 || Nkind (gnat_temp
) == N_Expanded_Name
)
7270 ignore_init_type
= false;
7271 gnu_init
= NULL_TREE
;
7272 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
7275 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
7277 const Entity_Id gnat_desig_type
7278 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
7280 ignore_init_type
= Has_Constrained_Partial_View (gnat_desig_type
);
7282 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
7283 gnu_init
= maybe_unconstrained_array (gnu_init
);
7285 gigi_checking_assert (!Do_Range_Check (Expression (gnat_temp
)));
7287 if (Is_Elementary_Type (gnat_desig_type
)
7288 || Is_Constrained (gnat_desig_type
))
7289 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
7292 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
7293 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
7294 gnu_type
= TREE_TYPE (gnu_init
);
7297 /* See the N_Qualified_Expression case for the rationale. */
7298 if (Is_Tagged_Type (gnat_desig_type
))
7299 used_types_insert (gnu_type
);
7301 gnu_init
= convert (gnu_type
, gnu_init
);
7306 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7307 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
7308 Procedure_To_Call (gnat_node
),
7309 Storage_Pool (gnat_node
), gnat_node
,
7314 /**************************/
7315 /* Chapter 5: Statements */
7316 /**************************/
7319 gnu_result
= build1 (LABEL_EXPR
, void_type_node
,
7320 gnat_to_gnu (Identifier (gnat_node
)));
7323 case N_Null_Statement
:
7324 /* When not optimizing, turn null statements from source into gotos to
7325 the next statement that the middle-end knows how to preserve. */
7326 if (!optimize
&& Comes_From_Source (gnat_node
))
7328 tree stmt
, label
= create_label_decl (NULL_TREE
, gnat_node
);
7329 DECL_IGNORED_P (label
) = 1;
7330 start_stmt_group ();
7331 stmt
= build1 (GOTO_EXPR
, void_type_node
, label
);
7332 set_expr_location_from_node (stmt
, gnat_node
);
7334 stmt
= build1 (LABEL_EXPR
, void_type_node
, label
);
7335 set_expr_location_from_node (stmt
, gnat_node
);
7337 gnu_result
= end_stmt_group ();
7340 gnu_result
= alloc_stmt_list ();
7343 case N_Assignment_Statement
:
7344 /* Get the LHS and RHS of the statement and convert any reference to an
7345 unconstrained array into a reference to the underlying array. */
7346 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
7348 /* If the type has a size that overflows, convert this into raise of
7349 Storage_Error: execution shouldn't have gotten here anyway. */
7350 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
7351 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))))
7352 gnu_result
= build_call_raise (SE_Object_Too_Large
, gnat_node
,
7353 N_Raise_Storage_Error
);
7354 else if (Nkind (Expression (gnat_node
)) == N_Function_Call
)
7356 get_atomic_access (Name (gnat_node
), &aa_type
, &aa_sync
);
7358 = Call_to_gnu (Expression (gnat_node
), &gnu_result_type
, gnu_lhs
,
7363 const Node_Id gnat_expr
= Expression (gnat_node
);
7364 const Node_Id gnat_inner
7365 = Nkind (gnat_expr
) == N_Qualified_Expression
7366 ? Expression (gnat_expr
)
7368 const Entity_Id gnat_type
7369 = Underlying_Type (Etype (Name (gnat_node
)));
7370 const bool use_memset_p
7371 = Is_Array_Type (gnat_type
)
7372 && Nkind (gnat_inner
) == N_Aggregate
7373 && Is_Single_Aggregate (gnat_inner
);
7375 /* If we use memset, we need to find the innermost expression. */
7378 gnat_temp
= gnat_inner
;
7381 = Expression (First (Component_Associations (gnat_temp
)));
7382 } while (Nkind (gnat_temp
) == N_Aggregate
7383 && Is_Single_Aggregate (gnat_temp
));
7384 gnu_rhs
= gnat_to_gnu (gnat_temp
);
7387 gnu_rhs
= maybe_unconstrained_array (gnat_to_gnu (gnat_expr
));
7389 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
7391 get_atomic_access (Name (gnat_node
), &aa_type
, &aa_sync
);
7393 /* If an outer atomic access is required on the LHS, build the load-
7394 modify-store sequence. */
7395 if (aa_type
== OUTER_ATOMIC
)
7396 gnu_result
= build_load_modify_store (gnu_lhs
, gnu_rhs
, gnat_node
);
7398 /* Or else, if a simple atomic access is required, build the atomic
7400 else if (aa_type
== SIMPLE_ATOMIC
)
7401 gnu_result
= build_atomic_store (gnu_lhs
, gnu_rhs
, aa_sync
);
7403 /* Or else, use memset when the conditions are met. This has already
7404 been validated by Aggr_Assignment_OK_For_Backend in the front-end
7405 and the RHS is thus guaranteed to be of the appropriate form. */
7406 else if (use_memset_p
)
7409 = real_zerop (gnu_rhs
)
7411 : fold_convert (integer_type_node
, gnu_rhs
);
7412 tree dest
= build_fold_addr_expr (gnu_lhs
);
7413 tree t
= builtin_decl_explicit (BUILT_IN_MEMSET
);
7414 /* Be extra careful not to write too much data. */
7416 if (TREE_CODE (gnu_lhs
) == COMPONENT_REF
)
7417 size
= DECL_SIZE_UNIT (TREE_OPERAND (gnu_lhs
, 1));
7418 else if (DECL_P (gnu_lhs
))
7419 size
= DECL_SIZE_UNIT (gnu_lhs
);
7421 size
= TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
));
7422 size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_lhs
);
7423 if (TREE_CODE (value
) == INTEGER_CST
&& !integer_zerop (value
))
7426 = build_int_cst (integer_type_node
,
7427 ((HOST_WIDE_INT
) 1 << BITS_PER_UNIT
) - 1);
7428 value
= int_const_binop (BIT_AND_EXPR
, value
, mask
);
7430 gnu_result
= build_call_expr (t
, 3, dest
, value
, size
);
7433 /* Otherwise build a regular assignment. */
7436 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
7438 /* If the assignment type is a regular array and the two sides are
7439 not completely disjoint, play safe and use memmove. But don't do
7440 it for a bit-packed array as it might not be byte-aligned. */
7441 if (TREE_CODE (gnu_result
) == MODIFY_EXPR
7442 && Is_Array_Type (gnat_type
)
7443 && !Is_Bit_Packed_Array (gnat_type
)
7444 && !(Forwards_OK (gnat_node
) && Backwards_OK (gnat_node
)))
7446 tree to
= TREE_OPERAND (gnu_result
, 0);
7447 tree from
= TREE_OPERAND (gnu_result
, 1);
7448 tree type
= TREE_TYPE (from
);
7450 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type
), from
);
7451 tree to_ptr
= build_fold_addr_expr (to
);
7452 tree from_ptr
= build_fold_addr_expr (from
);
7453 tree t
= builtin_decl_explicit (BUILT_IN_MEMMOVE
);
7454 gnu_result
= build_call_expr (t
, 3, to_ptr
, from_ptr
, size
);
7459 case N_If_Statement
:
7461 tree
*gnu_else_ptr
; /* Point to put next "else if" or "else". */
7463 /* Make the outer COND_EXPR. Avoid non-determinism. */
7464 gnu_result
= build3 (COND_EXPR
, void_type_node
,
7465 gnat_to_gnu (Condition (gnat_node
)),
7466 NULL_TREE
, NULL_TREE
);
7467 COND_EXPR_THEN (gnu_result
)
7468 = build_stmt_group (Then_Statements (gnat_node
), false);
7469 TREE_SIDE_EFFECTS (gnu_result
) = 1;
7470 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_result
);
7472 /* Now make a COND_EXPR for each of the "else if" parts. Put each
7473 into the previous "else" part and point to where to put any
7474 outer "else". Also avoid non-determinism. */
7475 if (Present (Elsif_Parts (gnat_node
)))
7476 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
7477 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
7479 gnu_expr
= build3 (COND_EXPR
, void_type_node
,
7480 gnat_to_gnu (Condition (gnat_temp
)),
7481 NULL_TREE
, NULL_TREE
);
7482 COND_EXPR_THEN (gnu_expr
)
7483 = build_stmt_group (Then_Statements (gnat_temp
), false);
7484 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
7485 set_expr_location_from_node (gnu_expr
, gnat_temp
);
7486 *gnu_else_ptr
= gnu_expr
;
7487 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
7490 *gnu_else_ptr
= build_stmt_group (Else_Statements (gnat_node
), false);
7494 case N_Case_Statement
:
7495 gnu_result
= Case_Statement_to_gnu (gnat_node
);
7498 case N_Loop_Statement
:
7499 gnu_result
= Loop_Statement_to_gnu (gnat_node
);
7502 case N_Block_Statement
:
7503 /* The only way to enter the block is to fall through to it. */
7504 if (stmt_group_may_fallthru ())
7506 start_stmt_group ();
7508 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7509 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
7511 gnu_result
= end_stmt_group ();
7514 gnu_result
= alloc_stmt_list ();
7517 case N_Exit_Statement
:
7519 = build2 (EXIT_STMT
, void_type_node
,
7520 (Present (Condition (gnat_node
))
7521 ? gnat_to_gnu (Condition (gnat_node
)) : NULL_TREE
),
7522 (Present (Name (gnat_node
))
7523 ? get_gnu_tree (Entity (Name (gnat_node
)))
7524 : LOOP_STMT_LABEL (gnu_loop_stack
->last ()->stmt
)));
7527 case N_Simple_Return_Statement
:
7529 tree gnu_ret_obj
, gnu_ret_val
;
7531 /* If the subprogram is a function, we must return the expression. */
7532 if (Present (Expression (gnat_node
)))
7534 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
7536 /* If this function has copy-in/copy-out parameters parameters and
7537 doesn't return by invisible reference, get the real object for
7538 the return. See Subprogram_Body_to_gnu. */
7539 if (TYPE_CI_CO_LIST (gnu_subprog_type
)
7540 && !TREE_ADDRESSABLE (gnu_subprog_type
))
7541 gnu_ret_obj
= gnu_return_var_stack
->last ();
7543 gnu_ret_obj
= DECL_RESULT (current_function_decl
);
7545 /* Get the GCC tree for the expression to be returned. */
7546 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
7548 /* Do not remove the padding from GNU_RET_VAL if the inner type is
7549 self-referential since we want to allocate the fixed size. */
7550 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
7551 && type_is_padding_self_referential
7552 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
7553 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
7555 /* If the function returns by direct reference, return a pointer
7556 to the return value. */
7557 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
)
7558 || By_Ref (gnat_node
))
7559 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
7561 /* Otherwise, if it returns an unconstrained array, we have to
7562 allocate a new version of the result and return it. */
7563 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
))
7565 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
7567 /* And find out whether this is a candidate for Named Return
7568 Value. If so, record it. */
7571 && !TYPE_CI_CO_LIST (gnu_subprog_type
))
7573 tree ret_val
= gnu_ret_val
;
7575 /* Strip useless conversions around the return value. */
7576 if (gnat_useless_type_conversion (ret_val
))
7577 ret_val
= TREE_OPERAND (ret_val
, 0);
7579 /* Strip unpadding around the return value. */
7580 if (TREE_CODE (ret_val
) == COMPONENT_REF
7581 && TYPE_IS_PADDING_P
7582 (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
7583 ret_val
= TREE_OPERAND (ret_val
, 0);
7585 /* Now apply the test to the return value. */
7586 if (return_value_ok_for_nrv_p (NULL_TREE
, ret_val
))
7588 if (!f_named_ret_val
)
7589 f_named_ret_val
= BITMAP_GGC_ALLOC ();
7590 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
7592 f_gnat_ret
= gnat_node
;
7596 gnu_ret_val
= build_allocator (TREE_TYPE (gnu_ret_val
),
7598 TREE_TYPE (gnu_ret_obj
),
7599 Procedure_To_Call (gnat_node
),
7600 Storage_Pool (gnat_node
),
7604 /* Otherwise, if it returns by invisible reference, dereference
7605 the pointer it is passed using the type of the return value
7606 and build the copy operation manually. This ensures that we
7607 don't copy too much data, for example if the return type is
7608 unconstrained with a maximum size. */
7609 else if (TREE_ADDRESSABLE (gnu_subprog_type
))
7612 = build_unary_op (INDIRECT_REF
, TREE_TYPE (gnu_ret_val
),
7614 gnu_result
= build2 (INIT_EXPR
, void_type_node
,
7615 gnu_ret_deref
, gnu_ret_val
);
7616 add_stmt_with_node (gnu_result
, gnat_node
);
7617 gnu_ret_val
= NULL_TREE
;
7622 gnu_ret_obj
= gnu_ret_val
= NULL_TREE
;
7624 /* If we have a return label defined, convert this into a branch to
7625 that label. The return proper will be handled elsewhere. */
7626 if (gnu_return_label_stack
->last ())
7629 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_ret_obj
,
7632 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
7633 gnu_return_label_stack
->last ());
7635 /* When not optimizing, make sure the return is preserved. */
7636 if (!optimize
&& Comes_From_Source (gnat_node
))
7637 DECL_ARTIFICIAL (gnu_return_label_stack
->last ()) = 0;
7640 /* Otherwise, build a regular return. */
7642 gnu_result
= build_return_expr (gnu_ret_obj
, gnu_ret_val
);
7646 case N_Goto_Statement
:
7647 gnu_expr
= gnat_to_gnu (Name (gnat_node
));
7648 gnu_result
= build1 (GOTO_EXPR
, void_type_node
, gnu_expr
);
7649 TREE_USED (gnu_expr
) = 1;
7652 /***************************/
7653 /* Chapter 6: Subprograms */
7654 /***************************/
7656 case N_Subprogram_Declaration
:
7657 /* Unless there is a freeze node, declare the entity. We consider
7658 this a definition even though we're not generating code for the
7659 subprogram because we will be making the corresponding GCC node.
7660 When there is a freeze node, it is considered the definition of
7661 the subprogram and we do nothing until after it is encountered.
7662 That's an efficiency issue: the types involved in the profile
7663 are far more likely to be frozen between the declaration and
7664 the freeze node than before the declaration, so we save some
7665 updates of the GCC node by waiting until the freeze node.
7666 The counterpart is that we assume that there is no reference
7667 to the subprogram between the declaration and the freeze node
7668 in the expanded code; otherwise, it will be interpreted as an
7669 external reference and very likely give rise to a link failure. */
7670 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
7671 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
7673 gnu_result
= alloc_stmt_list ();
7676 case N_Abstract_Subprogram_Declaration
:
7677 /* This subprogram doesn't exist for code generation purposes, but we
7678 have to elaborate the types of any parameters and result, unless
7679 they are imported types (nothing to generate in this case).
7681 The parameter list may contain types with freeze nodes, e.g. not null
7682 subtypes, so the subprogram itself may carry a freeze node, in which
7683 case its elaboration must be deferred. */
7685 /* Process the parameter types first. */
7686 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
7688 = First_Formal_With_Extras
7689 (Defining_Entity (Specification (gnat_node
)));
7690 Present (gnat_temp
);
7691 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
7692 if (Is_Itype (Etype (gnat_temp
))
7693 && !From_Limited_With (Etype (gnat_temp
)))
7694 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, false);
7696 /* Then the result type, set to Standard_Void_Type for procedures. */
7698 Entity_Id gnat_temp_type
7699 = Etype (Defining_Entity (Specification (gnat_node
)));
7701 if (Is_Itype (gnat_temp_type
) && !From_Limited_With (gnat_temp_type
))
7702 gnat_to_gnu_entity (Etype (gnat_temp_type
), NULL_TREE
, false);
7705 gnu_result
= alloc_stmt_list ();
7708 case N_Defining_Program_Unit_Name
:
7709 /* For a child unit identifier go up a level to get the specification.
7710 We get this when we try to find the spec of a child unit package
7711 that is the compilation unit being compiled. */
7712 gnu_result
= gnat_to_gnu (Parent (gnat_node
));
7715 case N_Subprogram_Body
:
7716 Subprogram_Body_to_gnu (gnat_node
);
7717 gnu_result
= alloc_stmt_list ();
7720 case N_Function_Call
:
7721 case N_Procedure_Call_Statement
:
7722 gnu_result
= Call_to_gnu (gnat_node
, &gnu_result_type
, NULL_TREE
,
7726 /************************/
7727 /* Chapter 7: Packages */
7728 /************************/
7730 case N_Package_Declaration
:
7731 gnu_result
= gnat_to_gnu (Specification (gnat_node
));
7734 case N_Package_Specification
:
7736 start_stmt_group ();
7737 process_decls (Visible_Declarations (gnat_node
),
7738 Private_Declarations (gnat_node
), Empty
, true, true);
7739 gnu_result
= end_stmt_group ();
7742 case N_Package_Body
:
7744 /* If this is the body of a generic package - do nothing. */
7745 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
7747 gnu_result
= alloc_stmt_list ();
7751 start_stmt_group ();
7752 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7754 if (Present (Handled_Statement_Sequence (gnat_node
)))
7755 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
7757 gnu_result
= end_stmt_group ();
7760 /********************************/
7761 /* Chapter 8: Visibility Rules */
7762 /********************************/
7764 case N_Use_Package_Clause
:
7765 case N_Use_Type_Clause
:
7766 /* Nothing to do here - but these may appear in list of declarations. */
7767 gnu_result
= alloc_stmt_list ();
7770 /*********************/
7771 /* Chapter 9: Tasks */
7772 /*********************/
7774 case N_Protected_Type_Declaration
:
7775 gnu_result
= alloc_stmt_list ();
7778 case N_Single_Task_Declaration
:
7779 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, true);
7780 gnu_result
= alloc_stmt_list ();
7783 /*********************************************************/
7784 /* Chapter 10: Program Structure and Compilation Issues */
7785 /*********************************************************/
7787 case N_Compilation_Unit
:
7788 /* This is not called for the main unit on which gigi is invoked. */
7789 Compilation_Unit_to_gnu (gnat_node
);
7790 gnu_result
= alloc_stmt_list ();
7794 gnu_result
= gnat_to_gnu (Proper_Body (gnat_node
));
7798 case N_Protected_Body
:
7800 /* These nodes should only be present when annotating types. */
7801 gcc_assert (type_annotate_only
);
7802 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7803 gnu_result
= alloc_stmt_list ();
7806 case N_Subprogram_Body_Stub
:
7807 case N_Package_Body_Stub
:
7808 case N_Protected_Body_Stub
:
7809 case N_Task_Body_Stub
:
7810 /* Simply process whatever unit is being inserted. */
7811 if (Present (Library_Unit (gnat_node
)))
7812 gnu_result
= gnat_to_gnu (Unit (Library_Unit (gnat_node
)));
7815 gcc_assert (type_annotate_only
);
7816 gnu_result
= alloc_stmt_list ();
7820 /***************************/
7821 /* Chapter 11: Exceptions */
7822 /***************************/
7824 case N_Handled_Sequence_Of_Statements
:
7825 /* If there is an At_End procedure attached to this node, and the EH
7826 mechanism is front-end, we must have at least a corresponding At_End
7827 handler, unless the No_Exception_Handlers restriction is set. */
7828 gcc_assert (type_annotate_only
7829 || !Front_End_Exceptions ()
7830 || No (At_End_Proc (gnat_node
))
7831 || Present (Exception_Handlers (gnat_node
))
7832 || No_Exception_Handlers_Set ());
7834 gnu_result
= Handled_Sequence_Of_Statements_to_gnu (gnat_node
);
7837 case N_Exception_Handler
:
7838 if (Back_End_Exceptions ())
7839 gnu_result
= Exception_Handler_to_gnu_gcc (gnat_node
);
7840 else if (Exception_Mechanism
== Front_End_SJLJ
)
7841 gnu_result
= Exception_Handler_to_gnu_fe_sjlj (gnat_node
);
7846 case N_Raise_Statement
:
7847 /* Only for reraise in back-end exceptions mode. */
7848 gcc_assert (No (Name (gnat_node
)) && Back_End_Exceptions ());
7850 start_stmt_group ();
7852 add_stmt_with_node (build_call_n_expr (reraise_zcx_decl
, 1,
7853 gnu_incoming_exc_ptr
),
7856 gnu_result
= end_stmt_group ();
7859 case N_Push_Constraint_Error_Label
:
7860 gnu_constraint_error_label_stack
.safe_push (Exception_Label (gnat_node
));
7863 case N_Push_Storage_Error_Label
:
7864 gnu_storage_error_label_stack
.safe_push (Exception_Label (gnat_node
));
7867 case N_Push_Program_Error_Label
:
7868 gnu_program_error_label_stack
.safe_push (Exception_Label (gnat_node
));
7871 case N_Pop_Constraint_Error_Label
:
7872 gnat_temp
= gnu_constraint_error_label_stack
.pop ();
7873 if (Present (gnat_temp
)
7874 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
7875 Warn_If_No_Local_Raise (gnat_temp
);
7878 case N_Pop_Storage_Error_Label
:
7879 gnat_temp
= gnu_storage_error_label_stack
.pop ();
7880 if (Present (gnat_temp
)
7881 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
7882 Warn_If_No_Local_Raise (gnat_temp
);
7885 case N_Pop_Program_Error_Label
:
7886 gnat_temp
= gnu_program_error_label_stack
.pop ();
7887 if (Present (gnat_temp
)
7888 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
7889 Warn_If_No_Local_Raise (gnat_temp
);
7892 /******************************/
7893 /* Chapter 12: Generic Units */
7894 /******************************/
7896 case N_Generic_Function_Renaming_Declaration
:
7897 case N_Generic_Package_Renaming_Declaration
:
7898 case N_Generic_Procedure_Renaming_Declaration
:
7899 case N_Generic_Package_Declaration
:
7900 case N_Generic_Subprogram_Declaration
:
7901 case N_Package_Instantiation
:
7902 case N_Procedure_Instantiation
:
7903 case N_Function_Instantiation
:
7904 /* These nodes can appear on a declaration list but there is nothing to
7905 to be done with them. */
7906 gnu_result
= alloc_stmt_list ();
7909 /**************************************************/
7910 /* Chapter 13: Representation Clauses and */
7911 /* Implementation-Dependent Features */
7912 /**************************************************/
7914 case N_Attribute_Definition_Clause
:
7915 gnu_result
= alloc_stmt_list ();
7917 /* The only one we need to deal with is 'Address since, for the others,
7918 the front-end puts the information elsewhere. */
7919 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
)
7922 /* And we only deal with 'Address if the object has a Freeze node. */
7923 gnat_temp
= Entity (Name (gnat_node
));
7924 if (Freeze_Node (gnat_temp
))
7926 tree gnu_address
= gnat_to_gnu (Expression (gnat_node
)), gnu_temp
;
7928 /* Get the value to use as the address and save it as the equivalent
7929 for the object; when it is frozen, gnat_to_gnu_entity will do the
7930 right thing. For a subprogram, put the naked address but build a
7931 meaningfull expression for an object in case its address is taken
7932 before the Freeze node is encountered; this can happen if the type
7933 of the object is limited and it is initialized with the result of
7935 if (Is_Subprogram (gnat_temp
))
7936 gnu_temp
= gnu_address
;
7939 tree gnu_type
= gnat_to_gnu_type (Etype (gnat_temp
));
7940 /* Drop atomic and volatile qualifiers for the expression. */
7941 gnu_type
= TYPE_MAIN_VARIANT (gnu_type
);
7943 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
7944 gnu_address
= convert (gnu_type
, gnu_address
);
7946 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_address
);
7949 save_gnu_tree (gnat_temp
, gnu_temp
, true);
7953 case N_Enumeration_Representation_Clause
:
7954 case N_Record_Representation_Clause
:
7956 /* We do nothing with these. SEM puts the information elsewhere. */
7957 gnu_result
= alloc_stmt_list ();
7960 case N_Code_Statement
:
7961 if (!type_annotate_only
)
7963 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
7964 tree gnu_inputs
= NULL_TREE
, gnu_outputs
= NULL_TREE
;
7965 tree gnu_clobbers
= NULL_TREE
, tail
;
7966 bool allows_mem
, allows_reg
, fake
;
7967 int ninputs
, noutputs
, i
;
7968 const char **oconstraints
;
7969 const char *constraint
;
7972 /* First retrieve the 3 operand lists built by the front-end. */
7973 Setup_Asm_Outputs (gnat_node
);
7974 while (Present (gnat_temp
= Asm_Output_Variable ()))
7976 tree gnu_value
= gnat_to_gnu (gnat_temp
);
7977 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
7978 (Asm_Output_Constraint ()));
7980 gnu_outputs
= tree_cons (gnu_constr
, gnu_value
, gnu_outputs
);
7984 Setup_Asm_Inputs (gnat_node
);
7985 while (Present (gnat_temp
= Asm_Input_Value ()))
7987 tree gnu_value
= gnat_to_gnu (gnat_temp
);
7988 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
7989 (Asm_Input_Constraint ()));
7991 gnu_inputs
= tree_cons (gnu_constr
, gnu_value
, gnu_inputs
);
7995 Clobber_Setup (gnat_node
);
7996 while ((clobber
= Clobber_Get_Next ()))
7998 = tree_cons (NULL_TREE
,
7999 build_string (strlen (clobber
) + 1, clobber
),
8002 /* Then perform some standard checking and processing on the
8003 operands. In particular, mark them addressable if needed. */
8004 gnu_outputs
= nreverse (gnu_outputs
);
8005 noutputs
= list_length (gnu_outputs
);
8006 gnu_inputs
= nreverse (gnu_inputs
);
8007 ninputs
= list_length (gnu_inputs
);
8008 oconstraints
= XALLOCAVEC (const char *, noutputs
);
8010 for (i
= 0, tail
= gnu_outputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
8012 tree output
= TREE_VALUE (tail
);
8014 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
8015 oconstraints
[i
] = constraint
;
8017 if (parse_output_constraint (&constraint
, i
, ninputs
, noutputs
,
8018 &allows_mem
, &allows_reg
, &fake
))
8020 /* If the operand is going to end up in memory,
8021 mark it addressable. Note that we don't test
8022 allows_mem like in the input case below; this
8023 is modeled on the C front-end. */
8026 output
= remove_conversions (output
, false);
8027 if (TREE_CODE (output
) == CONST_DECL
8028 && DECL_CONST_CORRESPONDING_VAR (output
))
8029 output
= DECL_CONST_CORRESPONDING_VAR (output
);
8030 if (!gnat_mark_addressable (output
))
8031 output
= error_mark_node
;
8035 output
= error_mark_node
;
8037 TREE_VALUE (tail
) = output
;
8040 for (i
= 0, tail
= gnu_inputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
8042 tree input
= TREE_VALUE (tail
);
8044 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
8046 if (parse_input_constraint (&constraint
, i
, ninputs
, noutputs
,
8048 &allows_mem
, &allows_reg
))
8050 /* If the operand is going to end up in memory,
8051 mark it addressable. */
8052 if (!allows_reg
&& allows_mem
)
8054 input
= remove_conversions (input
, false);
8055 if (TREE_CODE (input
) == CONST_DECL
8056 && DECL_CONST_CORRESPONDING_VAR (input
))
8057 input
= DECL_CONST_CORRESPONDING_VAR (input
);
8058 if (!gnat_mark_addressable (input
))
8059 input
= error_mark_node
;
8063 input
= error_mark_node
;
8065 TREE_VALUE (tail
) = input
;
8068 gnu_result
= build5 (ASM_EXPR
, void_type_node
,
8069 gnu_template
, gnu_outputs
,
8070 gnu_inputs
, gnu_clobbers
, NULL_TREE
);
8071 ASM_VOLATILE_P (gnu_result
) = Is_Asm_Volatile (gnat_node
);
8074 gnu_result
= alloc_stmt_list ();
8082 /* Markers are created by the ABE mechanism to capture information which
8083 is either unavailable of expensive to recompute. Markers do not have
8084 and runtime semantics, and should be ignored. */
8087 case N_Variable_Reference_Marker
:
8088 gnu_result
= alloc_stmt_list ();
8091 case N_Expression_With_Actions
:
8092 /* This construct doesn't define a scope so we don't push a binding
8093 level around the statement list, but we wrap it in a SAVE_EXPR to
8094 protect it from unsharing. Elaborate the expression as part of the
8095 same statement group as the actions so that the type declaration
8096 gets inserted there as well. This ensures that the type elaboration
8097 code is issued past the actions computing values on which it might
8099 start_stmt_group ();
8100 add_stmt_list (Actions (gnat_node
));
8101 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
8102 gnu_result
= end_stmt_group ();
8104 gnu_result
= build1 (SAVE_EXPR
, void_type_node
, gnu_result
);
8105 TREE_SIDE_EFFECTS (gnu_result
) = 1;
8108 = build_compound_expr (TREE_TYPE (gnu_expr
), gnu_result
, gnu_expr
);
8109 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
8112 case N_Freeze_Entity
:
8113 start_stmt_group ();
8114 process_freeze_entity (gnat_node
);
8115 process_decls (Actions (gnat_node
), Empty
, Empty
, true, true);
8116 gnu_result
= end_stmt_group ();
8119 case N_Freeze_Generic_Entity
:
8120 gnu_result
= alloc_stmt_list ();
8123 case N_Itype_Reference
:
8124 if (!present_gnu_tree (Itype (gnat_node
)))
8125 process_type (Itype (gnat_node
));
8126 gnu_result
= alloc_stmt_list ();
8129 case N_Free_Statement
:
8130 gnat_temp
= Expression (gnat_node
);
8132 if (!type_annotate_only
)
8134 tree gnu_ptr
, gnu_ptr_type
, gnu_obj_type
, gnu_actual_obj_type
;
8136 const Entity_Id gnat_desig_type
8137 = Designated_Type (Underlying_Type (Etype (gnat_temp
)));
8139 /* Make sure the designated type is complete before dereferencing,
8140 in case it is a Taft Amendment type. */
8141 (void) gnat_to_gnu_entity (gnat_desig_type
, NULL_TREE
, false);
8143 gnu_ptr
= gnat_to_gnu (gnat_temp
);
8144 gnu_ptr_type
= TREE_TYPE (gnu_ptr
);
8146 /* If this is a thin pointer, we must first dereference it to create
8147 a fat pointer, then go back below to a thin pointer. The reason
8148 for this is that we need to have a fat pointer someplace in order
8149 to properly compute the size. */
8150 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
8151 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
8152 build_unary_op (INDIRECT_REF
, NULL_TREE
,
8155 /* If this is a fat pointer, the object must have been allocated with
8156 the template in front of the array. So pass the template address,
8157 and get the total size; do it by converting to a thin pointer. */
8158 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
8160 = convert (build_pointer_type
8161 (TYPE_OBJECT_RECORD_TYPE
8162 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
8165 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
8167 /* If this is a thin pointer, the object must have been allocated with
8168 the template in front of the array. So pass the template address,
8169 and get the total size. */
8170 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
8172 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
8174 fold_build1 (NEGATE_EXPR
, sizetype
,
8177 TYPE_FIELDS ((gnu_obj_type
)))));
8179 /* If we have a special dynamic constrained subtype on the node, use
8180 it to compute the size; otherwise, use the designated subtype. */
8181 if (Present (Actual_Designated_Subtype (gnat_node
)))
8184 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node
));
8186 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
))
8188 = build_unc_object_type_from_ptr (gnu_ptr_type
,
8189 gnu_actual_obj_type
,
8190 get_identifier ("DEALLOC"),
8194 gnu_actual_obj_type
= gnu_obj_type
;
8196 tree gnu_size
= TYPE_SIZE_UNIT (gnu_actual_obj_type
);
8197 gnu_size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size
, gnu_ptr
);
8200 = build_call_alloc_dealloc (gnu_ptr
, gnu_size
, gnu_obj_type
,
8201 Procedure_To_Call (gnat_node
),
8202 Storage_Pool (gnat_node
),
8207 case N_Raise_Constraint_Error
:
8208 case N_Raise_Program_Error
:
8209 case N_Raise_Storage_Error
:
8210 if (type_annotate_only
)
8211 gnu_result
= alloc_stmt_list ();
8213 gnu_result
= Raise_Error_to_gnu (gnat_node
, &gnu_result_type
);
8216 case N_Validate_Unchecked_Conversion
:
8217 /* The only validation we currently do on an unchecked conversion is
8218 that of aliasing assumptions. */
8219 if (flag_strict_aliasing
)
8220 gnat_validate_uc_list
.safe_push (gnat_node
);
8221 gnu_result
= alloc_stmt_list ();
8224 case N_Function_Specification
:
8225 case N_Procedure_Specification
:
8227 case N_Component_Association
:
8228 /* These nodes should only be present when annotating types. */
8229 gcc_assert (type_annotate_only
);
8230 gnu_result
= alloc_stmt_list ();
8234 /* Other nodes are not supposed to reach here. */
8238 /* If we pushed the processing of the elaboration routine, pop it back. */
8239 if (went_into_elab_proc
)
8240 current_function_decl
= NULL_TREE
;
8242 /* When not optimizing, turn boolean rvalues B into B != false tests
8243 so that we can put the location information of the reference to B on
8244 the inequality operator for better debug info. */
8246 && TREE_CODE (gnu_result
) != INTEGER_CST
8247 && TREE_CODE (gnu_result
) != TYPE_DECL
8248 && (kind
== N_Identifier
8249 || kind
== N_Expanded_Name
8250 || kind
== N_Explicit_Dereference
8251 || kind
== N_Indexed_Component
8252 || kind
== N_Selected_Component
)
8253 && TREE_CODE (get_base_type (gnu_result_type
)) == BOOLEAN_TYPE
8254 && Nkind (Parent (gnat_node
)) != N_Attribute_Reference
8255 && Nkind (Parent (gnat_node
)) != N_Variant_Part
8256 && !lvalue_required_p (gnat_node
, gnu_result_type
, false, false))
8259 = build_binary_op (NE_EXPR
, gnu_result_type
,
8260 convert (gnu_result_type
, gnu_result
),
8261 convert (gnu_result_type
, boolean_false_node
));
8262 if (TREE_CODE (gnu_result
) != INTEGER_CST
)
8263 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
8266 /* Set the location information on the result if it's not a simple name
8267 or something that contains a simple name, for example a tag, because
8268 we don"t want all the references to get the location of the first use.
8269 Note that we may have no result if we tried to build a CALL_EXPR node
8270 to a procedure with no side-effects and optimization is enabled. */
8271 else if (kind
!= N_Identifier
8272 && !(kind
== N_Selected_Component
8273 && Chars (Selector_Name (gnat_node
)) == Name_uTag
)
8275 && EXPR_P (gnu_result
))
8276 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
8278 /* If we're supposed to return something of void_type, it means we have
8279 something we're elaborating for effect, so just return. */
8280 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
8283 /* If the result is a constant that overflowed, raise Constraint_Error. */
8284 if (TREE_CODE (gnu_result
) == INTEGER_CST
&& TREE_OVERFLOW (gnu_result
))
8286 post_error ("?`Constraint_Error` will be raised at run time", gnat_node
);
8288 = build1 (NULL_EXPR
, gnu_result_type
,
8289 build_call_raise (CE_Overflow_Check_Failed
, gnat_node
,
8290 N_Raise_Constraint_Error
));
8293 /* If the result has side-effects and is of an unconstrained type, protect
8294 the expression in case it will be referenced multiple times, i.e. for
8295 its value and to compute the size of an object. But do it neither for
8296 an object nor a renaming declaration, nor a return statement of a call
8297 to a function that returns an unconstrained record type with default
8298 discriminant, because there is no size to be computed in these cases
8299 and this will create a useless temporary. We must do this before any
8301 if (TREE_SIDE_EFFECTS (gnu_result
)
8302 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
8303 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
)))
8304 && !(TREE_CODE (gnu_result
) == CALL_EXPR
8305 && type_is_padding_self_referential (TREE_TYPE (gnu_result
))
8306 && (Nkind (Parent (gnat_node
)) == N_Object_Declaration
8307 || Nkind (Parent (gnat_node
)) == N_Object_Renaming_Declaration
8308 || Nkind (Parent (gnat_node
)) == N_Simple_Return_Statement
)))
8309 gnu_result
= gnat_protect_expr (gnu_result
);
8311 /* Now convert the result to the result type, unless we are in one of the
8314 1. If this is the LHS of an assignment or an actual parameter of a
8315 call, return the result almost unmodified since the RHS will have
8316 to be converted to our type in that case, unless the result type
8317 has a simpler size or for array types because this size might be
8318 changed in-between. Likewise if there is just a no-op unchecked
8319 conversion in-between. Similarly, don't convert integral types
8320 that are the operands of an unchecked conversion since we need
8321 to ignore those conversions (for 'Valid).
8323 2. If we have a label (which doesn't have any well-defined type), a
8324 field or an error, return the result almost unmodified. Similarly,
8325 if the two types are record types with the same name, don't convert.
8326 This will be the case when we are converting from a packable version
8327 of a type to its original type and we need those conversions to be
8328 NOPs in order for assignments into these types to work properly.
8330 3. If the type is void or if we have no result, return error_mark_node
8331 to show we have no result.
8333 4. If this is a call to a function that returns with variable size and
8334 the call is used as the expression in either an object or a renaming
8335 declaration, return the result unmodified because we want to use the
8336 return slot optimization in this case.
8338 5. If this is a reference to an unconstrained array which is used as the
8339 prefix of an attribute reference that requires an lvalue, return the
8340 result unmodified because we want to return the original bounds.
8342 6. Finally, if the type of the result is already correct. */
8344 if (Present (Parent (gnat_node
))
8345 && (lhs_or_actual_p (gnat_node
)
8346 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
8347 && unchecked_conversion_nop (Parent (gnat_node
)))
8348 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
8349 && !AGGREGATE_TYPE_P (gnu_result_type
)
8350 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))))
8351 && !(TYPE_SIZE (gnu_result_type
)
8352 && TYPE_SIZE (TREE_TYPE (gnu_result
))
8353 && AGGREGATE_TYPE_P (gnu_result_type
)
8354 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))
8355 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
8356 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
8358 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
8359 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
8360 && (CONTAINS_PLACEHOLDER_P
8361 (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
8362 || (TREE_CODE (gnu_result_type
) == ARRAY_TYPE
8363 && TREE_CODE (TREE_TYPE (gnu_result
)) == ARRAY_TYPE
))
8364 && !(TREE_CODE (gnu_result_type
) == RECORD_TYPE
8365 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type
))))
8367 /* Remove padding only if the inner object is of self-referential
8368 size: in that case it must be an object of unconstrained type
8369 with a default discriminant and we want to avoid copying too
8370 much data. But do not remove it if it is already too small. */
8371 if (type_is_padding_self_referential (TREE_TYPE (gnu_result
))
8372 && !(TREE_CODE (gnu_result
) == COMPONENT_REF
8373 && DECL_BIT_FIELD (TREE_OPERAND (gnu_result
, 1))))
8374 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
8378 else if (TREE_CODE (gnu_result
) == LABEL_DECL
8379 || TREE_CODE (gnu_result
) == FIELD_DECL
8380 || TREE_CODE (gnu_result
) == ERROR_MARK
8381 || (TYPE_NAME (gnu_result_type
)
8382 == TYPE_NAME (TREE_TYPE (gnu_result
))
8383 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
8384 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
))
8386 /* Remove any padding. */
8387 gnu_result
= maybe_padded_object (gnu_result
);
8390 else if (gnu_result
== error_mark_node
|| gnu_result_type
== void_type_node
)
8391 gnu_result
= error_mark_node
;
8393 else if (TREE_CODE (gnu_result
) == CALL_EXPR
8394 && Present (Parent (gnat_node
))
8395 && (Nkind (Parent (gnat_node
)) == N_Object_Declaration
8396 || Nkind (Parent (gnat_node
)) == N_Object_Renaming_Declaration
)
8397 && return_type_with_variable_size_p (TREE_TYPE (gnu_result
)))
8400 else if (TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
8401 && Present (Parent (gnat_node
))
8402 && Nkind (Parent (gnat_node
)) == N_Attribute_Reference
8403 && lvalue_required_for_attribute_p (Parent (gnat_node
)))
8406 else if (TREE_TYPE (gnu_result
) != gnu_result_type
)
8407 gnu_result
= convert (gnu_result_type
, gnu_result
);
8409 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
8410 while ((TREE_CODE (gnu_result
) == NOP_EXPR
8411 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
8412 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
8413 gnu_result
= TREE_OPERAND (gnu_result
, 0);
8418 /* Similar to gnat_to_gnu, but discard any object that might be created in
8419 the course of the translation of GNAT_NODE, which must be an "external"
8420 expression in the sense that it will be elaborated elsewhere. */
8423 gnat_to_gnu_external (Node_Id gnat_node
)
8425 const int save_force_global
= force_global
;
8426 bool went_into_elab_proc
= false;
8428 /* Force the local context and create a fake scope that we zap
8429 at the end so declarations will not be stuck either in the
8430 global varpool or in the current scope. */
8431 if (!current_function_decl
)
8433 current_function_decl
= get_elaboration_procedure ();
8434 went_into_elab_proc
= true;
8439 tree gnu_result
= gnat_to_gnu (gnat_node
);
8442 force_global
= save_force_global
;
8443 if (went_into_elab_proc
)
8444 current_function_decl
= NULL_TREE
;
8446 /* Do not import locations from external units. */
8447 if (gnu_result
&& EXPR_P (gnu_result
))
8448 SET_EXPR_LOCATION (gnu_result
, UNKNOWN_LOCATION
);
8453 /* Return true if the statement list STMT_LIST is empty. */
8456 empty_stmt_list_p (tree stmt_list
)
8458 tree_stmt_iterator tsi
;
8460 for (tsi
= tsi_start (stmt_list
); !tsi_end_p (tsi
); tsi_next (&tsi
))
8462 tree stmt
= tsi_stmt (tsi
);
8464 /* Anything else than an empty STMT_STMT counts as something. */
8465 if (TREE_CODE (stmt
) != STMT_STMT
|| STMT_STMT_STMT (stmt
))
8472 /* Record the current code position in GNAT_NODE. */
8475 record_code_position (Node_Id gnat_node
)
8477 tree stmt_stmt
= build1 (STMT_STMT
, void_type_node
, NULL_TREE
);
8479 add_stmt_with_node (stmt_stmt
, gnat_node
);
8480 save_gnu_tree (gnat_node
, stmt_stmt
, true);
8483 /* Insert the code for GNAT_NODE at the position saved for that node. */
8486 insert_code_for (Node_Id gnat_node
)
8488 tree code
= gnat_to_gnu (gnat_node
);
8490 /* It's too late to remove the STMT_STMT itself at this point. */
8491 if (!empty_stmt_list_p (code
))
8492 STMT_STMT_STMT (get_gnu_tree (gnat_node
)) = code
;
8494 save_gnu_tree (gnat_node
, NULL_TREE
, true);
8497 /* Start a new statement group chained to the previous group. */
8500 start_stmt_group (void)
8502 struct stmt_group
*group
= stmt_group_free_list
;
8504 /* First see if we can get one from the free list. */
8506 stmt_group_free_list
= group
->previous
;
8508 group
= ggc_alloc
<stmt_group
> ();
8510 group
->previous
= current_stmt_group
;
8511 group
->stmt_list
= group
->block
= group
->cleanups
= NULL_TREE
;
8512 current_stmt_group
= group
;
8515 /* Add GNU_STMT to the current statement group. If it is an expression with
8516 no effects, it is ignored. */
8519 add_stmt (tree gnu_stmt
)
8521 append_to_statement_list (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
8524 /* Similar, but the statement is always added, regardless of side-effects. */
8527 add_stmt_force (tree gnu_stmt
)
8529 append_to_statement_list_force (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
8532 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
8535 add_stmt_with_node (tree gnu_stmt
, Node_Id gnat_node
)
8537 if (Present (gnat_node
))
8538 set_expr_location_from_node (gnu_stmt
, gnat_node
);
8539 add_stmt (gnu_stmt
);
8542 /* Similar, but the statement is always added, regardless of side-effects. */
8545 add_stmt_with_node_force (tree gnu_stmt
, Node_Id gnat_node
)
8547 if (Present (gnat_node
))
8548 set_expr_location_from_node (gnu_stmt
, gnat_node
);
8549 add_stmt_force (gnu_stmt
);
8552 /* Add a declaration statement for GNU_DECL to the current statement group.
8553 Get the SLOC to be put onto the statement from GNAT_NODE. */
8556 add_decl_expr (tree gnu_decl
, Node_Id gnat_node
)
8558 tree type
= TREE_TYPE (gnu_decl
);
8559 tree gnu_stmt
, gnu_init
;
8561 /* If this is a variable that Gigi is to ignore, we may have been given
8562 an ERROR_MARK. So test for it. We also might have been given a
8563 reference for a renaming. So only do something for a decl. Also
8564 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
8565 if (!DECL_P (gnu_decl
)
8566 || (TREE_CODE (gnu_decl
) == TYPE_DECL
8567 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
))
8570 gnu_stmt
= build1 (DECL_EXPR
, void_type_node
, gnu_decl
);
8572 /* If we are external or global, we don't want to output the DECL_EXPR for
8573 this DECL node since we already have evaluated the expressions in the
8574 sizes and positions as globals and doing it again would be wrong. */
8575 if (DECL_EXTERNAL (gnu_decl
) || global_bindings_p ())
8577 /* Mark everything as used to prevent node sharing with subprograms.
8578 Note that walk_tree knows how to deal with TYPE_DECL, but neither
8579 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
8580 MARK_VISITED (gnu_stmt
);
8581 if (TREE_CODE (gnu_decl
) == VAR_DECL
8582 || TREE_CODE (gnu_decl
) == CONST_DECL
)
8584 MARK_VISITED (DECL_SIZE (gnu_decl
));
8585 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl
));
8586 MARK_VISITED (DECL_INITIAL (gnu_decl
));
8590 add_stmt_with_node (gnu_stmt
, gnat_node
);
8592 /* Mark our TYPE_ADA_SIZE field now since it will not be gimplified. */
8593 if (TREE_CODE (gnu_decl
) == TYPE_DECL
8594 && RECORD_OR_UNION_TYPE_P (type
)
8595 && !TYPE_FAT_POINTER_P (type
))
8596 MARK_VISITED (TYPE_ADA_SIZE (type
));
8598 /* If this is a variable and an initializer is attached to it, it must be
8599 valid for the context. Similar to init_const in create_var_decl. */
8600 if (TREE_CODE (gnu_decl
) == VAR_DECL
8601 && (gnu_init
= DECL_INITIAL (gnu_decl
))
8602 && (!gnat_types_compatible_p (type
, TREE_TYPE (gnu_init
))
8603 || (TREE_STATIC (gnu_decl
)
8604 && !initializer_constant_valid_p (gnu_init
,
8605 TREE_TYPE (gnu_init
)))))
8607 DECL_INITIAL (gnu_decl
) = NULL_TREE
;
8608 if (TREE_READONLY (gnu_decl
))
8610 TREE_READONLY (gnu_decl
) = 0;
8611 DECL_READONLY_ONCE_ELAB (gnu_decl
) = 1;
8614 /* Remove any padding so the assignment is done properly. */
8615 gnu_decl
= maybe_padded_object (gnu_decl
);
8617 gnu_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_decl
, gnu_init
);
8618 add_stmt_with_node (gnu_stmt
, gnat_node
);
8622 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
8625 mark_visited_r (tree
*tp
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
8629 if (TREE_VISITED (t
))
8632 /* Don't mark a dummy type as visited because we want to mark its sizes
8633 and fields once it's filled in. */
8634 else if (!TYPE_IS_DUMMY_P (t
))
8635 TREE_VISITED (t
) = 1;
8637 /* The test in gimplify_type_sizes is on the main variant. */
8639 TYPE_SIZES_GIMPLIFIED (TYPE_MAIN_VARIANT (t
)) = 1;
8644 /* Mark nodes rooted at T with TREE_VISITED and types as having their
8645 sized gimplified. We use this to indicate all variable sizes and
8646 positions in global types may not be shared by any subprogram. */
8649 mark_visited (tree t
)
8651 walk_tree (&t
, mark_visited_r
, NULL
, NULL
);
8654 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
8655 set its location to that of GNAT_NODE if present, but with column info
8656 cleared so that conditional branches generated as part of the cleanup
8657 code do not interfere with coverage analysis tools. */
8660 add_cleanup (tree gnu_cleanup
, Node_Id gnat_node
)
8662 if (Present (gnat_node
))
8663 set_expr_location_from_node (gnu_cleanup
, gnat_node
, true);
8665 /* An EH_ELSE_EXPR must be by itself, and that's all we need when we
8666 use it. The assert below makes sure that is so. Should we ever
8667 need more than that, we could combine EH_ELSE_EXPRs, and copy
8668 non-EH_ELSE_EXPR stmts into both cleanup paths of an
8670 if (TREE_CODE (gnu_cleanup
) == EH_ELSE_EXPR
)
8672 gcc_assert (!current_stmt_group
->cleanups
);
8673 current_stmt_group
->cleanups
= gnu_cleanup
;
8677 gcc_assert (!current_stmt_group
->cleanups
8678 || (TREE_CODE (current_stmt_group
->cleanups
)
8680 append_to_statement_list (gnu_cleanup
, ¤t_stmt_group
->cleanups
);
8684 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
8687 set_block_for_group (tree gnu_block
)
8689 gcc_assert (!current_stmt_group
->block
);
8690 current_stmt_group
->block
= gnu_block
;
8693 /* Return code corresponding to the current code group. It is normally
8694 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
8695 BLOCK or cleanups were set. */
8698 end_stmt_group (void)
8700 struct stmt_group
*group
= current_stmt_group
;
8701 tree gnu_retval
= group
->stmt_list
;
8703 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
8704 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
8705 make a BIND_EXPR. Note that we nest in that because the cleanup may
8706 reference variables in the block. */
8708 gnu_retval
= alloc_stmt_list ();
8710 if (group
->cleanups
)
8711 gnu_retval
= build2 (TRY_FINALLY_EXPR
, void_type_node
, gnu_retval
,
8714 if (current_stmt_group
->block
)
8715 gnu_retval
= build3 (BIND_EXPR
, void_type_node
, BLOCK_VARS (group
->block
),
8716 gnu_retval
, group
->block
);
8718 /* Remove this group from the stack and add it to the free list. */
8719 current_stmt_group
= group
->previous
;
8720 group
->previous
= stmt_group_free_list
;
8721 stmt_group_free_list
= group
;
8726 /* Return whether the current statement group may fall through. */
8729 stmt_group_may_fallthru (void)
8731 if (current_stmt_group
->stmt_list
)
8732 return block_may_fallthru (current_stmt_group
->stmt_list
);
8737 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
8741 add_stmt_list (List_Id gnat_list
)
8745 if (Present (gnat_list
))
8746 for (gnat_node
= First (gnat_list
); Present (gnat_node
);
8747 gnat_node
= Next (gnat_node
))
8748 add_stmt (gnat_to_gnu (gnat_node
));
8751 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
8752 If BINDING_P is true, push and pop a binding level around the list. */
8755 build_stmt_group (List_Id gnat_list
, bool binding_p
)
8757 start_stmt_group ();
8762 add_stmt_list (gnat_list
);
8767 return end_stmt_group ();
8770 /* Generate GIMPLE in place for the expression at *EXPR_P. */
8773 gnat_gimplify_expr (tree
*expr_p
, gimple_seq
*pre_p
,
8774 gimple_seq
*post_p ATTRIBUTE_UNUSED
)
8776 tree expr
= *expr_p
;
8777 tree type
= TREE_TYPE (expr
);
8780 if (IS_ADA_STMT (expr
))
8781 return gnat_gimplify_stmt (expr_p
);
8783 switch (TREE_CODE (expr
))
8786 /* If this is an aggregate type, build a null pointer of the appropriate
8787 type and dereference it. */
8788 if (AGGREGATE_TYPE_P (type
)
8789 || TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
8790 *expr_p
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
8791 convert (build_pointer_type (type
),
8792 integer_zero_node
));
8793 /* Otherwise, just make a VAR_DECL. */
8796 *expr_p
= create_tmp_var (type
, NULL
);
8797 TREE_NO_WARNING (*expr_p
) = 1;
8800 gimplify_and_add (TREE_OPERAND (expr
, 0), pre_p
);
8803 case UNCONSTRAINED_ARRAY_REF
:
8804 /* We should only do this if we are just elaborating for side-effects,
8805 but we can't know that yet. */
8806 *expr_p
= TREE_OPERAND (*expr_p
, 0);
8810 op
= TREE_OPERAND (expr
, 0);
8812 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
8813 is put into static memory. We know that it's going to be read-only
8814 given the semantics we have and it must be in static memory when the
8815 reference is in an elaboration procedure. */
8816 if (TREE_CODE (op
) == CONSTRUCTOR
&& TREE_CONSTANT (op
))
8818 tree addr
= build_fold_addr_expr (tree_output_constant_def (op
));
8819 *expr_p
= fold_convert (type
, addr
);
8823 /* Replace atomic loads with their first argument. That's necessary
8824 because the gimplifier would create a temporary otherwise. */
8825 if (TREE_SIDE_EFFECTS (op
))
8826 while (handled_component_p (op
) || CONVERT_EXPR_P (op
))
8828 tree inner
= TREE_OPERAND (op
, 0);
8829 if (TREE_CODE (inner
) == CALL_EXPR
&& call_is_atomic_load (inner
))
8831 tree t
= CALL_EXPR_ARG (inner
, 0);
8832 if (TREE_CODE (t
) == NOP_EXPR
)
8833 t
= TREE_OPERAND (t
, 0);
8834 if (TREE_CODE (t
) == ADDR_EXPR
)
8835 TREE_OPERAND (op
, 0) = TREE_OPERAND (t
, 0);
8837 TREE_OPERAND (op
, 0) = build_fold_indirect_ref (t
);
8843 return GS_UNHANDLED
;
8846 /* If we are passing a constant fat pointer CONSTRUCTOR, make sure it is
8847 put into static memory; this performs a restricted version of constant
8848 propagation on fat pointers in calls. But do not do it for strings to
8849 avoid blocking concatenation in the caller when it is inlined. */
8850 for (int i
= 0; i
< call_expr_nargs (expr
); i
++)
8852 tree arg
= *(CALL_EXPR_ARGP (expr
) + i
);
8854 if (TREE_CODE (arg
) == CONSTRUCTOR
8855 && TREE_CONSTANT (arg
)
8856 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (arg
)))
8858 tree t
= CONSTRUCTOR_ELT (arg
, 0)->value
;
8859 if (TREE_CODE (t
) == NOP_EXPR
)
8860 t
= TREE_OPERAND (t
, 0);
8861 if (TREE_CODE (t
) == ADDR_EXPR
)
8862 t
= TREE_OPERAND (t
, 0);
8863 if (TREE_CODE (t
) != STRING_CST
)
8864 *(CALL_EXPR_ARGP (expr
) + i
) = tree_output_constant_def (arg
);
8868 return GS_UNHANDLED
;
8870 case VIEW_CONVERT_EXPR
:
8871 op
= TREE_OPERAND (expr
, 0);
8873 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
8874 type to a scalar one, explicitly create the local temporary. That's
8875 required if the type is passed by reference. */
8876 if ((TREE_CODE (op
) == CONSTRUCTOR
|| TREE_CODE (op
) == CALL_EXPR
)
8877 && AGGREGATE_TYPE_P (TREE_TYPE (op
))
8878 && !AGGREGATE_TYPE_P (type
))
8880 tree mod
, new_var
= create_tmp_var_raw (TREE_TYPE (op
), "C");
8881 gimple_add_tmp_var (new_var
);
8883 mod
= build2 (INIT_EXPR
, TREE_TYPE (new_var
), new_var
, op
);
8884 gimplify_and_add (mod
, pre_p
);
8886 TREE_OPERAND (expr
, 0) = new_var
;
8890 return GS_UNHANDLED
;
8893 op
= DECL_EXPR_DECL (expr
);
8895 /* The expressions for the RM bounds must be gimplified to ensure that
8896 they are properly elaborated. See gimplify_decl_expr. */
8897 if ((TREE_CODE (op
) == TYPE_DECL
|| TREE_CODE (op
) == VAR_DECL
)
8898 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op
)))
8899 switch (TREE_CODE (TREE_TYPE (op
)))
8906 tree type
= TYPE_MAIN_VARIANT (TREE_TYPE (op
)), t
, val
;
8908 val
= TYPE_RM_MIN_VALUE (type
);
8911 gimplify_one_sizepos (&val
, pre_p
);
8912 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
8913 SET_TYPE_RM_MIN_VALUE (t
, val
);
8916 val
= TYPE_RM_MAX_VALUE (type
);
8919 gimplify_one_sizepos (&val
, pre_p
);
8920 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
8921 SET_TYPE_RM_MAX_VALUE (t
, val
);
8931 /* ... fall through ... */
8934 return GS_UNHANDLED
;
8938 /* Generate GIMPLE in place for the statement at *STMT_P. */
8940 static enum gimplify_status
8941 gnat_gimplify_stmt (tree
*stmt_p
)
8943 tree stmt
= *stmt_p
;
8945 switch (TREE_CODE (stmt
))
8948 *stmt_p
= STMT_STMT_STMT (stmt
);
8953 tree gnu_start_label
= create_artificial_label (input_location
);
8954 tree gnu_cond
= LOOP_STMT_COND (stmt
);
8955 tree gnu_update
= LOOP_STMT_UPDATE (stmt
);
8956 tree gnu_end_label
= LOOP_STMT_LABEL (stmt
);
8958 /* Build the condition expression from the test, if any. */
8961 /* Deal with the optimization hints. */
8962 if (LOOP_STMT_IVDEP (stmt
))
8963 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8964 build_int_cst (integer_type_node
,
8965 annot_expr_ivdep_kind
),
8967 if (LOOP_STMT_NO_UNROLL (stmt
))
8968 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8969 build_int_cst (integer_type_node
,
8970 annot_expr_unroll_kind
),
8972 if (LOOP_STMT_UNROLL (stmt
))
8973 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8974 build_int_cst (integer_type_node
,
8975 annot_expr_unroll_kind
),
8976 build_int_cst (NULL_TREE
, USHRT_MAX
));
8977 if (LOOP_STMT_NO_VECTOR (stmt
))
8978 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8979 build_int_cst (integer_type_node
,
8980 annot_expr_no_vector_kind
),
8982 if (LOOP_STMT_VECTOR (stmt
))
8983 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8984 build_int_cst (integer_type_node
,
8985 annot_expr_vector_kind
),
8989 = build3 (COND_EXPR
, void_type_node
, gnu_cond
, NULL_TREE
,
8990 build1 (GOTO_EXPR
, void_type_node
, gnu_end_label
));
8993 /* Set to emit the statements of the loop. */
8994 *stmt_p
= NULL_TREE
;
8996 /* We first emit the start label and then a conditional jump to the
8997 end label if there's a top condition, then the update if it's at
8998 the top, then the body of the loop, then a conditional jump to
8999 the end label if there's a bottom condition, then the update if
9000 it's at the bottom, and finally a jump to the start label and the
9001 definition of the end label. */
9002 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
9006 if (gnu_cond
&& !LOOP_STMT_BOTTOM_COND_P (stmt
))
9007 append_to_statement_list (gnu_cond
, stmt_p
);
9009 if (gnu_update
&& LOOP_STMT_TOP_UPDATE_P (stmt
))
9010 append_to_statement_list (gnu_update
, stmt_p
);
9012 append_to_statement_list (LOOP_STMT_BODY (stmt
), stmt_p
);
9014 if (gnu_cond
&& LOOP_STMT_BOTTOM_COND_P (stmt
))
9015 append_to_statement_list (gnu_cond
, stmt_p
);
9017 if (gnu_update
&& !LOOP_STMT_TOP_UPDATE_P (stmt
))
9018 append_to_statement_list (gnu_update
, stmt_p
);
9020 tree t
= build1 (GOTO_EXPR
, void_type_node
, gnu_start_label
);
9021 SET_EXPR_LOCATION (t
, DECL_SOURCE_LOCATION (gnu_end_label
));
9022 append_to_statement_list (t
, stmt_p
);
9024 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
9031 /* Build a statement to jump to the corresponding end label, then
9032 see if it needs to be conditional. */
9033 *stmt_p
= build1 (GOTO_EXPR
, void_type_node
, EXIT_STMT_LABEL (stmt
));
9034 if (EXIT_STMT_COND (stmt
))
9035 *stmt_p
= build3 (COND_EXPR
, void_type_node
,
9036 EXIT_STMT_COND (stmt
), *stmt_p
, alloc_stmt_list ());
9044 /* Force a reference to each of the entities in GNAT_PACKAGE recursively.
9046 This routine is exclusively called in type_annotate mode, to compute DDA
9047 information for types in withed units, for ASIS use. */
9050 elaborate_all_entities_for_package (Entity_Id gnat_package
)
9052 Entity_Id gnat_entity
;
9054 for (gnat_entity
= First_Entity (gnat_package
);
9055 Present (gnat_entity
);
9056 gnat_entity
= Next_Entity (gnat_entity
))
9058 const Entity_Kind kind
= Ekind (gnat_entity
);
9060 /* We are interested only in entities visible from the main unit. */
9061 if (!Is_Public (gnat_entity
))
9064 /* Skip stuff internal to the compiler. */
9065 if (Convention (gnat_entity
) == Convention_Intrinsic
)
9067 if (kind
== E_Operator
)
9069 if (IN (kind
, Subprogram_Kind
)
9070 && (Present (Alias (gnat_entity
))
9071 || Is_Intrinsic_Subprogram (gnat_entity
)))
9073 if (Is_Itype (gnat_entity
))
9076 /* Skip named numbers. */
9077 if (IN (kind
, Named_Kind
))
9080 /* Skip generic declarations. */
9081 if (IN (kind
, Generic_Unit_Kind
))
9084 /* Skip formal objects. */
9085 if (IN (kind
, Formal_Object_Kind
))
9088 /* Skip package bodies. */
9089 if (kind
== E_Package_Body
)
9092 /* Skip limited views that point back to the main unit. */
9093 if (IN (kind
, Incomplete_Kind
)
9094 && From_Limited_With (gnat_entity
)
9095 && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_entity
)))
9098 /* Skip types that aren't frozen. */
9099 if (IN (kind
, Type_Kind
) && !Is_Frozen (gnat_entity
))
9102 /* Recurse on real packages that aren't in the main unit. */
9103 if (kind
== E_Package
)
9105 if (No (Renamed_Entity (gnat_entity
))
9106 && !In_Extended_Main_Code_Unit (gnat_entity
))
9107 elaborate_all_entities_for_package (gnat_entity
);
9110 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
9114 /* Force a reference to each of the entities in packages withed by GNAT_NODE.
9115 Operate recursively but check that we aren't elaborating something more
9118 This routine is exclusively called in type_annotate mode, to compute DDA
9119 information for types in withed units, for ASIS use. */
9122 elaborate_all_entities (Node_Id gnat_node
)
9124 Entity_Id gnat_with_clause
;
9126 /* Process each unit only once. As we trace the context of all relevant
9127 units transitively, including generic bodies, we may encounter the
9128 same generic unit repeatedly. */
9129 if (!present_gnu_tree (gnat_node
))
9130 save_gnu_tree (gnat_node
, integer_zero_node
, true);
9132 /* Save entities in all context units. A body may have an implicit_with
9133 on its own spec, if the context includes a child unit, so don't save
9135 for (gnat_with_clause
= First (Context_Items (gnat_node
));
9136 Present (gnat_with_clause
);
9137 gnat_with_clause
= Next (gnat_with_clause
))
9138 if (Nkind (gnat_with_clause
) == N_With_Clause
9139 && !present_gnu_tree (Library_Unit (gnat_with_clause
))
9140 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
9142 Node_Id gnat_unit
= Library_Unit (gnat_with_clause
);
9143 Entity_Id gnat_entity
= Entity (Name (gnat_with_clause
));
9145 elaborate_all_entities (gnat_unit
);
9147 if (Ekind (gnat_entity
) == E_Package
9148 && No (Renamed_Entity (gnat_entity
)))
9149 elaborate_all_entities_for_package (gnat_entity
);
9151 else if (Ekind (gnat_entity
) == E_Generic_Package
)
9153 Node_Id gnat_body
= Corresponding_Body (Unit (gnat_unit
));
9155 /* Retrieve compilation unit node of generic body. */
9156 while (Present (gnat_body
)
9157 && Nkind (gnat_body
) != N_Compilation_Unit
)
9158 gnat_body
= Parent (gnat_body
);
9160 /* If body is available, elaborate its context. */
9161 if (Present (gnat_body
))
9162 elaborate_all_entities (gnat_body
);
9166 if (Nkind (Unit (gnat_node
)) == N_Package_Body
)
9167 elaborate_all_entities (Library_Unit (gnat_node
));
9170 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
9173 process_freeze_entity (Node_Id gnat_node
)
9175 const Entity_Id gnat_entity
= Entity (gnat_node
);
9176 const Entity_Kind kind
= Ekind (gnat_entity
);
9177 tree gnu_old
, gnu_new
;
9179 /* If this is a package, generate code for the package body, if any. */
9180 if (kind
== E_Package
)
9182 const Node_Id gnat_decl
= Parent (Declaration_Node (gnat_entity
));
9183 if (Present (Corresponding_Body (gnat_decl
)))
9184 insert_code_for (Parent (Corresponding_Body (gnat_decl
)));
9188 /* Don't do anything for class-wide types as they are always transformed
9189 into their root type. */
9190 if (kind
== E_Class_Wide_Type
)
9193 /* Check for an old definition if this isn't an object with address clause,
9194 since the saved GCC tree is the address expression in that case. */
9196 = present_gnu_tree (gnat_entity
) && No (Address_Clause (gnat_entity
))
9197 ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
9199 /* Don't do anything for subprograms that may have been elaborated before
9200 their freeze nodes. This can happen, for example, because of an inner
9201 call in an instance body or because of previous compilation of a spec
9202 for inlining purposes. */
9204 && ((TREE_CODE (gnu_old
) == FUNCTION_DECL
9205 && (kind
== E_Function
|| kind
== E_Procedure
))
9206 || (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_old
))
9207 && kind
== E_Subprogram_Type
)))
9210 /* If we have a non-dummy type old tree, we have nothing to do, except for
9211 aborting, since this node was never delayed as it should have been. We
9212 let this happen for concurrent types and their Corresponding_Record_Type,
9213 however, because each might legitimately be elaborated before its own
9214 freeze node, e.g. while processing the other. */
9216 && !(TREE_CODE (gnu_old
) == TYPE_DECL
9217 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
9219 gcc_assert (Is_Concurrent_Type (gnat_entity
)
9220 || (Is_Record_Type (gnat_entity
)
9221 && Is_Concurrent_Record_Type (gnat_entity
)));
9225 /* Reset the saved tree, if any, and elaborate the object or type for real.
9226 If there is a full view, elaborate it and use the result. And, if this
9227 is the root type of a class-wide type, reuse it for the latter. */
9230 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
9232 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9233 && Present (Full_View (gnat_entity
)))
9235 Entity_Id full_view
= Full_View (gnat_entity
);
9237 save_gnu_tree (full_view
, NULL_TREE
, false);
9239 if (Is_Private_Type (full_view
)
9240 && Present (Underlying_Full_View (full_view
)))
9242 full_view
= Underlying_Full_View (full_view
);
9243 save_gnu_tree (full_view
, NULL_TREE
, false);
9247 if (Is_Type (gnat_entity
)
9248 && Present (Class_Wide_Type (gnat_entity
))
9249 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
9250 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, false);
9253 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9254 && Present (Full_View (gnat_entity
)))
9256 Entity_Id full_view
= Full_View (gnat_entity
);
9258 if (Is_Private_Type (full_view
)
9259 && Present (Underlying_Full_View (full_view
)))
9260 full_view
= Underlying_Full_View (full_view
);
9262 gnu_new
= gnat_to_gnu_entity (full_view
, NULL_TREE
, true);
9264 /* Propagate back-annotations from full view to partial view. */
9265 if (Unknown_Alignment (gnat_entity
))
9266 Set_Alignment (gnat_entity
, Alignment (full_view
));
9268 if (Unknown_Esize (gnat_entity
))
9269 Set_Esize (gnat_entity
, Esize (full_view
));
9271 if (Unknown_RM_Size (gnat_entity
))
9272 Set_RM_Size (gnat_entity
, RM_Size (full_view
));
9274 /* The above call may have defined this entity (the simplest example
9275 of this is when we have a private enumeral type since the bounds
9276 will have the public view). */
9277 if (!present_gnu_tree (gnat_entity
))
9278 save_gnu_tree (gnat_entity
, gnu_new
, false);
9283 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
9284 && present_gnu_tree (Declaration_Node (gnat_entity
)))
9285 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
9287 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, true);
9290 if (Is_Type (gnat_entity
)
9291 && Present (Class_Wide_Type (gnat_entity
))
9292 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
9293 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, false);
9295 /* If we have an old type and we've made pointers to this type, update those
9296 pointers. If this is a Taft amendment type in the main unit, we need to
9297 mark the type as used since other units referencing it don't see the full
9298 declaration and, therefore, cannot mark it as used themselves. */
9301 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
9302 TREE_TYPE (gnu_new
));
9303 if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old
)))
9304 update_profiles_with (TREE_TYPE (gnu_old
));
9305 if (DECL_TAFT_TYPE_P (gnu_old
))
9306 used_types_insert (TREE_TYPE (gnu_new
));
9310 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
9311 We make two passes, one to elaborate anything other than bodies (but
9312 we declare a function if there was no spec). The second pass
9313 elaborates the bodies.
9315 GNAT_END_LIST gives the element in the list past the end. Normally,
9316 this is Empty, but can be First_Real_Statement for a
9317 Handled_Sequence_Of_Statements.
9319 We make a complete pass through both lists if PASS1P is true, then make
9320 the second pass over both lists if PASS2P is true. The lists usually
9321 correspond to the public and private parts of a package. */
9324 process_decls (List_Id gnat_decls
, List_Id gnat_decls2
,
9325 Node_Id gnat_end_list
, bool pass1p
, bool pass2p
)
9327 List_Id gnat_decl_array
[2];
9331 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
9334 for (i
= 0; i
<= 1; i
++)
9335 if (Present (gnat_decl_array
[i
]))
9336 for (gnat_decl
= First (gnat_decl_array
[i
]);
9337 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
9339 /* For package specs, we recurse inside the declarations,
9340 thus taking the two pass approach inside the boundary. */
9341 if (Nkind (gnat_decl
) == N_Package_Declaration
9342 && (Nkind (Specification (gnat_decl
)
9343 == N_Package_Specification
)))
9344 process_decls (Visible_Declarations (Specification (gnat_decl
)),
9345 Private_Declarations (Specification (gnat_decl
)),
9346 Empty
, true, false);
9348 /* Similarly for any declarations in the actions of a
9350 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
9352 process_freeze_entity (gnat_decl
);
9353 process_decls (Actions (gnat_decl
), Empty
, Empty
, true, false);
9356 /* Package bodies with freeze nodes get their elaboration deferred
9357 until the freeze node, but the code must be placed in the right
9358 place, so record the code position now. */
9359 else if (Nkind (gnat_decl
) == N_Package_Body
9360 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
9361 record_code_position (gnat_decl
);
9363 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
9364 && Present (Library_Unit (gnat_decl
))
9365 && Present (Freeze_Node
9368 (Library_Unit (gnat_decl
)))))))
9369 record_code_position
9370 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
9372 /* We defer most subprogram bodies to the second pass. */
9373 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
9375 if (Acts_As_Spec (gnat_decl
))
9377 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
9379 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
9380 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
9381 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, true);
9385 /* For bodies and stubs that act as their own specs, the entity
9386 itself must be elaborated in the first pass, because it may
9387 be used in other declarations. */
9388 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
9390 Node_Id gnat_subprog_id
9391 = Defining_Entity (Specification (gnat_decl
));
9393 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
9394 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
9395 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
9396 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, true);
9399 /* Concurrent stubs stand for the corresponding subprogram bodies,
9400 which are deferred like other bodies. */
9401 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
9402 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
9405 /* Renamed subprograms may not be elaborated yet at this point
9406 since renamings do not trigger freezing. Wait for the second
9407 pass to take care of them. */
9408 else if (Nkind (gnat_decl
) == N_Subprogram_Renaming_Declaration
)
9412 add_stmt (gnat_to_gnu (gnat_decl
));
9415 /* Here we elaborate everything we deferred above except for package bodies,
9416 which are elaborated at their freeze nodes. Note that we must also
9417 go inside things (package specs and freeze nodes) the first pass did. */
9419 for (i
= 0; i
<= 1; i
++)
9420 if (Present (gnat_decl_array
[i
]))
9421 for (gnat_decl
= First (gnat_decl_array
[i
]);
9422 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
9424 if (Nkind (gnat_decl
) == N_Subprogram_Body
9425 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
9426 || Nkind (gnat_decl
) == N_Task_Body_Stub
9427 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
9428 add_stmt (gnat_to_gnu (gnat_decl
));
9430 else if (Nkind (gnat_decl
) == N_Package_Declaration
9431 && (Nkind (Specification (gnat_decl
)
9432 == N_Package_Specification
)))
9433 process_decls (Visible_Declarations (Specification (gnat_decl
)),
9434 Private_Declarations (Specification (gnat_decl
)),
9435 Empty
, false, true);
9437 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
9438 process_decls (Actions (gnat_decl
), Empty
, Empty
, false, true);
9440 else if (Nkind (gnat_decl
) == N_Subprogram_Renaming_Declaration
)
9441 add_stmt (gnat_to_gnu (gnat_decl
));
9445 /* Make a unary operation of kind CODE using build_unary_op, but guard
9446 the operation by an overflow check. CODE can be one of NEGATE_EXPR
9447 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
9448 the operation is to be performed in that type. GNAT_NODE is the gnat
9449 node conveying the source location for which the error should be
9453 build_unary_op_trapv (enum tree_code code
, tree gnu_type
, tree operand
,
9456 gcc_assert (code
== NEGATE_EXPR
|| code
== ABS_EXPR
);
9458 operand
= gnat_protect_expr (operand
);
9460 return emit_check (build_binary_op (EQ_EXPR
, boolean_type_node
,
9461 operand
, TYPE_MIN_VALUE (gnu_type
)),
9462 build_unary_op (code
, gnu_type
, operand
),
9463 CE_Overflow_Check_Failed
, gnat_node
);
9466 /* Make a binary operation of kind CODE using build_binary_op, but guard
9467 the operation by an overflow check. CODE can be one of PLUS_EXPR,
9468 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
9469 Usually the operation is to be performed in that type. GNAT_NODE is
9470 the GNAT node conveying the source location for which the error should
9474 build_binary_op_trapv (enum tree_code code
, tree gnu_type
, tree left
,
9475 tree right
, Node_Id gnat_node
)
9477 const unsigned int precision
= TYPE_PRECISION (gnu_type
);
9478 tree lhs
= gnat_protect_expr (left
);
9479 tree rhs
= gnat_protect_expr (right
);
9480 tree type_max
= TYPE_MAX_VALUE (gnu_type
);
9481 tree type_min
= TYPE_MIN_VALUE (gnu_type
);
9482 tree gnu_expr
, check
;
9485 /* Assert that the precision is a power of 2. */
9486 gcc_assert ((precision
& (precision
- 1)) == 0);
9488 /* Prefer a constant on the RHS to simplify checks. */
9489 if (TREE_CODE (rhs
) != INTEGER_CST
9490 && TREE_CODE (lhs
) == INTEGER_CST
9491 && (code
== PLUS_EXPR
|| code
== MULT_EXPR
))
9498 gnu_expr
= build_binary_op (code
, gnu_type
, lhs
, rhs
);
9500 /* If we can fold the expression to a constant, just return it.
9501 The caller will deal with overflow, no need to generate a check. */
9502 if (TREE_CODE (gnu_expr
) == INTEGER_CST
)
9505 /* If no operand is a constant, we use the generic implementation. */
9506 if (TREE_CODE (lhs
) != INTEGER_CST
&& TREE_CODE (rhs
) != INTEGER_CST
)
9508 /* First convert the operands to the result type like build_binary_op.
9509 This is where the bias is made explicit for biased types. */
9510 lhs
= convert (gnu_type
, lhs
);
9511 rhs
= convert (gnu_type
, rhs
);
9513 /* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
9514 if (code
== MULT_EXPR
&& precision
== 64 && BITS_PER_WORD
< 64)
9516 tree int64
= gnat_type_for_size (64, 0);
9517 return convert (gnu_type
, build_call_n_expr (mulv64_decl
, 2,
9518 convert (int64
, lhs
),
9519 convert (int64
, rhs
)));
9522 /* Likewise for a 128-bit mult and a 64-bit target. */
9523 else if (code
== MULT_EXPR
&& precision
== 128 && BITS_PER_WORD
< 128)
9525 tree int128
= gnat_type_for_size (128, 0);
9526 return convert (gnu_type
, build_call_n_expr (mulv128_decl
, 2,
9527 convert (int128
, lhs
),
9528 convert (int128
, rhs
)));
9531 enum internal_fn icode
;
9536 icode
= IFN_ADD_OVERFLOW
;
9539 icode
= IFN_SUB_OVERFLOW
;
9542 icode
= IFN_MUL_OVERFLOW
;
9548 tree gnu_ctype
= build_complex_type (gnu_type
);
9550 = build_call_expr_internal_loc (UNKNOWN_LOCATION
, icode
, gnu_ctype
, 2,
9552 tree tgt
= save_expr (call
);
9553 gnu_expr
= build1 (REALPART_EXPR
, gnu_type
, tgt
);
9554 check
= fold_build2 (NE_EXPR
, boolean_type_node
,
9555 build1 (IMAGPART_EXPR
, gnu_type
, tgt
),
9556 build_int_cst (gnu_type
, 0));
9558 emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
9561 /* If one operand is a constant, we expose the overflow condition to enable
9562 a subsequent simplication or even elimination. */
9566 sgn
= tree_int_cst_sgn (rhs
);
9568 /* When rhs > 0, overflow when lhs > type_max - rhs. */
9569 check
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
9570 build_binary_op (MINUS_EXPR
, gnu_type
,
9573 /* When rhs < 0, overflow when lhs < type_min - rhs. */
9574 check
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
9575 build_binary_op (MINUS_EXPR
, gnu_type
,
9582 if (TREE_CODE (lhs
) == INTEGER_CST
)
9584 sgn
= tree_int_cst_sgn (lhs
);
9586 /* When lhs > 0, overflow when rhs < lhs - type_max. */
9587 check
= build_binary_op (LT_EXPR
, boolean_type_node
, rhs
,
9588 build_binary_op (MINUS_EXPR
, gnu_type
,
9591 /* When lhs < 0, overflow when rhs > lhs - type_min. */
9592 check
= build_binary_op (GT_EXPR
, boolean_type_node
, rhs
,
9593 build_binary_op (MINUS_EXPR
, gnu_type
,
9600 sgn
= tree_int_cst_sgn (rhs
);
9602 /* When rhs > 0, overflow when lhs < type_min + rhs. */
9603 check
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
9604 build_binary_op (PLUS_EXPR
, gnu_type
,
9607 /* When rhs < 0, overflow when lhs > type_max + rhs. */
9608 check
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
9609 build_binary_op (PLUS_EXPR
, gnu_type
,
9617 sgn
= tree_int_cst_sgn (rhs
);
9620 if (integer_onep (rhs
))
9623 tree lb
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
9624 tree ub
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
9626 /* When rhs > 1, overflow outside [type_min/rhs; type_max/rhs]. */
9628 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
9629 build_binary_op (LT_EXPR
, boolean_type_node
,
9631 build_binary_op (GT_EXPR
, boolean_type_node
,
9636 tree lb
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
9637 tree ub
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
9639 if (integer_minus_onep (rhs
))
9640 /* When rhs == -1, overflow if lhs == type_min. */
9642 = build_binary_op (EQ_EXPR
, boolean_type_node
, lhs
, type_min
);
9644 /* When rhs < -1, overflow outside [type_max/rhs; type_min/rhs]. */
9646 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
9647 build_binary_op (LT_EXPR
, boolean_type_node
,
9649 build_binary_op (GT_EXPR
, boolean_type_node
,
9660 return emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
9663 /* GNU_COND contains the condition corresponding to an index, overflow or
9664 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
9665 if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
9666 REASON is the code that says why the exception is raised. GNAT_NODE is
9667 the node conveying the source location for which the error should be
9670 We used to propagate TREE_SIDE_EFFECTS from GNU_EXPR to the COND_EXPR,
9671 overwriting the setting inherited from the call statement, on the ground
9672 that the expression need not be evaluated just for the check. However
9673 that's incorrect because, in the GCC type system, its value is presumed
9674 to be valid so its comparison against the type bounds always yields true
9675 and, therefore, could be done without evaluating it; given that it can
9676 be a computation that overflows the bounds, the language may require the
9677 check to fail and thus the expression to be evaluated in this case. */
9680 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
, Node_Id gnat_node
)
9683 = build_call_raise (reason
, gnat_node
, N_Raise_Constraint_Error
);
9685 fold_build3 (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
9686 build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_call
,
9687 SCALAR_FLOAT_TYPE_P (TREE_TYPE (gnu_expr
))
9688 ? build_real (TREE_TYPE (gnu_expr
), dconst0
)
9689 : build_int_cst (TREE_TYPE (gnu_expr
), 0)),
9693 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
9694 checks if OVERFLOW_P is true. If TRUNCATE_P is true, do a fp-to-integer
9695 conversion with truncation, otherwise round. GNAT_NODE is the GNAT node
9696 conveying the source location for which the error should be signaled. */
9699 convert_with_check (Entity_Id gnat_type
, tree gnu_expr
, bool overflow_p
,
9700 bool truncate_p
, Node_Id gnat_node
)
9702 tree gnu_type
= get_unpadded_type (gnat_type
);
9703 tree gnu_base_type
= get_base_type (gnu_type
);
9704 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
9705 tree gnu_in_base_type
= get_base_type (gnu_in_type
);
9706 tree gnu_result
= gnu_expr
;
9708 /* If we are not doing any checks, the output is an integral type and the
9709 input is not a floating-point type, just do the conversion. This is
9710 required for packed array types and is simpler in all cases anyway. */
9712 && INTEGRAL_TYPE_P (gnu_base_type
)
9713 && !FLOAT_TYPE_P (gnu_in_base_type
))
9714 return convert (gnu_type
, gnu_expr
);
9716 /* If the mode of the input base type is larger, then converting to it below
9717 may pessimize the final conversion step, for example generate a libcall
9718 instead of a simple instruction, so use a narrower type in this case. */
9719 if (TYPE_MODE (gnu_in_base_type
) != TYPE_MODE (gnu_in_type
)
9720 && !(TREE_CODE (gnu_in_type
) == INTEGER_TYPE
9721 && TYPE_BIASED_REPRESENTATION_P (gnu_in_type
)))
9722 gnu_in_base_type
= gnat_type_for_mode (TYPE_MODE (gnu_in_type
),
9723 TYPE_UNSIGNED (gnu_in_type
));
9725 /* First convert the expression to the base type. This will never generate
9726 code, but makes the tests below simpler. But don't do this if converting
9727 from an integer type to an unconstrained array type since then we need to
9728 get the bounds from the original (unpacked) type. */
9729 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
9730 gnu_result
= convert (gnu_in_base_type
, gnu_result
);
9732 /* If overflow checks are requested, we need to be sure the result will fit
9733 in the output base type. But don't do this if the input is integer and
9734 the output floating-point. */
9736 && !(FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_base_type
)))
9738 /* Ensure GNU_EXPR only gets evaluated once. */
9739 tree gnu_input
= gnat_protect_expr (gnu_result
);
9740 tree gnu_cond
= boolean_false_node
;
9741 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_base_type
);
9742 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_base_type
);
9743 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
9745 = (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
9746 && TYPE_MODULAR_P (gnu_base_type
))
9747 ? fold_build2 (MINUS_EXPR
, gnu_base_type
,
9748 TYPE_MODULUS (gnu_base_type
),
9749 build_int_cst (gnu_base_type
, 1))
9750 : TYPE_MAX_VALUE (gnu_base_type
);
9752 /* Convert the lower bounds to signed types, so we're sure we're
9753 comparing them properly. Likewise, convert the upper bounds
9754 to unsigned types. */
9755 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9756 && TYPE_UNSIGNED (gnu_in_base_type
))
9758 = convert (gnat_signed_type_for (gnu_in_base_type
), gnu_in_lb
);
9760 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9761 && !TYPE_UNSIGNED (gnu_in_base_type
))
9763 = convert (gnat_unsigned_type_for (gnu_in_base_type
), gnu_in_ub
);
9765 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
9767 = convert (gnat_signed_type_for (gnu_base_type
), gnu_out_lb
);
9769 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
9771 = convert (gnat_unsigned_type_for (gnu_base_type
), gnu_out_ub
);
9773 /* Check each bound separately and only if the result bound
9774 is tighter than the bound on the input type. Note that all the
9775 types are base types, so the bounds must be constant. Also,
9776 the comparison is done in the base type of the input, which
9777 always has the proper signedness. First check for input
9778 integer (which means output integer), output float (which means
9779 both float), or mixed, in which case we always compare.
9780 Note that we have to do the comparison which would *fail* in the
9781 case of an error since if it's an FP comparison and one of the
9782 values is a NaN or Inf, the comparison will fail. */
9783 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9784 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
9785 : (FLOAT_TYPE_P (gnu_base_type
)
9786 ? real_less (&TREE_REAL_CST (gnu_in_lb
),
9787 &TREE_REAL_CST (gnu_out_lb
))
9791 (build_binary_op (GE_EXPR
, boolean_type_node
,
9792 gnu_input
, convert (gnu_in_base_type
,
9795 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9796 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
9797 : (FLOAT_TYPE_P (gnu_base_type
)
9798 ? real_less (&TREE_REAL_CST (gnu_out_ub
),
9799 &TREE_REAL_CST (gnu_in_ub
))
9802 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, gnu_cond
,
9804 (build_binary_op (LE_EXPR
, boolean_type_node
,
9806 convert (gnu_in_base_type
,
9809 if (!integer_zerop (gnu_cond
))
9810 gnu_result
= emit_check (gnu_cond
, gnu_input
,
9811 CE_Overflow_Check_Failed
, gnat_node
);
9814 /* Now convert to the result base type. If this is a non-truncating
9815 float-to-integer conversion, round. */
9816 if (INTEGRAL_TYPE_P (gnu_base_type
)
9817 && FLOAT_TYPE_P (gnu_in_base_type
)
9820 REAL_VALUE_TYPE half_minus_pred_half
, pred_half
;
9821 tree gnu_conv
, gnu_zero
, gnu_comp
, calc_type
;
9822 tree gnu_pred_half
, gnu_add_pred_half
, gnu_subtract_pred_half
;
9823 const struct real_format
*fmt
;
9825 /* The following calculations depend on proper rounding to even
9826 of each arithmetic operation. In order to prevent excess
9827 precision from spoiling this property, use the widest hardware
9828 floating-point type if FP_ARITH_MAY_WIDEN is true. */
9830 = fp_arith_may_widen
? longest_float_type_node
: gnu_in_base_type
;
9832 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
9833 fmt
= REAL_MODE_FORMAT (TYPE_MODE (calc_type
));
9834 real_2expN (&half_minus_pred_half
, -(fmt
->p
) - 1, TYPE_MODE (calc_type
));
9835 real_arithmetic (&pred_half
, MINUS_EXPR
, &dconsthalf
,
9836 &half_minus_pred_half
);
9837 gnu_pred_half
= build_real (calc_type
, pred_half
);
9839 /* If the input is strictly negative, subtract this value
9840 and otherwise add it from the input. For 0.5, the result
9841 is exactly between 1.0 and the machine number preceding 1.0
9842 (for calc_type). Since the last bit of 1.0 is even, this 0.5
9843 will round to 1.0, while all other number with an absolute
9844 value less than 0.5 round to 0.0. For larger numbers exactly
9845 halfway between integers, rounding will always be correct as
9846 the true mathematical result will be closer to the higher
9847 integer compared to the lower one. So, this constant works
9848 for all floating-point numbers.
9850 The reason to use the same constant with subtract/add instead
9851 of a positive and negative constant is to allow the comparison
9852 to be scheduled in parallel with retrieval of the constant and
9853 conversion of the input to the calc_type (if necessary). */
9855 gnu_zero
= build_real (gnu_in_base_type
, dconst0
);
9856 gnu_result
= gnat_protect_expr (gnu_result
);
9857 gnu_conv
= convert (calc_type
, gnu_result
);
9859 = fold_build2 (GE_EXPR
, boolean_type_node
, gnu_result
, gnu_zero
);
9861 = fold_build2 (PLUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
9862 gnu_subtract_pred_half
9863 = fold_build2 (MINUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
9864 gnu_result
= fold_build3 (COND_EXPR
, calc_type
, gnu_comp
,
9865 gnu_add_pred_half
, gnu_subtract_pred_half
);
9868 if (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
9869 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type
)
9870 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
9871 gnu_result
= unchecked_convert (gnu_base_type
, gnu_result
, false);
9873 gnu_result
= convert (gnu_base_type
, gnu_result
);
9875 return convert (gnu_type
, gnu_result
);
9878 /* Return true if GNU_EXPR can be directly addressed. This is the case
9879 unless it is an expression involving computation or if it involves a
9880 reference to a bitfield or to an object not sufficiently aligned for
9881 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
9882 be directly addressed as an object of this type.
9884 *** Notes on addressability issues in the Ada compiler ***
9886 This predicate is necessary in order to bridge the gap between Gigi
9887 and the middle-end about addressability of GENERIC trees. A tree
9888 is said to be addressable if it can be directly addressed, i.e. if
9889 its address can be taken, is a multiple of the type's alignment on
9890 strict-alignment architectures and returns the first storage unit
9891 assigned to the object represented by the tree.
9893 In the C family of languages, everything is in practice addressable
9894 at the language level, except for bit-fields. This means that these
9895 compilers will take the address of any tree that doesn't represent
9896 a bit-field reference and expect the result to be the first storage
9897 unit assigned to the object. Even in cases where this will result
9898 in unaligned accesses at run time, nothing is supposed to be done
9899 and the program is considered as erroneous instead (see PR c/18287).
9901 The implicit assumptions made in the middle-end are in keeping with
9902 the C viewpoint described above:
9903 - the address of a bit-field reference is supposed to be never
9904 taken; the compiler (generally) will stop on such a construct,
9905 - any other tree is addressable if it is formally addressable,
9906 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
9908 In Ada, the viewpoint is the opposite one: nothing is addressable
9909 at the language level unless explicitly declared so. This means
9910 that the compiler will both make sure that the trees representing
9911 references to addressable ("aliased" in Ada parlance) objects are
9912 addressable and make no real attempts at ensuring that the trees
9913 representing references to non-addressable objects are addressable.
9915 In the first case, Ada is effectively equivalent to C and handing
9916 down the direct result of applying ADDR_EXPR to these trees to the
9917 middle-end works flawlessly. In the second case, Ada cannot afford
9918 to consider the program as erroneous if the address of trees that
9919 are not addressable is requested for technical reasons, unlike C;
9920 as a consequence, the Ada compiler must arrange for either making
9921 sure that this address is not requested in the middle-end or for
9922 compensating by inserting temporaries if it is requested in Gigi.
9924 The first goal can be achieved because the middle-end should not
9925 request the address of non-addressable trees on its own; the only
9926 exception is for the invocation of low-level block operations like
9927 memcpy, for which the addressability requirements are lower since
9928 the type's alignment can be disregarded. In practice, this means
9929 that Gigi must make sure that such operations cannot be applied to
9930 non-BLKmode bit-fields.
9932 The second goal is achieved by means of the addressable_p predicate,
9933 which computes whether a temporary must be inserted by Gigi when the
9934 address of a tree is requested; if so, the address of the temporary
9935 will be used in lieu of that of the original tree and some glue code
9936 generated to connect everything together. */
9939 addressable_p (tree gnu_expr
, tree gnu_type
)
9941 /* For an integral type, the size of the actual type of the object may not
9942 be greater than that of the expected type, otherwise an indirect access
9943 in the latter type wouldn't correctly set all the bits of the object. */
9945 && INTEGRAL_TYPE_P (gnu_type
)
9946 && smaller_form_type_p (gnu_type
, TREE_TYPE (gnu_expr
)))
9949 /* The size of the actual type of the object may not be smaller than that
9950 of the expected type, otherwise an indirect access in the latter type
9951 would be larger than the object. But only record types need to be
9952 considered in practice for this case. */
9954 && TREE_CODE (gnu_type
) == RECORD_TYPE
9955 && smaller_form_type_p (TREE_TYPE (gnu_expr
), gnu_type
))
9958 switch (TREE_CODE (gnu_expr
))
9964 /* All DECLs are addressable: if they are in a register, we can force
9968 case UNCONSTRAINED_ARRAY_REF
:
9970 /* Taking the address of a dereference yields the original pointer. */
9976 /* Taking the address yields a pointer to the constant pool. */
9980 /* Taking the address of a static constructor yields a pointer to the
9981 tree constant pool. */
9982 return TREE_STATIC (gnu_expr
) ? true : false;
9994 /* All rvalues are deemed addressable since taking their address will
9995 force a temporary to be created by the middle-end. */
9999 /* The address of a compound expression is that of its 2nd operand. */
10000 return addressable_p (TREE_OPERAND (gnu_expr
, 1), gnu_type
);
10003 /* We accept &COND_EXPR as soon as both operands are addressable and
10004 expect the outcome to be the address of the selected operand. */
10005 return (addressable_p (TREE_OPERAND (gnu_expr
, 1), NULL_TREE
)
10006 && addressable_p (TREE_OPERAND (gnu_expr
, 2), NULL_TREE
));
10008 case COMPONENT_REF
:
10009 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
10010 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
10011 the field is sufficiently aligned, in case it is subject
10012 to a pragma Component_Alignment. But we don't need to
10013 check the alignment of the containing record, as it is
10014 guaranteed to be not smaller than that of its most
10015 aligned field that is not a bit-field. */
10016 && (!STRICT_ALIGNMENT
10017 || DECL_ALIGN (TREE_OPERAND (gnu_expr
, 1))
10018 >= TYPE_ALIGN (TREE_TYPE (gnu_expr
))))
10019 /* The field of a padding record is always addressable. */
10020 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
10021 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
10023 case ARRAY_REF
: case ARRAY_RANGE_REF
:
10024 case REALPART_EXPR
: case IMAGPART_EXPR
:
10026 return addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
);
10029 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
10030 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
10032 case VIEW_CONVERT_EXPR
:
10034 /* This is addressable if we can avoid a copy. */
10035 tree type
= TREE_TYPE (gnu_expr
);
10036 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
10037 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
10038 && (!STRICT_ALIGNMENT
10039 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
10040 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
10041 || ((TYPE_MODE (type
) == BLKmode
10042 || TYPE_MODE (inner_type
) == BLKmode
)
10043 && (!STRICT_ALIGNMENT
10044 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
10045 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
10046 || TYPE_ALIGN_OK (type
)
10047 || TYPE_ALIGN_OK (inner_type
))))
10048 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
10056 /* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
10057 If a Freeze node exists for the entity, delay the bulk of the processing.
10058 Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
10061 process_type (Entity_Id gnat_entity
)
10064 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
10066 /* If we are to delay elaboration of this type, just do any elaboration
10067 needed for expressions within the declaration and make a dummy node
10068 for it and its Full_View (if any), in case something points to it.
10069 Do not do this if it has already been done (the only way that can
10070 happen is if the private completion is also delayed). */
10071 if (Present (Freeze_Node (gnat_entity
)))
10073 elaborate_entity (gnat_entity
);
10077 tree gnu_decl
= TYPE_STUB_DECL (make_dummy_type (gnat_entity
));
10078 save_gnu_tree (gnat_entity
, gnu_decl
, false);
10079 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
10080 && Present (Full_View (gnat_entity
)))
10082 if (Has_Completion_In_Body (gnat_entity
))
10083 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
10084 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, false);
10091 /* If we saved away a dummy type for this node, it means that this made the
10092 type that corresponds to the full type of an incomplete type. Clear that
10093 type for now and then update the type in the pointers below. But, if the
10094 saved type is not dummy, it very likely means that we have a use before
10095 declaration for the type in the tree, what we really cannot handle. */
10098 gcc_assert (TREE_CODE (gnu_old
) == TYPE_DECL
10099 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)));
10101 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
10104 /* Now fully elaborate the type. */
10105 tree gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, true);
10106 gcc_assert (TREE_CODE (gnu_new
) == TYPE_DECL
);
10108 /* If we have an old type and we've made pointers to this type, update those
10109 pointers. If this is a Taft amendment type in the main unit, we need to
10110 mark the type as used since other units referencing it don't see the full
10111 declaration and, therefore, cannot mark it as used themselves. */
10114 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
10115 TREE_TYPE (gnu_new
));
10116 if (DECL_TAFT_TYPE_P (gnu_old
))
10117 used_types_insert (TREE_TYPE (gnu_new
));
10120 /* If this is a record type corresponding to a task or protected type
10121 that is a completion of an incomplete type, perform a similar update
10122 on the type. ??? Including protected types here is a guess. */
10123 if (Is_Record_Type (gnat_entity
)
10124 && Is_Concurrent_Record_Type (gnat_entity
)
10125 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
10128 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
10130 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
10132 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
10135 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
10136 TREE_TYPE (gnu_new
));
10140 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
10141 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
10142 associations that are from RECORD_TYPE. If we see an internal record, make
10143 a recursive call to fill it in as well. */
10146 extract_values (tree values
, tree record_type
)
10148 vec
<constructor_elt
, va_gc
> *v
= NULL
;
10151 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
10153 tree tem
, value
= NULL_TREE
;
10155 /* _Parent is an internal field, but may have values in the aggregate,
10156 so check for values first. */
10157 if ((tem
= purpose_member (field
, values
)))
10159 value
= TREE_VALUE (tem
);
10160 TREE_ADDRESSABLE (tem
) = 1;
10163 else if (DECL_INTERNAL_P (field
))
10165 value
= extract_values (values
, TREE_TYPE (field
));
10166 if (TREE_CODE (value
) == CONSTRUCTOR
10167 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value
)))
10171 /* If we have a record subtype, the names will match, but not the
10172 actual FIELD_DECLs. */
10173 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
10174 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
10176 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
10177 TREE_ADDRESSABLE (tem
) = 1;
10183 CONSTRUCTOR_APPEND_ELT (v
, field
, value
);
10186 return gnat_build_constructor (record_type
, v
);
10189 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
10190 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
10191 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
10194 assoc_to_constructor (Entity_Id gnat_entity
, Node_Id gnat_assoc
, tree gnu_type
)
10196 tree gnu_list
= NULL_TREE
, gnu_result
;
10198 /* We test for GNU_FIELD being empty in the case where a variant
10199 was the last thing since we don't take things off GNAT_ASSOC in
10200 that case. We check GNAT_ASSOC in case we have a variant, but it
10203 for (; Present (gnat_assoc
); gnat_assoc
= Next (gnat_assoc
))
10205 const Node_Id gnat_field
= First (Choices (gnat_assoc
));
10206 const Node_Id gnat_expr
= Expression (gnat_assoc
);
10207 tree gnu_field
= gnat_to_gnu_field_decl (Entity (gnat_field
));
10208 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
10210 /* The expander is supposed to put a single component selector name
10211 in every record component association. */
10212 gcc_assert (No (Next (gnat_field
)));
10214 /* Ignore discriminants that have Corresponding_Discriminants in tagged
10215 types since we'll be setting those fields in the parent subtype. */
10216 if (Ekind (Entity (gnat_field
)) == E_Discriminant
10217 && Present (Corresponding_Discriminant (Entity (gnat_field
)))
10218 && Is_Tagged_Type (Scope (Entity (gnat_field
))))
10221 /* Also ignore discriminants of Unchecked_Unions. */
10222 if (Ekind (Entity (gnat_field
)) == E_Discriminant
10223 && Is_Unchecked_Union (gnat_entity
))
10226 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
10228 /* Convert to the type of the field. */
10229 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
10231 /* Add the field and expression to the list. */
10232 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
10235 gnu_result
= extract_values (gnu_list
, gnu_type
);
10239 /* Verify that every entry in GNU_LIST was used. */
10240 for (; gnu_list
; gnu_list
= TREE_CHAIN (gnu_list
))
10241 gcc_assert (TREE_ADDRESSABLE (gnu_list
));
10247 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
10248 the first element of an array aggregate. It may itself be an aggregate.
10249 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate. */
10252 pos_to_constructor (Node_Id gnat_expr
, tree gnu_array_type
)
10254 tree gnu_index
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type
));
10255 vec
<constructor_elt
, va_gc
> *gnu_expr_vec
= NULL
;
10257 for (; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
10261 /* If the expression is itself an array aggregate then first build the
10262 innermost constructor if it is part of our array (multi-dimensional
10264 if (Nkind (gnat_expr
) == N_Aggregate
10265 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
10266 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
10267 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
10268 TREE_TYPE (gnu_array_type
));
10271 /* If the expression is a conversion to an unconstrained array type,
10272 skip it to avoid spilling to memory. */
10273 if (Nkind (gnat_expr
) == N_Type_Conversion
10274 && Is_Array_Type (Etype (gnat_expr
))
10275 && !Is_Constrained (Etype (gnat_expr
)))
10276 gnu_expr
= gnat_to_gnu (Expression (gnat_expr
));
10278 gnu_expr
= gnat_to_gnu (gnat_expr
);
10280 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
10283 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec
, gnu_index
,
10284 convert (TREE_TYPE (gnu_array_type
), gnu_expr
));
10286 gnu_index
= int_const_binop (PLUS_EXPR
, gnu_index
,
10287 convert (TREE_TYPE (gnu_index
),
10288 integer_one_node
));
10291 return gnat_build_constructor (gnu_array_type
, gnu_expr_vec
);
10294 /* Process a N_Validate_Unchecked_Conversion node. */
10297 validate_unchecked_conversion (Node_Id gnat_node
)
10299 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
10300 tree gnu_target_type
= gnat_to_gnu_type (Target_Type (gnat_node
));
10302 /* If the target is a pointer type, see if we are either converting from a
10303 non-pointer or from a pointer to a type with a different alias set and
10304 warn if so, unless the pointer has been marked to alias everything. */
10305 if (POINTER_TYPE_P (gnu_target_type
)
10306 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type
))
10308 tree gnu_source_desig_type
= POINTER_TYPE_P (gnu_source_type
)
10309 ? TREE_TYPE (gnu_source_type
)
10311 tree gnu_target_desig_type
= TREE_TYPE (gnu_target_type
);
10312 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
10314 if (target_alias_set
!= 0
10315 && (!POINTER_TYPE_P (gnu_source_type
)
10316 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
10317 target_alias_set
)))
10319 post_error_ne ("?possible aliasing problem for type&",
10320 gnat_node
, Target_Type (gnat_node
));
10321 post_error ("\\?use -fno-strict-aliasing switch for references",
10323 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
10324 gnat_node
, Target_Type (gnat_node
));
10328 /* Likewise if the target is a fat pointer type, but we have no mechanism to
10329 mitigate the problem in this case, so we unconditionally warn. */
10330 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type
))
10332 tree gnu_source_desig_type
10333 = TYPE_IS_FAT_POINTER_P (gnu_source_type
)
10334 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type
)))
10336 tree gnu_target_desig_type
10337 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type
)));
10338 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
10340 if (target_alias_set
!= 0
10341 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type
)
10342 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
10343 target_alias_set
)))
10345 post_error_ne ("?possible aliasing problem for type&",
10346 gnat_node
, Target_Type (gnat_node
));
10347 post_error ("\\?use -fno-strict-aliasing switch for references",
10353 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a
10354 source code location and false if it doesn't. If CLEAR_COLUMN is
10355 true, set the column information to 0. If DECL is given and SLOC
10356 refers to a File with an instance, map DECL to that instance. */
10359 Sloc_to_locus (Source_Ptr Sloc
, location_t
*locus
, bool clear_column
,
10362 if (Sloc
== No_Location
)
10365 if (Sloc
<= Standard_Location
)
10367 *locus
= BUILTINS_LOCATION
;
10371 Source_File_Index file
= Get_Source_File_Index (Sloc
);
10372 Line_Number_Type line
= Get_Logical_Line_Number (Sloc
);
10373 Column_Number_Type column
= (clear_column
? 0 : Get_Column_Number (Sloc
));
10374 line_map_ordinary
*map
= LINEMAPS_ORDINARY_MAP_AT (line_table
, file
- 1);
10376 /* We can have zero if pragma Source_Reference is in effect. */
10380 /* Translate the location. */
10382 = linemap_position_for_line_and_column (line_table
, map
, line
, column
);
10384 if (file_map
&& file_map
[file
- 1].Instance
)
10385 decl_to_instance_map
->put (decl
, file_map
[file
- 1].Instance
);
10390 /* Return whether GNAT_NODE is a defining identifier for a renaming that comes
10391 from the parameter association for the instantiation of a generic. We do
10392 not want to emit source location for them: the code generated for their
10393 initialization is likely to disturb debugging. */
10396 renaming_from_instantiation_p (Node_Id gnat_node
)
10398 if (Nkind (gnat_node
) != N_Defining_Identifier
10399 || !Is_Object (gnat_node
)
10400 || Comes_From_Source (gnat_node
)
10401 || !Present (Renamed_Object (gnat_node
)))
10404 /* Get the object declaration of the renamed object, if any and if the
10405 renamed object is a mere identifier. */
10406 gnat_node
= Renamed_Object (gnat_node
);
10407 if (Nkind (gnat_node
) != N_Identifier
)
10410 gnat_node
= Parent (Entity (gnat_node
));
10411 return (Present (gnat_node
)
10412 && Nkind (gnat_node
) == N_Object_Declaration
10413 && Present (Corresponding_Generic_Association (gnat_node
)));
10416 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
10417 don't do anything if it doesn't correspond to a source location. And,
10418 if CLEAR_COLUMN is true, set the column information to 0. */
10421 set_expr_location_from_node (tree node
, Node_Id gnat_node
, bool clear_column
)
10425 /* Do not set a location for constructs likely to disturb debugging. */
10426 if (Nkind (gnat_node
) == N_Defining_Identifier
)
10428 if (Is_Type (gnat_node
) && Is_Actual_Subtype (gnat_node
))
10431 if (renaming_from_instantiation_p (gnat_node
))
10435 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
, clear_column
))
10438 SET_EXPR_LOCATION (node
, locus
);
10441 /* More elaborate version of set_expr_location_from_node to be used in more
10442 general contexts, for example the result of the translation of a generic
10446 set_gnu_expr_location_from_node (tree node
, Node_Id gnat_node
)
10448 /* Set the location information on the node if it is a real expression.
10449 References can be reused for multiple GNAT nodes and they would get
10450 the location information of their last use. Also make sure not to
10451 overwrite an existing location as it is probably more precise. */
10453 switch (TREE_CODE (node
))
10456 case NON_LVALUE_EXPR
:
10460 case COMPOUND_EXPR
:
10461 if (EXPR_P (TREE_OPERAND (node
, 1)))
10462 set_gnu_expr_location_from_node (TREE_OPERAND (node
, 1), gnat_node
);
10464 /* ... fall through ... */
10467 if (!REFERENCE_CLASS_P (node
) && !EXPR_HAS_LOCATION (node
))
10469 set_expr_location_from_node (node
, gnat_node
);
10470 set_end_locus_from_node (node
, gnat_node
);
10476 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
10477 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
10478 most sense. Return true if a sensible assignment was performed. */
10481 set_end_locus_from_node (tree gnu_node
, Node_Id gnat_node
)
10483 Node_Id gnat_end_label
;
10484 location_t end_locus
;
10486 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
10487 end_locus when there is one. We consider only GNAT nodes with a possible
10488 End_Label attached. If the End_Label actually was unassigned, fallback
10489 on the original node. We'd better assign an explicit sloc associated with
10490 the outer construct in any case. */
10492 switch (Nkind (gnat_node
))
10494 case N_Package_Body
:
10495 case N_Subprogram_Body
:
10496 case N_Block_Statement
:
10497 gnat_end_label
= End_Label (Handled_Statement_Sequence (gnat_node
));
10500 case N_Package_Declaration
:
10501 gnat_end_label
= End_Label (Specification (gnat_node
));
10508 if (Present (gnat_end_label
))
10509 gnat_node
= gnat_end_label
;
10511 /* Some expanded subprograms have neither an End_Label nor a Sloc
10512 attached. Notify that to callers. For a block statement with no
10513 End_Label, clear column information, so that the tree for a
10514 transient block does not receive the sloc of a source condition. */
10515 if (!Sloc_to_locus (Sloc (gnat_node
), &end_locus
,
10516 No (gnat_end_label
)
10517 && (Nkind (gnat_node
) == N_Block_Statement
)))
10520 switch (TREE_CODE (gnu_node
))
10523 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node
)) = end_locus
;
10526 case FUNCTION_DECL
:
10527 DECL_STRUCT_FUNCTION (gnu_node
)->function_end_locus
= end_locus
;
10535 /* Post an error message. MSG is the error message, properly annotated.
10536 NODE is the node at which to post the error and the node to use for the
10537 '&' substitution. */
10540 post_error (const char *msg
, Node_Id node
)
10542 String_Template temp
;
10548 temp
.Low_Bound
= 1;
10549 temp
.High_Bound
= strlen (msg
);
10552 Error_Msg_N (sp
, node
);
10555 /* Similar to post_error, but NODE is the node at which to post the error and
10556 ENT is the node to use for the '&' substitution. */
10559 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
10561 String_Template temp
;
10567 temp
.Low_Bound
= 1;
10568 temp
.High_Bound
= strlen (msg
);
10571 Error_Msg_NE (sp
, node
, ent
);
10574 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
10577 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int num
)
10579 Error_Msg_Uint_1
= UI_From_Int (num
);
10580 post_error_ne (msg
, node
, ent
);
10583 /* Similar to post_error_ne, but T is a GCC tree representing the number to
10584 write. If T represents a constant, the text inside curly brackets in
10585 MSG will be output (presumably including a '^'). Otherwise it will not
10586 be output and the text inside square brackets will be output instead. */
10589 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
10591 char *new_msg
= XALLOCAVEC (char, strlen (msg
) + 1);
10592 char start_yes
, end_yes
, start_no
, end_no
;
10596 if (TREE_CODE (t
) == INTEGER_CST
)
10598 Error_Msg_Uint_1
= UI_From_gnu (t
);
10599 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
10602 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
10604 for (p
= msg
, q
= new_msg
; *p
; p
++)
10606 if (*p
== start_yes
)
10607 for (p
++; *p
!= end_yes
; p
++)
10609 else if (*p
== start_no
)
10610 for (p
++; *p
!= end_no
; p
++)
10618 post_error_ne (new_msg
, node
, ent
);
10621 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
10624 post_error_ne_tree_2 (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
,
10627 Error_Msg_Uint_2
= UI_From_Int (num
);
10628 post_error_ne_tree (msg
, node
, ent
, t
);
10631 /* Return a label to branch to for the exception type in KIND or Empty
10635 get_exception_label (char kind
)
10639 case N_Raise_Constraint_Error
:
10640 return gnu_constraint_error_label_stack
.last ();
10642 case N_Raise_Storage_Error
:
10643 return gnu_storage_error_label_stack
.last ();
10645 case N_Raise_Program_Error
:
10646 return gnu_program_error_label_stack
.last ();
10652 gcc_unreachable ();
10655 /* Return the decl for the current elaboration procedure. */
10658 get_elaboration_procedure (void)
10660 return gnu_elab_proc_stack
->last ();
10663 /* Return the controlling type of a dispatching subprogram. */
10666 get_controlling_type (Entity_Id subprog
)
10668 /* This is modeled on Expand_Interface_Thunk. */
10669 Entity_Id controlling_type
= Etype (First_Formal (subprog
));
10670 if (Is_Access_Type (controlling_type
))
10671 controlling_type
= Directly_Designated_Type (controlling_type
);
10672 controlling_type
= Underlying_Type (controlling_type
);
10673 if (Is_Concurrent_Type (controlling_type
))
10674 controlling_type
= Corresponding_Record_Type (controlling_type
);
10675 controlling_type
= Base_Type (controlling_type
);
10676 return controlling_type
;
10679 /* Return whether we should use an alias for the TARGET of a thunk
10680 in order to make the call generated in the thunk local. */
10683 use_alias_for_thunk_p (tree target
)
10685 /* We cannot generate a local call in this case. */
10686 if (DECL_EXTERNAL (target
))
10689 /* The call is already local in this case. */
10690 if (TREE_CODE (DECL_CONTEXT (target
)) == FUNCTION_DECL
)
10693 return TARGET_USE_LOCAL_THUNK_ALIAS_P (target
);
10696 static GTY(()) unsigned long thunk_labelno
= 0;
10698 /* Create an alias for TARGET to be used as the target of a thunk. */
10701 make_alias_for_thunk (tree target
)
10704 targetm
.asm_out
.generate_internal_label (buf
, "LTHUNK", thunk_labelno
++);
10706 tree alias
= build_decl (DECL_SOURCE_LOCATION (target
), TREE_CODE (target
),
10707 get_identifier (buf
), TREE_TYPE (target
));
10709 DECL_LANG_SPECIFIC (alias
) = DECL_LANG_SPECIFIC (target
);
10710 DECL_CONTEXT (alias
) = DECL_CONTEXT (target
);
10711 TREE_READONLY (alias
) = TREE_READONLY (target
);
10712 TREE_THIS_VOLATILE (alias
) = TREE_THIS_VOLATILE (target
);
10713 DECL_ARTIFICIAL (alias
) = 1;
10714 DECL_INITIAL (alias
) = error_mark_node
;
10715 DECL_ARGUMENTS (alias
) = copy_list (DECL_ARGUMENTS (target
));
10716 TREE_ADDRESSABLE (alias
) = 1;
10717 SET_DECL_ASSEMBLER_NAME (alias
, DECL_NAME (alias
));
10719 cgraph_node
*n
= cgraph_node::create_same_body_alias (alias
, target
);
10725 /* Create the local covariant part of {GNAT,GNU}_THUNK. */
10728 make_covariant_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
)
10730 tree gnu_name
= create_concat_name (gnat_thunk
, "CV");
10732 = build_decl (DECL_SOURCE_LOCATION (gnu_thunk
), TREE_CODE (gnu_thunk
),
10733 gnu_name
, TREE_TYPE (gnu_thunk
));
10735 DECL_ARGUMENTS (gnu_cv_thunk
) = copy_list (DECL_ARGUMENTS (gnu_thunk
));
10736 for (tree param_decl
= DECL_ARGUMENTS (gnu_cv_thunk
);
10738 param_decl
= DECL_CHAIN (param_decl
))
10739 DECL_CONTEXT (param_decl
) = gnu_cv_thunk
;
10741 DECL_RESULT (gnu_cv_thunk
) = copy_node (DECL_RESULT (gnu_thunk
));
10742 DECL_CONTEXT (DECL_RESULT (gnu_cv_thunk
)) = gnu_cv_thunk
;
10744 DECL_LANG_SPECIFIC (gnu_cv_thunk
) = DECL_LANG_SPECIFIC (gnu_thunk
);
10745 DECL_CONTEXT (gnu_cv_thunk
) = DECL_CONTEXT (gnu_thunk
);
10746 TREE_READONLY (gnu_cv_thunk
) = TREE_READONLY (gnu_thunk
);
10747 TREE_THIS_VOLATILE (gnu_cv_thunk
) = TREE_THIS_VOLATILE (gnu_thunk
);
10748 DECL_ARTIFICIAL (gnu_cv_thunk
) = 1;
10750 return gnu_cv_thunk
;
10753 /* Try to create a GNU thunk for {GNAT,GNU}_THUNK and return true on success.
10755 GNU thunks are more efficient than GNAT thunks because they don't call into
10756 the runtime to retrieve the offset used in the displacement operation, but
10757 they are tailored to C++ and thus too limited to support the full range of
10758 thunks generated in Ada. Here's the complete list of limitations:
10760 1. Multi-controlling thunks, i.e thunks with more than one controlling
10761 parameter, are simply not supported.
10763 2. Covariant thunks, i.e. thunks for which the result is also controlling,
10764 are split into a pair of (this, covariant-only) thunks.
10766 3. Variable-offset thunks, i.e. thunks for which the offset depends on the
10767 object and not only on its type, are supported as 2nd class citizens.
10769 4. External thunks, i.e. thunks for which the target is not declared in
10770 the same unit as the thunk, are supported as 2nd class citizens.
10772 5. Local thunks, i.e. thunks generated for a local type, are supported as
10773 2nd class citizens. */
10776 maybe_make_gnu_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
)
10778 const Entity_Id gnat_target
= Thunk_Entity (gnat_thunk
);
10780 /* Check that the first formal of the target is the only controlling one. */
10781 Entity_Id gnat_formal
= First_Formal (gnat_target
);
10782 if (!Is_Controlling_Formal (gnat_formal
))
10784 for (gnat_formal
= Next_Formal (gnat_formal
);
10785 Present (gnat_formal
);
10786 gnat_formal
= Next_Formal (gnat_formal
))
10787 if (Is_Controlling_Formal (gnat_formal
))
10790 /* Look for the types that control the target and the thunk. */
10791 const Entity_Id gnat_controlling_type
= get_controlling_type (gnat_target
);
10792 const Entity_Id gnat_interface_type
= get_controlling_type (gnat_thunk
);
10794 /* We must have an interface type at this point. */
10795 gcc_assert (Is_Interface (gnat_interface_type
));
10797 /* Now compute whether the former covers the latter. */
10798 const Entity_Id gnat_interface_tag
10799 = Find_Interface_Tag (gnat_controlling_type
, gnat_interface_type
);
10800 tree gnu_interface_tag
10801 = Present (gnat_interface_tag
)
10802 ? gnat_to_gnu_field_decl (gnat_interface_tag
)
10804 tree gnu_interface_offset
10805 = gnu_interface_tag
? byte_position (gnu_interface_tag
) : NULL_TREE
;
10807 /* There are three ways to retrieve the offset between the interface view
10808 and the base object. Either the controlling type covers the interface
10809 type and the offset of the corresponding tag is fixed, in which case it
10810 can be statically encoded in the thunk (see FIXED_OFFSET below). Or the
10811 controlling type doesn't cover the interface type but is of fixed size,
10812 in which case the offset is stored in the dispatch table, two pointers
10813 above the dispatch table address (see VIRTUAL_VALUE below). Otherwise,
10814 the offset is variable and is stored right after the tag in every object
10815 (see INDIRECT_OFFSET below). See also a-tags.ads for more details. */
10816 HOST_WIDE_INT fixed_offset
, virtual_value
, indirect_offset
;
10817 tree virtual_offset
;
10819 if (gnu_interface_offset
&& TREE_CODE (gnu_interface_offset
) == INTEGER_CST
)
10821 fixed_offset
= - tree_to_shwi (gnu_interface_offset
);
10823 virtual_offset
= NULL_TREE
;
10824 indirect_offset
= 0;
10826 else if (!gnu_interface_offset
10827 && !Is_Variable_Size_Record (gnat_controlling_type
))
10830 virtual_value
= - 2 * (HOST_WIDE_INT
) (POINTER_SIZE
/ BITS_PER_UNIT
);
10831 virtual_offset
= build_int_cst (integer_type_node
, virtual_value
);
10832 indirect_offset
= 0;
10836 /* Covariant thunks with variable offset are not supported. */
10837 if (Has_Controlling_Result (gnat_target
))
10842 virtual_offset
= NULL_TREE
;
10843 indirect_offset
= (HOST_WIDE_INT
) (POINTER_SIZE
/ BITS_PER_UNIT
);
10846 tree gnu_target
= gnat_to_gnu_entity (gnat_target
, NULL_TREE
, false);
10848 /* If the target is local, then thunk and target must have the same context
10849 because cgraph_node::expand_thunk can only forward the static chain. */
10850 if (DECL_STATIC_CHAIN (gnu_target
)
10851 && DECL_CONTEXT (gnu_thunk
) != DECL_CONTEXT (gnu_target
))
10854 /* If the target returns by invisible reference and is external, apply the
10855 same transformation as Subprogram_Body_to_gnu here. */
10856 if (TREE_ADDRESSABLE (TREE_TYPE (gnu_target
))
10857 && DECL_EXTERNAL (gnu_target
)
10858 && !POINTER_TYPE_P (TREE_TYPE (DECL_RESULT (gnu_target
))))
10860 TREE_TYPE (DECL_RESULT (gnu_target
))
10861 = build_reference_type (TREE_TYPE (DECL_RESULT (gnu_target
)));
10862 relayout_decl (DECL_RESULT (gnu_target
));
10865 /* The thunk expander requires the return types of thunk and target to be
10866 compatible, which is not fully the case with the CICO mechanism. */
10867 if (TYPE_CI_CO_LIST (TREE_TYPE (gnu_thunk
)))
10869 tree gnu_target_type
= TREE_TYPE (gnu_target
);
10870 gcc_assert (TYPE_CI_CO_LIST (gnu_target_type
));
10871 TYPE_CANONICAL (TREE_TYPE (TREE_TYPE (gnu_thunk
)))
10872 = TYPE_CANONICAL (TREE_TYPE (gnu_target_type
));
10875 cgraph_node
*target_node
= cgraph_node::get_create (gnu_target
);
10877 /* We may also need to create an alias for the target in order to make
10878 the call local, depending on the linkage of the target. */
10879 tree gnu_alias
= use_alias_for_thunk_p (gnu_target
)
10880 ? make_alias_for_thunk (gnu_target
)
10883 /* If the return type of the target is a controlling type, then we need
10884 both an usual this thunk and a covariant thunk in this order:
10886 this thunk --> covariant thunk --> target
10888 For covariant thunks, we can only handle a fixed offset. */
10889 if (Has_Controlling_Result (gnat_target
))
10891 gcc_assert (fixed_offset
< 0);
10892 tree gnu_cv_thunk
= make_covariant_thunk (gnat_thunk
, gnu_thunk
);
10893 target_node
->create_thunk (gnu_cv_thunk
, gnu_target
, false,
10894 - fixed_offset
, 0, 0,
10895 NULL_TREE
, gnu_alias
);
10897 gnu_alias
= gnu_target
= gnu_cv_thunk
;
10900 target_node
->create_thunk (gnu_thunk
, gnu_target
, true,
10901 fixed_offset
, virtual_value
, indirect_offset
,
10902 virtual_offset
, gnu_alias
);
10907 /* Initialize the table that maps GNAT codes to GCC codes for simple
10908 binary and unary operations. */
10911 init_code_table (void)
10913 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
10914 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
10915 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
10916 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
10917 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
10918 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
10919 gnu_codes
[N_Op_Le
] = LE_EXPR
;
10920 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
10921 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
10922 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
10923 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
10924 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
10925 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
10926 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
10927 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
10928 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
10929 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
10930 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
10931 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
10932 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
10933 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
10934 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
10935 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
10936 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
10939 #include "gt-ada-trans.h"