1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2020, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
33 #include "gimple-expr.h"
34 #include "stringpool.h"
37 #include "diagnostic.h"
39 #include "fold-const.h"
40 #include "stor-layout.h"
45 #include "libfuncs.h" /* For set_stack_check_libfunc. */
46 #include "tree-iterator.h"
49 #include "common/common-target.h"
50 #include "gomp-constants.h"
51 #include "stringpool.h"
55 #include "adadecode.h"
71 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
72 for fear of running out of stack space. If we need more, we use xmalloc
74 #define ALLOCA_THRESHOLD 1000
76 /* Pointers to front-end tables accessed through macros. */
77 struct Node
*Nodes_Ptr
;
78 struct Flags
*Flags_Ptr
;
79 Node_Id
*Next_Node_Ptr
;
80 Node_Id
*Prev_Node_Ptr
;
81 struct Elist_Header
*Elists_Ptr
;
82 struct Elmt_Item
*Elmts_Ptr
;
83 struct String_Entry
*Strings_Ptr
;
84 Char_Code
*String_Chars_Ptr
;
85 struct List_Header
*List_Headers_Ptr
;
87 /* Highest number in the front-end node table. */
90 /* True when gigi is being called on an analyzed but unexpanded
91 tree, and the only purpose of the call is to properly annotate
92 types with representation information. */
93 bool type_annotate_only
;
95 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
96 static vec
<Node_Id
> gnat_validate_uc_list
;
98 /* List of expressions of pragma Compile_Time_{Error|Warning} in the unit. */
99 static vec
<Node_Id
> gnat_compile_time_expr_list
;
101 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
102 of unconstrained array IN parameters to avoid emitting a great deal of
103 redundant instructions to recompute them each time. */
104 struct GTY (()) parm_attr_d
{
105 int id
; /* GTY doesn't like Entity_Id. */
112 typedef struct parm_attr_d
*parm_attr
;
115 struct GTY(()) language_function
{
116 vec
<parm_attr
, va_gc
> *parm_attr_cache
;
117 bitmap named_ret_val
;
118 vec
<tree
, va_gc
> *other_ret_val
;
122 #define f_parm_attr_cache \
123 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
125 #define f_named_ret_val \
126 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
128 #define f_other_ret_val \
129 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
132 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
134 /* A structure used to gather together information about a statement group.
135 We use this to gather related statements, for example the "then" part
136 of a IF. In the case where it represents a lexical scope, we may also
137 have a BLOCK node corresponding to it and/or cleanups. */
139 struct GTY((chain_next ("%h.previous"))) stmt_group
{
140 struct stmt_group
*previous
; /* Previous code group. */
141 tree stmt_list
; /* List of statements for this code group. */
142 tree block
; /* BLOCK for this code group, if any. */
143 tree cleanups
; /* Cleanups for this code group, if any. */
146 static GTY(()) struct stmt_group
*current_stmt_group
;
148 /* List of unused struct stmt_group nodes. */
149 static GTY((deletable
)) struct stmt_group
*stmt_group_free_list
;
151 /* A structure used to record information on elaboration procedures
152 we've made and need to process.
154 ??? gnat_node should be Node_Id, but gengtype gets confused. */
156 struct GTY((chain_next ("%h.next"))) elab_info
{
157 struct elab_info
*next
; /* Pointer to next in chain. */
158 tree elab_proc
; /* Elaboration procedure. */
159 int gnat_node
; /* The N_Compilation_Unit. */
162 static GTY(()) struct elab_info
*elab_info_list
;
164 /* Stack of exception pointer variables. Each entry is the VAR_DECL
165 that stores the address of the raised exception. Nonzero means we
166 are in an exception handler. Not used in the zero-cost case. */
167 static GTY(()) vec
<tree
, va_gc
> *gnu_except_ptr_stack
;
169 /* In ZCX case, current exception pointer. Used to re-raise it. */
170 static GTY(()) tree gnu_incoming_exc_ptr
;
172 /* Stack for storing the current elaboration procedure decl. */
173 static GTY(()) vec
<tree
, va_gc
> *gnu_elab_proc_stack
;
175 /* Stack of labels to be used as a goto target instead of a return in
176 some functions. See processing for N_Subprogram_Body. */
177 static GTY(()) vec
<tree
, va_gc
> *gnu_return_label_stack
;
179 /* Stack of variable for the return value of a function with copy-in/copy-out
180 parameters. See processing for N_Subprogram_Body. */
181 static GTY(()) vec
<tree
, va_gc
> *gnu_return_var_stack
;
183 /* Structure used to record information for a range check. */
184 struct GTY(()) range_check_info_d
{
194 typedef struct range_check_info_d
*range_check_info
;
197 /* Structure used to record information for a loop. */
198 struct GTY(()) loop_info_d
{
203 tree omp_loop_clauses
;
204 tree omp_construct_clauses
;
205 enum tree_code omp_code
;
206 vec
<range_check_info
, va_gc
> *checks
;
209 typedef struct loop_info_d
*loop_info
;
212 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
213 static GTY(()) vec
<loop_info
, va_gc
> *gnu_loop_stack
;
215 /* The stacks for N_{Push,Pop}_*_Label. */
216 static vec
<Entity_Id
> gnu_constraint_error_label_stack
;
217 static vec
<Entity_Id
> gnu_storage_error_label_stack
;
218 static vec
<Entity_Id
> gnu_program_error_label_stack
;
220 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
221 static enum tree_code gnu_codes
[Number_Node_Kinds
];
223 static void init_code_table (void);
224 static tree
get_elaboration_procedure (void);
225 static void Compilation_Unit_to_gnu (Node_Id
);
226 static bool empty_stmt_list_p (tree
);
227 static void record_code_position (Node_Id
);
228 static void insert_code_for (Node_Id
);
229 static void add_cleanup (tree
, Node_Id
);
230 static void add_stmt_list (List_Id
);
231 static tree
build_stmt_group (List_Id
, bool);
232 static inline bool stmt_group_may_fallthru (void);
233 static enum gimplify_status
gnat_gimplify_stmt (tree
*);
234 static void elaborate_all_entities (Node_Id
);
235 static void process_freeze_entity (Node_Id
);
236 static void process_decls (List_Id
, List_Id
, Node_Id
, bool, bool);
237 static tree
emit_check (tree
, tree
, int, Node_Id
);
238 static tree
build_unary_op_trapv (enum tree_code
, tree
, tree
, Node_Id
);
239 static tree
build_binary_op_trapv (enum tree_code
, tree
, tree
, tree
, Node_Id
);
240 static tree
convert_with_check (Entity_Id
, tree
, bool, bool, Node_Id
);
241 static bool addressable_p (tree
, tree
);
242 static tree
assoc_to_constructor (Entity_Id
, Node_Id
, tree
);
243 static tree
pos_to_constructor (Node_Id
, tree
);
244 static void validate_unchecked_conversion (Node_Id
);
245 static void set_expr_location_from_node (tree
, Node_Id
, bool = false);
246 static void set_gnu_expr_location_from_node (tree
, Node_Id
);
247 static bool set_end_locus_from_node (tree
, Node_Id
);
248 static int lvalue_required_p (Node_Id
, tree
, bool, bool);
249 static tree
build_raise_check (int, enum exception_info_kind
);
250 static tree
create_init_temporary (const char *, tree
, tree
*, Node_Id
);
251 static bool maybe_make_gnu_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
);
253 /* Hooks for debug info back-ends, only supported and used in a restricted set
254 of configurations. */
255 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED
;
256 static const char *decode_name (const char *) ATTRIBUTE_UNUSED
;
258 /* This makes gigi's file_info_ptr visible in this translation unit,
259 so that Sloc_to_locus can look it up when deciding whether to map
260 decls to instances. */
262 static struct File_Info_Type
*file_map
;
264 /* This is the main program of the back-end. It sets up all the table
265 structures and then generates code. */
268 gigi (Node_Id gnat_root
,
270 int number_name ATTRIBUTE_UNUSED
,
271 struct Node
*nodes_ptr
,
272 struct Flags
*flags_ptr
,
273 Node_Id
*next_node_ptr
,
274 Node_Id
*prev_node_ptr
,
275 struct Elist_Header
*elists_ptr
,
276 struct Elmt_Item
*elmts_ptr
,
277 struct String_Entry
*strings_ptr
,
278 Char_Code
*string_chars_ptr
,
279 struct List_Header
*list_headers_ptr
,
281 struct File_Info_Type
*file_info_ptr
,
282 Entity_Id standard_boolean
,
283 Entity_Id standard_integer
,
284 Entity_Id standard_character
,
285 Entity_Id standard_long_long_float
,
286 Entity_Id standard_exception_type
,
287 Int gigi_operating_mode
)
290 Entity_Id gnat_literal
;
291 tree t
, ftype
, int64_type
;
292 struct elab_info
*info
;
295 max_gnat_nodes
= max_gnat_node
;
297 Nodes_Ptr
= nodes_ptr
;
298 Flags_Ptr
= flags_ptr
;
299 Next_Node_Ptr
= next_node_ptr
;
300 Prev_Node_Ptr
= prev_node_ptr
;
301 Elists_Ptr
= elists_ptr
;
302 Elmts_Ptr
= elmts_ptr
;
303 Strings_Ptr
= strings_ptr
;
304 String_Chars_Ptr
= string_chars_ptr
;
305 List_Headers_Ptr
= list_headers_ptr
;
307 type_annotate_only
= (gigi_operating_mode
== 1);
309 if (Generate_SCO_Instance_Table
!= 0)
311 file_map
= file_info_ptr
;
312 maybe_create_decl_to_instance_map (number_file
);
315 for (i
= 0; i
< number_file
; i
++)
317 /* Use the identifier table to make a permanent copy of the filename as
318 the name table gets reallocated after Gigi returns but before all the
319 debugging information is output. The __gnat_to_canonical_file_spec
320 call translates filenames from pragmas Source_Reference that contain
321 host style syntax not understood by gdb. */
325 (__gnat_to_canonical_file_spec
326 (Get_Name_String (file_info_ptr
[i
].File_Name
))));
328 /* We rely on the order isomorphism between files and line maps. */
329 gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table
) == i
);
331 /* We create the line map for a source file at once, with a fixed number
332 of columns chosen to avoid jumping over the next power of 2. */
333 linemap_add (line_table
, LC_ENTER
, 0, filename
, 1);
334 linemap_line_start (line_table
, file_info_ptr
[i
].Num_Source_Lines
, 252);
335 linemap_position_for_column (line_table
, 252 - 1);
336 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
339 gcc_assert (Nkind (gnat_root
) == N_Compilation_Unit
);
341 /* Declare the name of the compilation unit as the first global
342 name in order to make the middle-end fully deterministic. */
343 t
= create_concat_name (Defining_Entity (Unit (gnat_root
)), NULL
);
344 first_global_object_name
= ggc_strdup (IDENTIFIER_POINTER (t
));
346 /* Initialize ourselves. */
351 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
353 if (type_annotate_only
)
355 TYPE_SIZE (void_type_node
) = bitsize_zero_node
;
356 TYPE_SIZE_UNIT (void_type_node
) = size_zero_node
;
359 /* Enable GNAT stack checking method if needed */
360 if (!Stack_Check_Probes_On_Target
)
361 set_stack_check_libfunc ("_gnat_stack_check");
363 /* Retrieve alignment settings. */
364 double_float_alignment
= get_target_double_float_alignment ();
365 double_scalar_alignment
= get_target_double_scalar_alignment ();
367 /* Record the builtin types. Define `integer' and `character' first so that
368 dbx will output them first. */
369 record_builtin_type ("integer", integer_type_node
, false);
370 record_builtin_type ("character", char_type_node
, false);
371 record_builtin_type ("boolean", boolean_type_node
, false);
372 record_builtin_type ("void", void_type_node
, false);
374 /* Save the type we made for integer as the type for Standard.Integer. */
375 save_gnu_tree (Base_Type (standard_integer
),
376 TYPE_NAME (integer_type_node
),
379 /* Likewise for character as the type for Standard.Character. */
380 finish_character_type (char_type_node
);
381 save_gnu_tree (Base_Type (standard_character
),
382 TYPE_NAME (char_type_node
),
385 /* Likewise for boolean as the type for Standard.Boolean. */
386 save_gnu_tree (Base_Type (standard_boolean
),
387 TYPE_NAME (boolean_type_node
),
389 gnat_literal
= First_Literal (Base_Type (standard_boolean
));
390 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
391 gcc_assert (t
== boolean_false_node
);
392 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
393 boolean_type_node
, t
, true, false, false, false, false,
394 true, false, NULL
, gnat_literal
);
395 save_gnu_tree (gnat_literal
, t
, false);
396 gnat_literal
= Next_Literal (gnat_literal
);
397 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
398 gcc_assert (t
== boolean_true_node
);
399 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
400 boolean_type_node
, t
, true, false, false, false, false,
401 true, false, NULL
, gnat_literal
);
402 save_gnu_tree (gnat_literal
, t
, false);
404 /* Declare the building blocks of function nodes. */
405 void_list_node
= build_tree_list (NULL_TREE
, void_type_node
);
406 void_ftype
= build_function_type_list (void_type_node
, NULL_TREE
);
407 ptr_void_ftype
= build_pointer_type (void_ftype
);
409 /* Now declare run-time functions. */
411 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE
,
412 build_function_type_list (ptr_type_node
, sizetype
,
414 NULL_TREE
, is_default
, true, true, true, false,
416 DECL_IS_MALLOC (malloc_decl
) = 1;
419 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
420 build_function_type_list (void_type_node
,
421 ptr_type_node
, NULL_TREE
),
422 NULL_TREE
, is_default
, true, true, true, false,
426 = create_subprog_decl (get_identifier ("__gnat_realloc"), NULL_TREE
,
427 build_function_type_list (ptr_type_node
,
428 ptr_type_node
, sizetype
,
430 NULL_TREE
, is_default
, true, true, true, false,
433 /* This is used for 64-bit multiplication with overflow checking. */
434 int64_type
= gnat_type_for_size (64, 0);
436 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE
,
437 build_function_type_list (int64_type
, int64_type
,
438 int64_type
, NULL_TREE
),
439 NULL_TREE
, is_default
, true, true, true, false,
442 /* Name of the _Parent field in tagged record types. */
443 parent_name_id
= get_identifier (Get_Name_String (Name_uParent
));
445 /* Name of the Exception_Data type defined in System.Standard_Library. */
446 exception_data_name_id
447 = get_identifier ("system__standard_library__exception_data");
449 /* Make the types and functions used for exception processing. */
450 except_type_node
= gnat_to_gnu_type (Base_Type (standard_exception_type
));
453 = build_array_type (gnat_type_for_mode (Pmode
, 0),
454 build_index_type (size_int (5)));
455 record_builtin_type ("JMPBUF_T", jmpbuf_type
, true);
456 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
458 /* Functions to get and set the jumpbuf pointer for the current thread. */
460 = create_subprog_decl
461 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
462 NULL_TREE
, build_function_type_list (jmpbuf_ptr_type
, NULL_TREE
),
463 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
466 = create_subprog_decl
467 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
468 NULL_TREE
, build_function_type_list (void_type_node
, jmpbuf_ptr_type
,
470 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
473 = create_subprog_decl
474 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE
,
475 build_function_type_list (build_pointer_type (except_type_node
),
477 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
479 not_handled_by_others_decl
= get_identifier ("not_handled_by_others");
480 for (t
= TYPE_FIELDS (except_type_node
); t
; t
= DECL_CHAIN (t
))
481 if (DECL_NAME (t
) == not_handled_by_others_decl
)
483 not_handled_by_others_decl
= t
;
486 gcc_assert (DECL_P (not_handled_by_others_decl
));
488 /* setjmp returns an integer and has one operand, which is a pointer to
491 = create_subprog_decl
492 (get_identifier ("__builtin_setjmp"), NULL_TREE
,
493 build_function_type_list (integer_type_node
, jmpbuf_ptr_type
,
495 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
496 set_decl_built_in_function (setjmp_decl
, BUILT_IN_NORMAL
, BUILT_IN_SETJMP
);
498 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
500 update_setjmp_buf_decl
501 = create_subprog_decl
502 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE
,
503 build_function_type_list (void_type_node
, jmpbuf_ptr_type
, NULL_TREE
),
504 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
505 set_decl_built_in_function (update_setjmp_buf_decl
, BUILT_IN_NORMAL
,
506 BUILT_IN_UPDATE_SETJMP_BUF
);
508 /* Indicate that it never returns. */
509 ftype
= build_function_type_list (void_type_node
,
510 build_pointer_type (except_type_node
),
512 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
514 = create_subprog_decl
515 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
, ftype
,
516 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
518 set_exception_parameter_decl
519 = create_subprog_decl
520 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE
,
521 build_function_type_list (void_type_node
, ptr_type_node
, ptr_type_node
,
523 NULL_TREE
, is_default
, true, true, true, false, false, NULL
, Empty
);
525 /* Hooks to call when entering/leaving an exception handler. */
526 ftype
= build_function_type_list (ptr_type_node
,
527 ptr_type_node
, NULL_TREE
);
529 = create_subprog_decl (get_identifier ("__gnat_begin_handler_v1"),
530 NULL_TREE
, ftype
, NULL_TREE
,
531 is_default
, true, true, true, false, false, NULL
,
533 /* __gnat_begin_handler_v1 is not a dummy procedure, but we arrange
534 for it not to throw. */
535 TREE_NOTHROW (begin_handler_decl
) = 1;
537 ftype
= build_function_type_list (ptr_type_node
,
538 ptr_type_node
, ptr_type_node
,
539 ptr_type_node
, NULL_TREE
);
541 = create_subprog_decl (get_identifier ("__gnat_end_handler_v1"), NULL_TREE
,
543 is_default
, true, true, true, false, false, NULL
,
546 ftype
= build_function_type_list (void_type_node
, ptr_type_node
, NULL_TREE
);
547 unhandled_except_decl
548 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
549 NULL_TREE
, ftype
, NULL_TREE
,
550 is_default
, true, true, true, false, false, NULL
,
553 /* Indicate that it never returns. */
554 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
556 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE
,
558 is_default
, true, true, true, false, false, NULL
,
561 /* Dummy objects to materialize "others" and "all others" in the exception
562 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
565 = create_var_decl (get_identifier ("OTHERS"),
566 get_identifier ("__gnat_others_value"),
567 char_type_node
, NULL_TREE
,
568 true, false, true, false, false, true, false,
572 = create_var_decl (get_identifier ("ALL_OTHERS"),
573 get_identifier ("__gnat_all_others_value"),
574 char_type_node
, NULL_TREE
,
575 true, false, true, false, false, true, false,
578 unhandled_others_decl
579 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
580 get_identifier ("__gnat_unhandled_others_value"),
581 char_type_node
, NULL_TREE
,
582 true, false, true, false, false, true, false,
585 /* If in no exception handlers mode, all raise statements are redirected to
586 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
587 this procedure will never be called in this mode. */
588 if (No_Exception_Handlers_Set ())
590 /* Indicate that it never returns. */
591 ftype
= build_function_type_list (void_type_node
,
592 build_pointer_type (char_type_node
),
593 integer_type_node
, NULL_TREE
);
594 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
596 = create_subprog_decl
597 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
, ftype
,
598 NULL_TREE
, is_default
, true, true, true, false, false, NULL
,
600 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
601 gnat_raise_decls
[i
] = decl
;
605 /* Otherwise, make one decl for each exception reason. */
606 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
607 gnat_raise_decls
[i
] = build_raise_check (i
, exception_simple
);
608 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls_ext
); i
++)
609 gnat_raise_decls_ext
[i
]
610 = build_raise_check (i
,
611 i
== CE_Index_Check_Failed
612 || i
== CE_Range_Check_Failed
613 || i
== CE_Invalid_Data
614 ? exception_range
: exception_column
);
617 /* Build the special descriptor type and its null node if needed. */
618 if (TARGET_VTABLE_USES_DESCRIPTORS
)
620 tree null_node
= fold_convert (ptr_void_ftype
, null_pointer_node
);
621 tree field_list
= NULL_TREE
;
623 vec
<constructor_elt
, va_gc
> *null_vec
= NULL
;
624 constructor_elt
*elt
;
626 fdesc_type_node
= make_node (RECORD_TYPE
);
627 vec_safe_grow (null_vec
, TARGET_VTABLE_USES_DESCRIPTORS
);
628 elt
= (null_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
630 for (j
= 0; j
< TARGET_VTABLE_USES_DESCRIPTORS
; j
++)
633 = create_field_decl (NULL_TREE
, ptr_void_ftype
, fdesc_type_node
,
634 NULL_TREE
, NULL_TREE
, 0, 1);
635 DECL_CHAIN (field
) = field_list
;
638 elt
->value
= null_node
;
642 finish_record_type (fdesc_type_node
, nreverse (field_list
), 0, false);
643 record_builtin_type ("descriptor", fdesc_type_node
, true);
644 null_fdesc_node
= gnat_build_constructor (fdesc_type_node
, null_vec
);
647 longest_float_type_node
648 = get_unpadded_type (Base_Type (standard_long_long_float
));
650 main_identifier_node
= get_identifier ("main");
652 /* If we are using the GCC exception mechanism, let GCC know. */
653 if (Back_End_Exceptions ())
656 /* Initialize the GCC support for FP operations. */
659 /* Install the builtins we might need, either internally or as user-available
660 facilities for Intrinsic imports. Note that this must be done after the
661 GCC exception mechanism is initialized. */
662 gnat_install_builtins ();
664 vec_safe_push (gnu_except_ptr_stack
, NULL_TREE
);
666 gnu_constraint_error_label_stack
.safe_push (Empty
);
667 gnu_storage_error_label_stack
.safe_push (Empty
);
668 gnu_program_error_label_stack
.safe_push (Empty
);
670 /* Process any Pragma Ident for the main unit. */
671 if (Present (Ident_String (Main_Unit
)))
672 targetm
.asm_out
.output_ident
673 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
675 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
676 if (No_Strict_Aliasing_CP
)
677 flag_strict_aliasing
= 0;
679 /* Save the current optimization options again after the above possible
680 global_options changes. */
681 optimization_default_node
= build_optimization_node (&global_options
);
682 optimization_current_node
= optimization_default_node
;
684 /* Now translate the compilation unit proper. */
685 Compilation_Unit_to_gnu (gnat_root
);
687 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
688 the very end to avoid having to second-guess the front-end when we run
689 into dummy nodes during the regular processing. */
690 for (i
= 0; gnat_validate_uc_list
.iterate (i
, &gnat_iter
); i
++)
691 validate_unchecked_conversion (gnat_iter
);
692 gnat_validate_uc_list
.release ();
694 /* Finally see if we have any elaboration procedures to deal with. */
695 for (info
= elab_info_list
; info
; info
= info
->next
)
697 tree gnu_body
= DECL_SAVED_TREE (info
->elab_proc
);
699 /* We should have a BIND_EXPR but it may not have any statements in it.
700 If it doesn't have any, we have nothing to do except for setting the
701 flag on the GNAT node. Otherwise, process the function as others. */
702 tree gnu_stmts
= gnu_body
;
703 if (TREE_CODE (gnu_stmts
) == BIND_EXPR
)
704 gnu_stmts
= BIND_EXPR_BODY (gnu_stmts
);
705 if (!gnu_stmts
|| empty_stmt_list_p (gnu_stmts
))
706 Set_Has_No_Elaboration_Code (info
->gnat_node
, 1);
709 begin_subprog_body (info
->elab_proc
);
710 end_subprog_body (gnu_body
);
711 rest_of_subprog_body_compilation (info
->elab_proc
);
715 /* Destroy ourselves. */
717 destroy_gnat_decl ();
718 destroy_gnat_utils ();
720 /* We cannot track the location of errors past this point. */
721 Current_Error_Node
= Empty
;
724 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
725 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
728 build_raise_check (int check
, enum exception_info_kind kind
)
731 const char pfx
[] = "__gnat_rcheck_";
733 strcpy (Name_Buffer
, pfx
);
734 Name_Len
= sizeof (pfx
) - 1;
735 Get_RT_Exception_Name (check
);
737 if (kind
== exception_simple
)
739 Name_Buffer
[Name_Len
] = 0;
741 = build_function_type_list (void_type_node
,
742 build_pointer_type (char_type_node
),
743 integer_type_node
, NULL_TREE
);
747 tree t
= (kind
== exception_column
? NULL_TREE
: integer_type_node
);
749 strcpy (Name_Buffer
+ Name_Len
, "_ext");
750 Name_Buffer
[Name_Len
+ 4] = 0;
752 = build_function_type_list (void_type_node
,
753 build_pointer_type (char_type_node
),
754 integer_type_node
, integer_type_node
,
758 /* Indicate that it never returns. */
759 ftype
= build_qualified_type (ftype
, TYPE_QUAL_VOLATILE
);
761 = create_subprog_decl (get_identifier (Name_Buffer
), NULL_TREE
, ftype
,
762 NULL_TREE
, is_default
, true, true, true, false,
768 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
769 an N_Attribute_Reference. */
772 lvalue_required_for_attribute_p (Node_Id gnat_node
)
774 switch (Get_Attribute_Id (Attribute_Name (gnat_node
)))
780 case Attr_Range_Length
:
782 case Attr_Object_Size
:
784 case Attr_Value_Size
:
785 case Attr_Component_Size
:
786 case Attr_Descriptor_Size
:
787 case Attr_Max_Size_In_Storage_Elements
:
790 case Attr_Null_Parameter
:
791 case Attr_Passed_By_Reference
:
792 case Attr_Mechanism_Code
:
799 case Attr_Unchecked_Access
:
800 case Attr_Unrestricted_Access
:
801 case Attr_Code_Address
:
802 case Attr_Pool_Address
:
804 case Attr_Bit_Position
:
810 case Attr_Asm_Output
:
816 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
817 is the type that will be used for GNAT_NODE in the translated GNU tree.
818 CONSTANT indicates whether the underlying object represented by GNAT_NODE
819 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
820 whether its value is the address of another constant. If it isn't, then
821 ADDRESS_OF_CONSTANT is ignored.
823 The function climbs up the GNAT tree starting from the node and returns 1
824 upon encountering a node that effectively requires an lvalue downstream.
825 It returns int instead of bool to facilitate usage in non-purely binary
829 lvalue_required_p (Node_Id gnat_node
, tree gnu_type
, bool constant
,
830 bool address_of_constant
)
832 Node_Id gnat_parent
= Parent (gnat_node
), gnat_temp
;
834 switch (Nkind (gnat_parent
))
839 case N_Attribute_Reference
:
840 return lvalue_required_for_attribute_p (gnat_parent
);
842 case N_Parameter_Association
:
843 case N_Function_Call
:
844 case N_Procedure_Call_Statement
:
845 /* If the parameter is by reference, an lvalue is required. */
847 || must_pass_by_ref (gnu_type
)
848 || default_pass_by_ref (gnu_type
));
850 case N_Indexed_Component
:
851 /* Only the array expression can require an lvalue. */
852 if (Prefix (gnat_parent
) != gnat_node
)
855 /* ??? Consider that referencing an indexed component with a variable
856 index forces the whole aggregate to memory. Note that testing only
857 for literals is conservative, any static expression in the RM sense
858 could probably be accepted with some additional work. */
859 for (gnat_temp
= First (Expressions (gnat_parent
));
861 gnat_temp
= Next (gnat_temp
))
862 if (Nkind (gnat_temp
) != N_Character_Literal
863 && Nkind (gnat_temp
) != N_Integer_Literal
864 && !(Is_Entity_Name (gnat_temp
)
865 && Ekind (Entity (gnat_temp
)) == E_Enumeration_Literal
))
868 /* ... fall through ... */
870 case N_Selected_Component
:
872 /* Only the prefix expression can require an lvalue. */
873 if (Prefix (gnat_parent
) != gnat_node
)
876 return lvalue_required_p (gnat_parent
,
877 get_unpadded_type (Etype (gnat_parent
)),
878 constant
, address_of_constant
);
880 case N_Object_Renaming_Declaration
:
881 /* We need to preserve addresses through a renaming. */
884 case N_Object_Declaration
:
885 /* We cannot use a constructor if this is an atomic object because
886 the actual assignment might end up being done component-wise. */
888 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
889 && Is_Atomic_Or_VFA (Defining_Entity (gnat_parent
)))
890 /* We don't use a constructor if this is a class-wide object
891 because the effective type of the object is the equivalent
892 type of the class-wide subtype and it smashes most of the
893 data into an array of bytes to which we cannot convert. */
894 || Ekind ((Etype (Defining_Entity (gnat_parent
))))
895 == E_Class_Wide_Subtype
);
897 case N_Assignment_Statement
:
898 /* We cannot use a constructor if the LHS is an atomic object because
899 the actual assignment might end up being done component-wise. */
901 || Name (gnat_parent
) == gnat_node
902 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
903 && Is_Entity_Name (Name (gnat_parent
))
904 && Is_Atomic_Or_VFA (Entity (Name (gnat_parent
)))));
906 case N_Unchecked_Type_Conversion
:
910 /* ... fall through ... */
912 case N_Type_Conversion
:
913 case N_Qualified_Expression
:
914 /* We must look through all conversions because we may need to bypass
915 an intermediate conversion that is meant to be purely formal. */
916 return lvalue_required_p (gnat_parent
,
917 get_unpadded_type (Etype (gnat_parent
)),
918 constant
, address_of_constant
);
920 case N_Explicit_Dereference
:
921 /* We look through dereferences for address of constant because we need
922 to handle the special cases listed above. */
923 if (constant
&& address_of_constant
)
924 return lvalue_required_p (gnat_parent
,
925 get_unpadded_type (Etype (gnat_parent
)),
928 /* ... fall through ... */
937 /* Return true if an lvalue should be used for GNAT_NODE. GNU_TYPE is the type
938 that will be used for GNAT_NODE in the translated GNU tree and is assumed to
939 be an aggregate type.
941 The function climbs up the GNAT tree starting from the node and returns true
942 upon encountering a node that makes it doable to decide. lvalue_required_p
943 should have been previously invoked on the arguments and returned false. */
946 lvalue_for_aggregate_p (Node_Id gnat_node
, tree gnu_type
)
948 Node_Id gnat_parent
= Parent (gnat_node
);
950 switch (Nkind (gnat_parent
))
952 case N_Parameter_Association
:
953 case N_Function_Call
:
954 case N_Procedure_Call_Statement
:
955 /* Even if the parameter is by copy, prefer an lvalue. */
958 case N_Indexed_Component
:
959 case N_Selected_Component
:
960 /* If an elementary component is used, take it from the constant. */
961 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_parent
))))
964 /* ... fall through ... */
967 return lvalue_for_aggregate_p (gnat_parent
,
968 get_unpadded_type (Etype (gnat_parent
)));
970 case N_Object_Declaration
:
971 /* For an aggregate object declaration, return the constant at top level
972 in order to avoid generating elaboration code. */
973 if (global_bindings_p ())
976 /* ... fall through ... */
978 case N_Assignment_Statement
:
979 /* For an aggregate assignment, decide based on the size. */
981 const HOST_WIDE_INT size
= int_size_in_bytes (gnu_type
);
982 return size
< 0 || size
>= param_large_stack_frame
/ 4;
985 case N_Unchecked_Type_Conversion
:
986 case N_Type_Conversion
:
987 case N_Qualified_Expression
:
988 return lvalue_for_aggregate_p (gnat_parent
,
989 get_unpadded_type (Etype (gnat_parent
)));
992 /* We should only reach here through the N_Qualified_Expression case.
993 Force an lvalue for aggregate types since a block-copy to the newly
994 allocated area of memory is made. */
1005 /* Return true if T is a constant DECL node that can be safely replaced
1006 by its initializer. */
1009 constant_decl_with_initializer_p (tree t
)
1011 if (!TREE_CONSTANT (t
) || !DECL_P (t
) || !DECL_INITIAL (t
))
1014 /* Return false for aggregate types that contain a placeholder since
1015 their initializers cannot be manipulated easily. */
1016 if (AGGREGATE_TYPE_P (TREE_TYPE (t
))
1017 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t
))
1018 && type_contains_placeholder_p (TREE_TYPE (t
)))
1024 /* Return an expression equivalent to EXP but where constant DECL nodes
1025 have been replaced by their initializer. */
1028 fold_constant_decl_in_expr (tree exp
)
1030 enum tree_code code
= TREE_CODE (exp
);
1037 if (!constant_decl_with_initializer_p (exp
))
1040 return DECL_INITIAL (exp
);
1043 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1044 if (op0
== TREE_OPERAND (exp
, 0))
1047 return fold_build3 (COMPONENT_REF
, TREE_TYPE (exp
), op0
,
1048 TREE_OPERAND (exp
, 1), NULL_TREE
);
1051 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1052 if (op0
== TREE_OPERAND (exp
, 0))
1055 return fold_build3 (BIT_FIELD_REF
, TREE_TYPE (exp
), op0
,
1056 TREE_OPERAND (exp
, 1), TREE_OPERAND (exp
, 2));
1059 case ARRAY_RANGE_REF
:
1060 /* If the index is not itself constant, then nothing can be folded. */
1061 if (!TREE_CONSTANT (TREE_OPERAND (exp
, 1)))
1063 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1064 if (op0
== TREE_OPERAND (exp
, 0))
1067 return fold (build4 (code
, TREE_TYPE (exp
), op0
, TREE_OPERAND (exp
, 1),
1068 TREE_OPERAND (exp
, 2), NULL_TREE
));
1072 case VIEW_CONVERT_EXPR
:
1073 op0
= fold_constant_decl_in_expr (TREE_OPERAND (exp
, 0));
1074 if (op0
== TREE_OPERAND (exp
, 0))
1077 return fold_build1 (code
, TREE_TYPE (exp
), op0
);
1086 /* Return true if TYPE and DEF_TYPE are compatible GNAT types for Gigi. */
1089 Gigi_Types_Compatible (Entity_Id type
, Entity_Id def_type
)
1091 /* The trivial case. */
1092 if (type
== def_type
)
1095 /* A class-wide type is equivalent to a subtype of itself. */
1096 if (Is_Class_Wide_Type (type
))
1099 /* A packed array type is compatible with its implementation type. */
1100 if (Is_Packed (def_type
) && type
== Packed_Array_Impl_Type (def_type
))
1103 /* If both types are Itypes, one may be a copy of the other. */
1104 if (Is_Itype (def_type
) && Is_Itype (type
))
1107 /* If the type is incomplete and comes from a limited context, then also
1108 consider its non-limited view. */
1109 if (Is_Incomplete_Type (def_type
)
1110 && From_Limited_With (def_type
)
1111 && Present (Non_Limited_View (def_type
)))
1112 return Gigi_Types_Compatible (type
, Non_Limited_View (def_type
));
1114 /* If the type is incomplete/private, then also consider its full view. */
1115 if (Is_Incomplete_Or_Private_Type (def_type
)
1116 && Present (Full_View (def_type
)))
1117 return Gigi_Types_Compatible (type
, Full_View (def_type
));
1122 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
1123 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
1124 to where we should place the result type. */
1127 Identifier_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
1129 /* The entity of GNAT_NODE and its type. */
1130 Node_Id gnat_entity
= (Nkind (gnat_node
) == N_Defining_Identifier
1131 || Nkind (gnat_node
) == N_Defining_Operator_Symbol
)
1132 ? gnat_node
: Entity (gnat_node
);
1133 Node_Id gnat_entity_type
= Etype (gnat_entity
);
1134 /* If GNAT_NODE is a constant, whether we should use the initialization
1135 value instead of the constant entity, typically for scalars with an
1136 address clause when the parent doesn't require an lvalue. */
1137 bool use_constant_initializer
= false;
1138 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1139 specific circumstances only, so evaluated lazily. < 0 means
1140 unknown, > 0 means known true, 0 means known false. */
1141 int require_lvalue
= -1;
1142 Node_Id gnat_result_type
;
1143 tree gnu_result
, gnu_result_type
;
1145 /* If the Etype of this node is not the same as that of the Entity, then
1146 something went wrong, probably in generic instantiation. However, this
1147 does not apply to types. Since we sometime have strange Ekind's, just
1148 do this test for objects, except for discriminants because their type
1149 may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */
1150 gcc_assert (!Is_Object (gnat_entity
)
1151 || Ekind (gnat_entity
) == E_Discriminant
1152 || Etype (gnat_node
) == gnat_entity_type
1153 || Gigi_Types_Compatible (Etype (gnat_node
), gnat_entity_type
));
1155 /* If this is a reference to a deferred constant whose partial view is an
1156 unconstrained private type, the proper type is on the full view of the
1157 constant, not on the full view of the type, which may be unconstrained.
1159 This may be a reference to a type, for example in the prefix of the
1160 attribute Position, generated for dispatching code (see Make_DT in
1161 exp_disp,adb). In that case we need the type itself, not is parent,
1162 in particular if it is a derived type */
1163 if (Ekind (gnat_entity
) == E_Constant
1164 && Is_Private_Type (gnat_entity_type
)
1165 && (Has_Unknown_Discriminants (gnat_entity_type
)
1166 || (Present (Full_View (gnat_entity_type
))
1167 && Has_Discriminants (Full_View (gnat_entity_type
))))
1168 && Present (Full_View (gnat_entity
)))
1170 gnat_entity
= Full_View (gnat_entity
);
1171 gnat_result_type
= Etype (gnat_entity
);
1175 /* We use the Actual_Subtype only if it has already been elaborated,
1176 as we may be invoked precisely during its elaboration, otherwise
1177 the Etype. Avoid using it for packed arrays to simplify things,
1178 except in a return statement because we need the actual size and
1179 the front-end does not make it explicit in this case. */
1180 if ((Ekind (gnat_entity
) == E_Constant
1181 || Ekind (gnat_entity
) == E_Variable
1182 || Is_Formal (gnat_entity
))
1183 && !(Is_Array_Type (Etype (gnat_entity
))
1184 && Present (Packed_Array_Impl_Type (Etype (gnat_entity
)))
1185 && Nkind (Parent (gnat_node
)) != N_Simple_Return_Statement
)
1186 && Present (Actual_Subtype (gnat_entity
))
1187 && present_gnu_tree (Actual_Subtype (gnat_entity
)))
1188 gnat_result_type
= Actual_Subtype (gnat_entity
);
1190 gnat_result_type
= Etype (gnat_node
);
1193 /* Expand the type of this identifier first, in case it is an enumeral
1194 literal, which only get made when the type is expanded. There is no
1195 order-of-elaboration issue here. */
1196 gnu_result_type
= get_unpadded_type (gnat_result_type
);
1198 /* If this is a non-imported elementary constant with an address clause,
1199 retrieve the value instead of a pointer to be dereferenced unless
1200 an lvalue is required. This is generally more efficient and actually
1201 required if this is a static expression because it might be used
1202 in a context where a dereference is inappropriate, such as a case
1203 statement alternative or a record discriminant. There is no possible
1204 volatile-ness short-circuit here since Volatile constants must be
1205 imported per C.6. */
1206 if (Ekind (gnat_entity
) == E_Constant
1207 && Is_Elementary_Type (gnat_result_type
)
1208 && !Is_Imported (gnat_entity
)
1209 && Present (Address_Clause (gnat_entity
)))
1212 = lvalue_required_p (gnat_node
, gnu_result_type
, true, false);
1213 use_constant_initializer
= !require_lvalue
;
1216 if (use_constant_initializer
)
1218 /* If this is a deferred constant, the initializer is attached to
1220 if (Present (Full_View (gnat_entity
)))
1221 gnat_entity
= Full_View (gnat_entity
);
1223 gnu_result
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
1226 gnu_result
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
1228 /* Some objects (such as parameters passed by reference, globals of
1229 variable size, and renamed objects) actually represent the address
1230 of the object. In that case, we must do the dereference. Likewise,
1231 deal with parameters to foreign convention subprograms. */
1232 if (DECL_P (gnu_result
)
1233 && (DECL_BY_REF_P (gnu_result
)
1234 || (TREE_CODE (gnu_result
) == PARM_DECL
1235 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
1237 const bool read_only
= DECL_POINTS_TO_READONLY_P (gnu_result
);
1239 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1240 if (TREE_CODE (gnu_result
) == PARM_DECL
1241 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
1243 = convert (build_pointer_type (gnu_result_type
), gnu_result
);
1245 /* If it's a CONST_DECL, return the underlying constant like below. */
1246 else if (TREE_CODE (gnu_result
) == CONST_DECL
1247 && !(DECL_CONST_ADDRESS_P (gnu_result
)
1248 && lvalue_required_p (gnat_node
, gnu_result_type
, true,
1250 gnu_result
= DECL_INITIAL (gnu_result
);
1252 /* Do the final dereference. */
1253 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
1255 if ((TREE_CODE (gnu_result
) == INDIRECT_REF
1256 || TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
1257 && No (Address_Clause (gnat_entity
)))
1258 TREE_THIS_NOTRAP (gnu_result
) = 1;
1261 TREE_READONLY (gnu_result
) = 1;
1264 /* If we have a constant declaration and its initializer, try to return the
1265 latter to avoid the need to call fold in lots of places and the need for
1266 elaboration code if this identifier is used as an initializer itself. */
1267 if (constant_decl_with_initializer_p (gnu_result
))
1269 bool constant_only
= (TREE_CODE (gnu_result
) == CONST_DECL
1270 && !DECL_CONST_CORRESPONDING_VAR (gnu_result
));
1271 bool address_of_constant
= (TREE_CODE (gnu_result
) == CONST_DECL
1272 && DECL_CONST_ADDRESS_P (gnu_result
));
1274 /* If there is a (corresponding) variable or this is the address of a
1275 constant, we only want to return the initializer if an lvalue isn't
1276 required. Evaluate this now if we have not already done so. */
1277 if ((!constant_only
|| address_of_constant
) && require_lvalue
< 0)
1279 = lvalue_required_p (gnat_node
, gnu_result_type
, true,
1280 address_of_constant
)
1281 || (AGGREGATE_TYPE_P (gnu_result_type
)
1282 && lvalue_for_aggregate_p (gnat_node
, gnu_result_type
));
1284 /* Finally retrieve the initializer if this is deemed valid. */
1285 if ((constant_only
&& !address_of_constant
) || !require_lvalue
)
1286 gnu_result
= DECL_INITIAL (gnu_result
);
1289 /* But for a constant renaming we couldn't do that incrementally for its
1290 definition because of the need to return an lvalue so, if the present
1291 context doesn't itself require an lvalue, we try again here. */
1292 else if (Ekind (gnat_entity
) == E_Constant
1293 && Is_Elementary_Type (gnat_result_type
)
1294 && Present (Renamed_Object (gnat_entity
)))
1296 if (require_lvalue
< 0)
1298 = lvalue_required_p (gnat_node
, gnu_result_type
, true, false);
1299 if (!require_lvalue
)
1300 gnu_result
= fold_constant_decl_in_expr (gnu_result
);
1303 /* The GNAT tree has the type of a function set to its result type, so we
1304 adjust here. Also use the type of the result if the Etype is a subtype
1305 that is nominally unconstrained. Likewise if this is a deferred constant
1306 of a discriminated type whose full view can be elaborated statically, to
1307 avoid problematic conversions to the nominal subtype. But remove any
1308 padding from the resulting type. */
1309 if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_result
))
1310 || Is_Constr_Subt_For_UN_Aliased (gnat_result_type
)
1311 || (Ekind (gnat_entity
) == E_Constant
1312 && Present (Full_View (gnat_entity
))
1313 && Has_Discriminants (gnat_result_type
)
1314 && TREE_CODE (gnu_result
) == CONSTRUCTOR
))
1316 gnu_result_type
= TREE_TYPE (gnu_result
);
1317 if (TYPE_IS_PADDING_P (gnu_result_type
))
1318 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
1321 *gnu_result_type_p
= gnu_result_type
;
1326 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1327 any statements we generate. */
1330 Pragma_to_gnu (Node_Id gnat_node
)
1332 tree gnu_result
= alloc_stmt_list ();
1335 /* Check for (and ignore) unrecognized pragmas. */
1336 if (!Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node
))))
1339 const unsigned char id
1340 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)));
1342 /* Save the expression of pragma Compile_Time_{Error|Warning} for later. */
1343 if (id
== Pragma_Compile_Time_Error
|| id
== Pragma_Compile_Time_Warning
)
1345 gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1346 gnat_compile_time_expr_list
.safe_push (Expression (gnat_temp
));
1350 /* Stop there if we are just annotating types. */
1351 if (type_annotate_only
)
1356 case Pragma_Inspection_Point
:
1357 /* Do nothing at top level: all such variables are already viewable. */
1358 if (global_bindings_p ())
1361 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1362 Present (gnat_temp
);
1363 gnat_temp
= Next (gnat_temp
))
1365 Node_Id gnat_expr
= Expression (gnat_temp
);
1366 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1367 tree asm_constraint
= NULL_TREE
;
1368 #ifdef ASM_COMMENT_START
1371 gnu_expr
= maybe_unconstrained_array (gnu_expr
);
1372 gnat_mark_addressable (gnu_expr
);
1374 #ifdef ASM_COMMENT_START
1375 comment
= concat (ASM_COMMENT_START
,
1376 " inspection point: ",
1377 Get_Name_String (Chars (gnat_expr
)),
1380 asm_constraint
= build_string (strlen (comment
), comment
);
1383 gnu_expr
= build5 (ASM_EXPR
, void_type_node
,
1387 (build_tree_list (NULL_TREE
,
1388 build_string (1, "m")),
1389 gnu_expr
, NULL_TREE
),
1390 NULL_TREE
, NULL_TREE
);
1391 ASM_VOLATILE_P (gnu_expr
) = 1;
1392 set_expr_location_from_node (gnu_expr
, gnat_node
);
1393 append_to_statement_list (gnu_expr
, &gnu_result
);
1397 case Pragma_Loop_Optimize
:
1398 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1399 Present (gnat_temp
);
1400 gnat_temp
= Next (gnat_temp
))
1402 tree gnu_loop_stmt
= gnu_loop_stack
->last ()->stmt
;
1404 switch (Chars (Expression (gnat_temp
)))
1407 LOOP_STMT_IVDEP (gnu_loop_stmt
) = 1;
1410 case Name_No_Unroll
:
1411 LOOP_STMT_NO_UNROLL (gnu_loop_stmt
) = 1;
1415 LOOP_STMT_UNROLL (gnu_loop_stmt
) = 1;
1418 case Name_No_Vector
:
1419 LOOP_STMT_NO_VECTOR (gnu_loop_stmt
) = 1;
1423 LOOP_STMT_VECTOR (gnu_loop_stmt
) = 1;
1432 case Pragma_Optimize
:
1433 switch (Chars (Expression
1434 (First (Pragma_Argument_Associations (gnat_node
)))))
1438 post_error ("must specify -O0?", gnat_node
);
1443 post_error ("must specify -Os?", gnat_node
);
1448 post_error ("insufficient -O value?", gnat_node
);
1456 case Pragma_Reviewable
:
1457 if (write_symbols
== NO_DEBUG
)
1458 post_error ("must specify -g?", gnat_node
);
1461 case Pragma_Warning_As_Error
:
1462 case Pragma_Warnings
:
1465 /* Preserve the location of the pragma. */
1466 const location_t location
= input_location
;
1467 struct cl_option_handlers handlers
;
1468 unsigned int option_index
;
1472 gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1474 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1475 if (Nkind (Expression (gnat_temp
)) == N_String_Literal
)
1479 case Pragma_Warning_As_Error
:
1484 case Pragma_Warnings
:
1493 gnat_expr
= Expression (gnat_temp
);
1496 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1497 else if (Nkind (Expression (gnat_temp
)) == N_Identifier
)
1499 switch (Chars (Expression (gnat_temp
)))
1513 /* Deal with optional pattern (but ignore Reason => "..."). */
1514 if (Present (Next (gnat_temp
))
1515 && Chars (Next (gnat_temp
)) != Name_Reason
)
1517 /* pragma Warnings (On | Off, Name) is handled differently. */
1518 if (Nkind (Expression (Next (gnat_temp
))) != N_String_Literal
)
1521 gnat_expr
= Expression (Next (gnat_temp
));
1527 /* For pragma Warnings (Off), we save the current state... */
1528 if (kind
== DK_IGNORED
)
1529 diagnostic_push_diagnostics (global_dc
, location
);
1531 /* ...so that, for pragma Warnings (On), we do not enable all
1532 the warnings but just restore the previous state. */
1535 diagnostic_pop_diagnostics (global_dc
, location
);
1546 /* This is the same implementation as in the C family of compilers. */
1547 const unsigned int lang_mask
= CL_Ada
| CL_COMMON
;
1548 const char *arg
= NULL
;
1549 if (Present (gnat_expr
))
1551 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1552 const char *option_string
= TREE_STRING_POINTER (gnu_expr
);
1553 const int len
= TREE_STRING_LENGTH (gnu_expr
);
1554 if (len
< 3 || option_string
[0] != '-' || option_string
[1] != 'W')
1556 option_index
= find_opt (option_string
+ 1, lang_mask
);
1557 if (option_index
== OPT_SPECIAL_unknown
)
1559 post_error ("?unknown -W switch", gnat_node
);
1562 else if (!(cl_options
[option_index
].flags
& CL_WARNING
))
1564 post_error ("?-W switch does not control warning", gnat_node
);
1567 else if (!(cl_options
[option_index
].flags
& lang_mask
))
1569 post_error ("?-W switch not valid for Ada", gnat_node
);
1572 if (cl_options
[option_index
].flags
& CL_JOINED
)
1573 arg
= option_string
+ 1 + cl_options
[option_index
].opt_len
;
1578 set_default_handlers (&handlers
, NULL
);
1579 control_warning_option (option_index
, (int) kind
, arg
, imply
, location
,
1580 lang_mask
, &handlers
, &global_options
,
1581 &global_options_set
, global_dc
);
1592 /* Check the inline status of nested function FNDECL wrt its parent function.
1594 If a non-inline nested function is referenced from an inline external
1595 function, we cannot honor both requests at the same time without cloning
1596 the nested function in the current unit since it is private to its unit.
1597 We could inline it as well but it's probably better to err on the side
1598 of too little inlining.
1600 This must be done only on nested functions present in the source code
1601 and not on nested functions generated by the compiler, e.g. finalizers,
1602 because they may be not marked inline and we don't want them to block
1603 the inlining of the parent function. */
1606 check_inlining_for_nested_subprog (tree fndecl
)
1608 if (DECL_IGNORED_P (current_function_decl
) || DECL_IGNORED_P (fndecl
))
1611 if (DECL_DECLARED_INLINE_P (fndecl
))
1614 tree parent_decl
= decl_function_context (fndecl
);
1615 if (DECL_EXTERNAL (parent_decl
) && DECL_DECLARED_INLINE_P (parent_decl
))
1617 const location_t loc1
= DECL_SOURCE_LOCATION (fndecl
);
1618 const location_t loc2
= DECL_SOURCE_LOCATION (parent_decl
);
1620 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl
)))
1622 error_at (loc1
, "subprogram %q+F not marked %<Inline_Always%>",
1624 error_at (loc2
, "parent subprogram cannot be inlined");
1628 warning_at (loc1
, OPT_Winline
, "subprogram %q+F not marked %<Inline%>",
1630 warning_at (loc2
, OPT_Winline
, "parent subprogram cannot be inlined");
1633 DECL_DECLARED_INLINE_P (parent_decl
) = 0;
1634 DECL_UNINLINABLE (parent_decl
) = 1;
1638 /* Return an expression for the length of TYPE, an integral type, computed in
1639 RESULT_TYPE, another integral type.
1641 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
1642 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
1643 which would only overflow in much rarer cases, for extremely large arrays
1644 we expect never to encounter in practice. Besides, the former computation
1645 required the use of potentially constraining signed arithmetics while the
1646 latter does not. Note that the comparison must be done in the original
1647 base index type in order to avoid any overflow during the conversion. */
1650 get_type_length (tree type
, tree result_type
)
1652 tree comp_type
= get_base_type (result_type
);
1653 tree base_type
= maybe_character_type (get_base_type (type
));
1654 tree lb
= convert (base_type
, TYPE_MIN_VALUE (type
));
1655 tree hb
= convert (base_type
, TYPE_MAX_VALUE (type
));
1657 = build_binary_op (PLUS_EXPR
, comp_type
,
1658 build_binary_op (MINUS_EXPR
, comp_type
,
1659 convert (comp_type
, hb
),
1660 convert (comp_type
, lb
)),
1661 build_int_cst (comp_type
, 1));
1663 = build_cond_expr (result_type
,
1664 build_binary_op (GE_EXPR
, boolean_type_node
, hb
, lb
),
1665 convert (result_type
, length
),
1666 build_int_cst (result_type
, 0));
1670 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1671 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1672 where we should place the result type. ATTRIBUTE is the attribute ID. */
1675 Attribute_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, int attribute
)
1677 const Node_Id gnat_prefix
= Prefix (gnat_node
);
1678 tree gnu_prefix
= gnat_to_gnu (gnat_prefix
);
1679 tree gnu_type
= TREE_TYPE (gnu_prefix
);
1680 tree gnu_expr
, gnu_result_type
, gnu_result
= error_mark_node
;
1681 bool prefix_unused
= false;
1683 /* If the input is a NULL_EXPR, make a new one. */
1684 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1686 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1687 *gnu_result_type_p
= gnu_result_type
;
1688 return build1 (NULL_EXPR
, gnu_result_type
, TREE_OPERAND (gnu_prefix
, 0));
1695 /* These just add or subtract the constant 1 since representation
1696 clauses for enumeration types are handled in the front-end. */
1697 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1698 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1699 gnu_type
= maybe_character_type (gnu_result_type
);
1700 if (TREE_TYPE (gnu_expr
) != gnu_type
)
1701 gnu_expr
= convert (gnu_type
, gnu_expr
);
1703 = build_binary_op (attribute
== Attr_Pred
? MINUS_EXPR
: PLUS_EXPR
,
1704 gnu_type
, gnu_expr
, build_int_cst (gnu_type
, 1));
1708 case Attr_Unrestricted_Access
:
1709 /* Conversions don't change the address of references but can cause
1710 build_unary_op to miss the references below, so strip them off.
1711 On the contrary, if the address-of operation causes a temporary
1712 to be created, then it must be created with the proper type. */
1713 gnu_expr
= remove_conversions (gnu_prefix
,
1714 !Must_Be_Byte_Aligned (gnat_node
));
1715 if (REFERENCE_CLASS_P (gnu_expr
))
1716 gnu_prefix
= gnu_expr
;
1718 /* If we are taking 'Address of an unconstrained object, this is the
1719 pointer to the underlying array. */
1720 if (attribute
== Attr_Address
)
1721 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1723 /* If we are building a static dispatch table, we have to honor
1724 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1725 with the C++ ABI. We do it in the non-static case as well,
1726 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1727 else if (TARGET_VTABLE_USES_DESCRIPTORS
1728 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
1731 /* Descriptors can only be built here for top-level functions. */
1732 bool build_descriptor
= (global_bindings_p () != 0);
1734 vec
<constructor_elt
, va_gc
> *gnu_vec
= NULL
;
1735 constructor_elt
*elt
;
1737 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1739 /* If we're not going to build the descriptor, we have to retrieve
1740 the one which will be built by the linker (or by the compiler
1741 later if a static chain is requested). */
1742 if (!build_descriptor
)
1744 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_prefix
);
1745 gnu_result
= fold_convert (build_pointer_type (gnu_result_type
),
1747 gnu_result
= build1 (INDIRECT_REF
, gnu_result_type
, gnu_result
);
1750 vec_safe_grow (gnu_vec
, TARGET_VTABLE_USES_DESCRIPTORS
);
1751 elt
= (gnu_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
1752 for (gnu_field
= TYPE_FIELDS (gnu_result_type
), i
= 0;
1753 i
< TARGET_VTABLE_USES_DESCRIPTORS
;
1754 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
1756 if (build_descriptor
)
1758 t
= build2 (FDESC_EXPR
, TREE_TYPE (gnu_field
), gnu_prefix
,
1759 build_int_cst (NULL_TREE
, i
));
1760 TREE_CONSTANT (t
) = 1;
1763 t
= build3 (COMPONENT_REF
, ptr_void_ftype
, gnu_result
,
1764 gnu_field
, NULL_TREE
);
1766 elt
->index
= gnu_field
;
1771 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
1775 /* ... fall through ... */
1778 case Attr_Unchecked_Access
:
1779 case Attr_Code_Address
:
1780 /* Taking the address of a type does not make sense. */
1781 gcc_assert (TREE_CODE (gnu_prefix
) != TYPE_DECL
);
1783 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1785 = build_unary_op (((attribute
== Attr_Address
1786 || attribute
== Attr_Unrestricted_Access
)
1787 && !Must_Be_Byte_Aligned (gnat_node
))
1788 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1789 gnu_result_type
, gnu_prefix
);
1791 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1792 don't try to build a trampoline. */
1793 if (attribute
== Attr_Code_Address
)
1795 gnu_expr
= remove_conversions (gnu_result
, false);
1797 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1798 TREE_NO_TRAMPOLINE (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1800 /* On targets for which function symbols denote a descriptor, the
1801 code address is stored within the first slot of the descriptor
1802 so we do an additional dereference:
1803 result = *((result_type *) result)
1804 where we expect result to be of some pointer type already. */
1805 if (targetm
.calls
.custom_function_descriptors
== 0)
1807 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1808 convert (build_pointer_type (gnu_result_type
),
1812 /* For 'Access, issue an error message if the prefix is a C++ method
1813 since it can use a special calling convention on some platforms,
1814 which cannot be propagated to the access type. */
1815 else if (attribute
== Attr_Access
1816 && TREE_CODE (TREE_TYPE (gnu_prefix
)) == METHOD_TYPE
)
1817 post_error ("access to C++ constructor or member function not allowed",
1820 /* For other address attributes applied to a nested function,
1821 find an inner ADDR_EXPR and annotate it so that we can issue
1822 a useful warning with -Wtrampolines. */
1823 else if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_prefix
))
1824 && (gnu_expr
= remove_conversions (gnu_result
, false))
1825 && TREE_CODE (gnu_expr
) == ADDR_EXPR
1826 && decl_function_context (TREE_OPERAND (gnu_expr
, 0)))
1828 set_expr_location_from_node (gnu_expr
, gnat_node
);
1830 /* Also check the inlining status. */
1831 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr
, 0));
1833 /* Moreover, for 'Access or 'Unrestricted_Access with non-
1834 foreign-compatible representation, mark the ADDR_EXPR so
1835 that we can build a descriptor instead of a trampoline. */
1836 if ((attribute
== Attr_Access
1837 || attribute
== Attr_Unrestricted_Access
)
1838 && targetm
.calls
.custom_function_descriptors
> 0
1839 && Can_Use_Internal_Rep (Underlying_Type (Etype (gnat_node
))))
1840 FUNC_ADDR_BY_DESCRIPTOR (gnu_expr
) = 1;
1842 /* Otherwise, we need to check that we are not violating the
1843 No_Implicit_Dynamic_Code restriction. */
1844 else if (targetm
.calls
.custom_function_descriptors
!= 0)
1845 Check_Implicit_Dynamic_Code_Allowed (gnat_node
);
1849 case Attr_Pool_Address
:
1851 tree gnu_ptr
= gnu_prefix
;
1854 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1856 /* If this is fat pointer, the object must have been allocated with the
1857 template in front of the array. So compute the template address; do
1858 it by converting to a thin pointer. */
1859 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
1861 = convert (build_pointer_type
1862 (TYPE_OBJECT_RECORD_TYPE
1863 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
1866 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
1868 /* If this is a thin pointer, the object must have been allocated with
1869 the template in front of the array. So compute the template address
1871 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
1873 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
1875 fold_build1 (NEGATE_EXPR
, sizetype
,
1878 TYPE_FIELDS ((gnu_obj_type
)))));
1880 gnu_result
= convert (gnu_result_type
, gnu_ptr
);
1885 case Attr_Object_Size
:
1886 case Attr_Value_Size
:
1887 case Attr_Max_Size_In_Storage_Elements
:
1888 /* Strip NOPs, conversions between original and packable versions, and
1889 unpadding from GNU_PREFIX. Note that we cannot simply strip every
1890 VIEW_CONVERT_EXPR because some of them may give the actual size, e.g.
1891 for nominally unconstrained packed array. We use GNU_EXPR to see
1892 if a COMPONENT_REF was involved. */
1893 while (CONVERT_EXPR_P (gnu_prefix
)
1894 || TREE_CODE (gnu_prefix
) == NON_LVALUE_EXPR
1895 || (TREE_CODE (gnu_prefix
) == VIEW_CONVERT_EXPR
1896 && TREE_CODE (TREE_TYPE (gnu_prefix
)) == RECORD_TYPE
1897 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1899 && TYPE_NAME (TREE_TYPE (gnu_prefix
))
1900 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1901 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1902 gnu_expr
= gnu_prefix
;
1903 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1904 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
1905 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1906 prefix_unused
= true;
1907 gnu_type
= TREE_TYPE (gnu_prefix
);
1909 /* Replace an unconstrained array type with the type of the underlying
1910 array, except for 'Max_Size_In_Storage_Elements because we need to
1911 return the (maximum) size requested for an allocator. */
1912 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1914 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1915 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1916 gnu_type
= TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
1919 /* The type must be frozen at this point. */
1920 gcc_assert (COMPLETE_TYPE_P (gnu_type
));
1922 /* If we're looking for the size of a field, return the field size. */
1923 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1924 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1926 /* Otherwise, if the prefix is an object, or if we are looking for
1927 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1928 GCC size of the type. We make an exception for padded objects,
1929 as we do not take into account alignment promotions for the size.
1930 This is in keeping with the object case of gnat_to_gnu_entity. */
1931 else if ((TREE_CODE (gnu_prefix
) != TYPE_DECL
1932 && !(TYPE_IS_PADDING_P (gnu_type
)
1933 && TREE_CODE (gnu_expr
) == COMPONENT_REF
1934 && pad_type_has_rm_size (gnu_type
)))
1935 || attribute
== Attr_Object_Size
1936 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1938 /* If this is a dereference and we have a special dynamic constrained
1939 subtype on the prefix, use it to compute the size; otherwise, use
1940 the designated subtype. */
1941 if (Nkind (gnat_prefix
) == N_Explicit_Dereference
)
1943 Node_Id gnat_actual_subtype
1944 = Actual_Designated_Subtype (gnat_prefix
);
1946 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix
)));
1948 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
)
1949 && Present (gnat_actual_subtype
))
1951 tree gnu_actual_obj_type
1952 = gnat_to_gnu_type (gnat_actual_subtype
);
1954 = build_unc_object_type_from_ptr (gnu_ptr_type
,
1955 gnu_actual_obj_type
,
1956 get_identifier ("SIZE"),
1961 gnu_result
= TYPE_SIZE (gnu_type
);
1964 /* Otherwise, the result is the RM size of the type. */
1966 gnu_result
= rm_size (gnu_type
);
1968 /* Deal with a self-referential size by qualifying the size with the
1969 object or returning the maximum size for a type. */
1970 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1971 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
1972 else if (CONTAINS_PLACEHOLDER_P (gnu_result
))
1973 gnu_result
= max_size (gnu_result
, true);
1975 /* If the type contains a template, subtract the padded size of the
1976 template, except for 'Max_Size_In_Storage_Elements because we need
1977 to return the (maximum) size requested for an allocator. */
1978 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1979 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
1980 && attribute
!= Attr_Max_Size_In_Storage_Elements
)
1982 = size_binop (MINUS_EXPR
, gnu_result
,
1983 bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type
))));
1985 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
1986 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1987 gnu_result
= size_binop (CEIL_DIV_EXPR
, gnu_result
, bitsize_unit_node
);
1989 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1992 case Attr_Alignment
:
1996 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1997 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
1998 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
2000 gnu_type
= TREE_TYPE (gnu_prefix
);
2001 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2002 prefix_unused
= true;
2004 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2005 align
= DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)) / BITS_PER_UNIT
;
2008 Entity_Id gnat_type
= Etype (gnat_prefix
);
2009 unsigned int double_align
;
2010 bool is_capped_double
, align_clause
;
2012 /* If the default alignment of "double" or larger scalar types is
2013 specifically capped and there is an alignment clause neither
2014 on the type nor on the prefix itself, return the cap. */
2015 if ((double_align
= double_float_alignment
) > 0)
2017 = is_double_float_or_array (gnat_type
, &align_clause
);
2018 else if ((double_align
= double_scalar_alignment
) > 0)
2020 = is_double_scalar_or_array (gnat_type
, &align_clause
);
2022 is_capped_double
= align_clause
= false;
2024 if (is_capped_double
2025 && Nkind (gnat_prefix
) == N_Identifier
2026 && Present (Alignment_Clause (Entity (gnat_prefix
))))
2027 align_clause
= true;
2029 if (is_capped_double
&& !align_clause
)
2030 align
= double_align
;
2032 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
2035 gnu_result
= size_int (align
);
2041 case Attr_Range_Length
:
2042 prefix_unused
= true;
2044 if (INTEGRAL_TYPE_P (gnu_type
) || SCALAR_FLOAT_TYPE_P (gnu_type
))
2046 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2048 if (attribute
== Attr_First
)
2049 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
2050 else if (attribute
== Attr_Last
)
2051 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
2053 gnu_result
= get_type_length (gnu_type
, gnu_result_type
);
2057 /* ... fall through ... */
2061 int Dimension
= (Present (Expressions (gnat_node
))
2062 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
2064 struct parm_attr_d
*pa
= NULL
;
2065 Entity_Id gnat_param
= Empty
;
2066 bool unconstrained_ptr_deref
= false;
2068 gnu_prefix
= maybe_padded_object (gnu_prefix
);
2069 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
2071 /* We treat unconstrained array In parameters specially. We also note
2072 whether we are dereferencing a pointer to unconstrained array. */
2073 if (!Is_Constrained (Etype (gnat_prefix
)))
2074 switch (Nkind (gnat_prefix
))
2077 /* This is the direct case. */
2078 if (Ekind (Entity (gnat_prefix
)) == E_In_Parameter
)
2079 gnat_param
= Entity (gnat_prefix
);
2082 case N_Explicit_Dereference
:
2083 /* This is the indirect case. Note that we need to be sure that
2084 the access value cannot be null as we'll hoist the load. */
2085 if (Nkind (Prefix (gnat_prefix
)) == N_Identifier
2086 && Ekind (Entity (Prefix (gnat_prefix
))) == E_In_Parameter
)
2088 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix
))))
2089 gnat_param
= Entity (Prefix (gnat_prefix
));
2092 unconstrained_ptr_deref
= true;
2099 /* If the prefix is the view conversion of a constrained array to an
2100 unconstrained form, we retrieve the constrained array because we
2101 might not be able to substitute the PLACEHOLDER_EXPR coming from
2102 the conversion. This can occur with the 'Old attribute applied
2103 to a parameter with an unconstrained type, which gets rewritten
2104 into a constrained local variable very late in the game. */
2105 if (TREE_CODE (gnu_prefix
) == VIEW_CONVERT_EXPR
2106 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix
)))
2107 && !CONTAINS_PLACEHOLDER_P
2108 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
2109 gnu_type
= TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0));
2111 gnu_type
= TREE_TYPE (gnu_prefix
);
2113 prefix_unused
= true;
2114 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2116 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
2121 for (ndim
= 1, gnu_type_temp
= gnu_type
;
2122 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
2123 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
2124 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
2127 Dimension
= ndim
+ 1 - Dimension
;
2130 for (i
= 1; i
< Dimension
; i
++)
2131 gnu_type
= TREE_TYPE (gnu_type
);
2133 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
2135 /* When not optimizing, look up the slot associated with the parameter
2136 and the dimension in the cache and create a new one on failure.
2137 Don't do this when the actual subtype needs debug info (this happens
2138 with -gnatD): in elaborate_expression_1, we create variables that
2139 hold the bounds, so caching attributes isn't very interesting and
2140 causes dependency issues between these variables and cached
2143 && Present (gnat_param
)
2144 && !(Present (Actual_Subtype (gnat_param
))
2145 && Needs_Debug_Info (Actual_Subtype (gnat_param
))))
2147 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache
, i
, pa
)
2148 if (pa
->id
== gnat_param
&& pa
->dim
== Dimension
)
2153 pa
= ggc_cleared_alloc
<parm_attr_d
> ();
2154 pa
->id
= gnat_param
;
2155 pa
->dim
= Dimension
;
2156 vec_safe_push (f_parm_attr_cache
, pa
);
2160 /* Return the cached expression or build a new one. */
2161 if (attribute
== Attr_First
)
2163 if (pa
&& pa
->first
)
2165 gnu_result
= pa
->first
;
2170 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
2173 else if (attribute
== Attr_Last
)
2177 gnu_result
= pa
->last
;
2182 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
2185 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2187 if (pa
&& pa
->length
)
2189 gnu_result
= pa
->length
;
2194 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)),
2198 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2199 handling. Note that these attributes could not have been used on
2200 an unconstrained array type. */
2201 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
2203 /* Cache the expression we have just computed. Since we want to do it
2204 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2205 create the temporary in the outermost binding level. We will make
2206 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2207 paths by forcing its evaluation on entry of the function. */
2211 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
2215 pa
->first
= gnu_result
;
2219 pa
->last
= gnu_result
;
2223 case Attr_Range_Length
:
2224 pa
->length
= gnu_result
;
2232 /* Otherwise, evaluate it each time it is referenced. */
2238 /* If we are dereferencing a pointer to unconstrained array, we
2239 need to capture the value because the pointed-to bounds may
2240 subsequently be released. */
2241 if (unconstrained_ptr_deref
)
2243 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
2247 case Attr_Range_Length
:
2248 /* Set the source location onto the predicate of the condition
2249 but not if the expression is cached to avoid messing up the
2251 if (TREE_CODE (gnu_result
) == COND_EXPR
2252 && EXPR_P (TREE_OPERAND (gnu_result
, 0)))
2253 set_expr_location_from_node (TREE_OPERAND (gnu_result
, 0),
2264 case Attr_Bit_Position
:
2266 case Attr_First_Bit
:
2273 tree gnu_field_bitpos
;
2274 tree gnu_field_offset
;
2277 int unsignedp
, reversep
, volatilep
;
2279 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2280 gnu_prefix
= remove_conversions (gnu_prefix
, true);
2281 prefix_unused
= true;
2283 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2284 the result is 0. Don't allow 'Bit on a bare component, though. */
2285 if (attribute
== Attr_Bit
2286 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
2287 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
2289 gnu_result
= integer_zero_node
;
2294 gcc_assert (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2295 || (attribute
== Attr_Bit_Position
2296 && TREE_CODE (gnu_prefix
) == FIELD_DECL
));
2298 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
2299 &mode
, &unsignedp
, &reversep
, &volatilep
);
2301 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2303 gnu_field_bitpos
= bit_position (TREE_OPERAND (gnu_prefix
, 1));
2304 gnu_field_offset
= byte_position (TREE_OPERAND (gnu_prefix
, 1));
2306 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
2307 TREE_CODE (gnu_inner
) == COMPONENT_REF
2308 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
2309 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
2312 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
2313 bit_position (TREE_OPERAND (gnu_inner
, 1)));
2315 = size_binop (PLUS_EXPR
, gnu_field_offset
,
2316 byte_position (TREE_OPERAND (gnu_inner
, 1)));
2319 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
2321 gnu_field_bitpos
= bit_position (gnu_prefix
);
2322 gnu_field_offset
= byte_position (gnu_prefix
);
2326 gnu_field_bitpos
= bitsize_zero_node
;
2327 gnu_field_offset
= size_zero_node
;
2333 gnu_result
= gnu_field_offset
;
2336 case Attr_First_Bit
:
2338 gnu_result
= size_int (num_trailing_bits (bitpos
));
2342 gnu_result
= bitsize_int (num_trailing_bits (bitpos
));
2343 gnu_result
= size_binop (PLUS_EXPR
, gnu_result
,
2344 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
2345 /* ??? Avoid a large unsigned result that will overflow when
2346 converted to the signed universal_integer. */
2347 if (integer_zerop (gnu_result
))
2348 gnu_result
= integer_minus_one_node
;
2351 = size_binop (MINUS_EXPR
, gnu_result
, bitsize_one_node
);
2354 case Attr_Bit_Position
:
2355 gnu_result
= gnu_field_bitpos
;
2359 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2361 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
2368 tree gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
2369 tree gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
2371 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2373 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2374 a NaN so we implement the semantics of C99 f{min,max} to make it
2375 predictable in this case: if either operand is a NaN, the other
2376 is returned; if both operands are NaN's, a NaN is returned. */
2377 if (SCALAR_FLOAT_TYPE_P (gnu_result_type
)
2378 && !Machine_Overflows_On_Target
)
2380 const bool lhs_side_effects_p
= TREE_SIDE_EFFECTS (gnu_lhs
);
2381 const bool rhs_side_effects_p
= TREE_SIDE_EFFECTS (gnu_rhs
);
2382 tree t
= builtin_decl_explicit (BUILT_IN_ISNAN
);
2383 tree lhs_is_nan
, rhs_is_nan
;
2385 /* If the operands have side-effects, they need to be evaluated
2386 only once in spite of the multiple references in the result. */
2387 if (lhs_side_effects_p
)
2388 gnu_lhs
= gnat_protect_expr (gnu_lhs
);
2389 if (rhs_side_effects_p
)
2390 gnu_rhs
= gnat_protect_expr (gnu_rhs
);
2392 lhs_is_nan
= fold_build2 (NE_EXPR
, boolean_type_node
,
2393 build_call_expr (t
, 1, gnu_lhs
),
2396 rhs_is_nan
= fold_build2 (NE_EXPR
, boolean_type_node
,
2397 build_call_expr (t
, 1, gnu_rhs
),
2400 gnu_result
= build_binary_op (attribute
== Attr_Min
2401 ? MIN_EXPR
: MAX_EXPR
,
2402 gnu_result_type
, gnu_lhs
, gnu_rhs
);
2403 gnu_result
= fold_build3 (COND_EXPR
, gnu_result_type
,
2404 rhs_is_nan
, gnu_lhs
, gnu_result
);
2405 gnu_result
= fold_build3 (COND_EXPR
, gnu_result_type
,
2406 lhs_is_nan
, gnu_rhs
, gnu_result
);
2408 /* If the operands have side-effects, they need to be evaluated
2409 before doing the tests above since the place they otherwise
2410 would end up being evaluated at run time could be wrong. */
2411 if (lhs_side_effects_p
)
2413 = build2 (COMPOUND_EXPR
, gnu_result_type
, gnu_lhs
, gnu_result
);
2415 if (rhs_side_effects_p
)
2417 = build2 (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs
, gnu_result
);
2420 gnu_result
= build_binary_op (attribute
== Attr_Min
2421 ? MIN_EXPR
: MAX_EXPR
,
2422 gnu_result_type
, gnu_lhs
, gnu_rhs
);
2426 case Attr_Passed_By_Reference
:
2427 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
2428 || must_pass_by_ref (gnu_type
));
2429 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2432 case Attr_Component_Size
:
2433 gnu_prefix
= maybe_padded_object (gnu_prefix
);
2434 gnu_type
= TREE_TYPE (gnu_prefix
);
2436 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
2437 gnu_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
2439 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
2440 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
2441 gnu_type
= TREE_TYPE (gnu_type
);
2443 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
2445 /* Note this size cannot be self-referential. */
2446 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
2447 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2448 prefix_unused
= true;
2451 case Attr_Descriptor_Size
:
2452 gnu_type
= TREE_TYPE (gnu_prefix
);
2453 gcc_assert (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
);
2455 /* Return the padded size of the template in the object record type. */
2456 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
2457 gnu_result
= bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
2458 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2459 prefix_unused
= true;
2462 case Attr_Null_Parameter
:
2463 /* This is just a zero cast to the pointer type for our prefix and
2465 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2467 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
2468 convert (build_pointer_type (gnu_result_type
),
2469 integer_zero_node
));
2472 case Attr_Mechanism_Code
:
2474 Entity_Id gnat_obj
= Entity (gnat_prefix
);
2477 prefix_unused
= true;
2478 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2479 if (Present (Expressions (gnat_node
)))
2481 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
2483 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
2484 i
--, gnat_obj
= Next_Formal (gnat_obj
))
2488 code
= Mechanism (gnat_obj
);
2489 if (code
== Default
)
2490 code
= ((present_gnu_tree (gnat_obj
)
2491 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
2492 || ((TREE_CODE (get_gnu_tree (gnat_obj
))
2494 && (DECL_BY_COMPONENT_PTR_P
2495 (get_gnu_tree (gnat_obj
))))))
2496 ? By_Reference
: By_Copy
);
2497 gnu_result
= convert (gnu_result_type
, size_int (- code
));
2502 /* We treat Model as identical to Machine. This is true for at least
2503 IEEE and some other nice floating-point systems. */
2505 /* ... fall through ... */
2508 /* The trick is to force the compiler to store the result in memory so
2509 that we do not have extra precision used. But do this only when this
2510 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2511 the type is lower than that of the longest floating-point type. */
2512 prefix_unused
= true;
2513 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2514 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2515 gnu_result
= convert (gnu_result_type
, gnu_expr
);
2517 if (TREE_CODE (gnu_result
) != REAL_CST
2518 && fp_arith_may_widen
2519 && TYPE_PRECISION (gnu_result_type
)
2520 < TYPE_PRECISION (longest_float_type_node
))
2522 tree rec_type
= make_node (RECORD_TYPE
);
2524 = create_field_decl (get_identifier ("OBJ"), gnu_result_type
,
2525 rec_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2526 tree rec_val
, asm_expr
;
2528 finish_record_type (rec_type
, field
, 0, false);
2530 rec_val
= build_constructor_single (rec_type
, field
, gnu_result
);
2531 rec_val
= build1 (SAVE_EXPR
, rec_type
, rec_val
);
2534 = build5 (ASM_EXPR
, void_type_node
,
2535 build_string (0, ""),
2536 tree_cons (build_tree_list (NULL_TREE
,
2537 build_string (2, "=m")),
2538 rec_val
, NULL_TREE
),
2539 tree_cons (build_tree_list (NULL_TREE
,
2540 build_string (1, "m")),
2541 rec_val
, NULL_TREE
),
2542 NULL_TREE
, NULL_TREE
);
2543 ASM_VOLATILE_P (asm_expr
) = 1;
2546 = build_compound_expr (gnu_result_type
, asm_expr
,
2547 build_component_ref (rec_val
, field
,
2553 prefix_unused
= true;
2554 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
2555 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2556 /* This can be a random address so build an alias-all pointer type. */
2558 = convert (build_pointer_type_for_mode (gnu_result_type
, ptr_mode
,
2561 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_expr
);
2565 /* This abort means that we have an unimplemented attribute. */
2569 /* If this is an attribute where the prefix was unused, force a use of it if
2570 it has a side-effect. But don't do it if the prefix is just an entity
2571 name. However, if an access check is needed, we must do it. See second
2572 example in AARM 11.6(5.e). */
2574 && TREE_SIDE_EFFECTS (gnu_prefix
)
2575 && !Is_Entity_Name (gnat_prefix
))
2577 = build_compound_expr (TREE_TYPE (gnu_result
), gnu_prefix
, gnu_result
);
2579 *gnu_result_type_p
= gnu_result_type
;
2583 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2584 to a GCC tree, which is returned. */
2587 Case_Statement_to_gnu (Node_Id gnat_node
)
2589 tree gnu_result
, gnu_expr
, gnu_type
, gnu_label
;
2591 location_t end_locus
;
2592 bool may_fallthru
= false;
2594 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2595 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2596 gnu_expr
= maybe_character_value (gnu_expr
);
2597 gnu_type
= TREE_TYPE (gnu_expr
);
2599 /* We build a SWITCH_EXPR that contains the code with interspersed
2600 CASE_LABEL_EXPRs for each label. */
2601 if (!Sloc_to_locus (End_Location (gnat_node
), &end_locus
))
2602 end_locus
= input_location
;
2603 gnu_label
= create_artificial_label (end_locus
);
2604 start_stmt_group ();
2606 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2607 Present (gnat_when
);
2608 gnat_when
= Next_Non_Pragma (gnat_when
))
2610 bool choices_added_p
= false;
2611 Node_Id gnat_choice
;
2613 /* First compile all the different case choices for the current WHEN
2615 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2616 Present (gnat_choice
);
2617 gnat_choice
= Next (gnat_choice
))
2619 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2620 tree label
= create_artificial_label (input_location
);
2622 switch (Nkind (gnat_choice
))
2625 gnu_low
= gnat_to_gnu (Low_Bound (gnat_choice
));
2626 gnu_high
= gnat_to_gnu (High_Bound (gnat_choice
));
2629 case N_Subtype_Indication
:
2630 gnu_low
= gnat_to_gnu (Low_Bound (Range_Expression
2631 (Constraint (gnat_choice
))));
2632 gnu_high
= gnat_to_gnu (High_Bound (Range_Expression
2633 (Constraint (gnat_choice
))));
2637 case N_Expanded_Name
:
2638 /* This represents either a subtype range or a static value of
2639 some kind; Ekind says which. */
2640 if (Is_Type (Entity (gnat_choice
)))
2642 tree gnu_type
= get_unpadded_type (Entity (gnat_choice
));
2644 gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2645 gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2649 /* ... fall through ... */
2651 case N_Character_Literal
:
2652 case N_Integer_Literal
:
2653 gnu_low
= gnat_to_gnu (gnat_choice
);
2656 case N_Others_Choice
:
2663 /* Everything should be folded into constants at this point. */
2664 gcc_assert (!gnu_low
|| TREE_CODE (gnu_low
) == INTEGER_CST
);
2665 gcc_assert (!gnu_high
|| TREE_CODE (gnu_high
) == INTEGER_CST
);
2667 if (gnu_low
&& TREE_TYPE (gnu_low
) != gnu_type
)
2668 gnu_low
= convert (gnu_type
, gnu_low
);
2669 if (gnu_high
&& TREE_TYPE (gnu_high
) != gnu_type
)
2670 gnu_high
= convert (gnu_type
, gnu_high
);
2672 add_stmt_with_node (build_case_label (gnu_low
, gnu_high
, label
),
2674 choices_added_p
= true;
2677 /* This construct doesn't define a scope so we shouldn't push a binding
2678 level around the statement list. Except that we have always done so
2679 historically and this makes it possible to reduce stack usage. As a
2680 compromise, we keep doing it for case statements, for which this has
2681 never been problematic, but not for case expressions in Ada 2012. */
2682 if (choices_added_p
)
2684 const bool is_case_expression
2685 = (Nkind (Parent (gnat_node
)) == N_Expression_With_Actions
);
2687 = build_stmt_group (Statements (gnat_when
), !is_case_expression
);
2688 bool group_may_fallthru
= block_may_fallthru (group
);
2690 if (group_may_fallthru
)
2692 tree stmt
= build1 (GOTO_EXPR
, void_type_node
, gnu_label
);
2693 SET_EXPR_LOCATION (stmt
, end_locus
);
2695 may_fallthru
= true;
2700 /* Now emit a definition of the label the cases branch to, if any. */
2702 add_stmt (build1 (LABEL_EXPR
, void_type_node
, gnu_label
));
2703 gnu_result
= build2 (SWITCH_EXPR
, gnu_type
, gnu_expr
, end_stmt_group ());
2708 /* Return true if we are in the body of a loop. */
2711 inside_loop_p (void)
2713 return !vec_safe_is_empty (gnu_loop_stack
);
2716 /* Find out whether EXPR is a simple additive expression based on the iteration
2717 variable of some enclosing loop in the current function. If so, return the
2718 loop and set *DISP to the displacement and *NEG_P to true if this is for a
2719 subtraction; otherwise, return NULL. */
2721 static struct loop_info_d
*
2722 find_loop_for (tree expr
, tree
*disp
, bool *neg_p
)
2726 struct loop_info_d
*iter
= NULL
;
2729 if (is_simple_additive_expression (expr
, &add
, &cst
, &minus_p
))
2746 var
= remove_conversions (var
, false);
2748 if (TREE_CODE (var
) != VAR_DECL
)
2751 if (decl_function_context (var
) != current_function_decl
)
2754 gcc_assert (vec_safe_length (gnu_loop_stack
) > 0);
2756 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack
, i
, iter
)
2757 if (var
== iter
->loop_var
)
2763 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2764 false, or the maximum value if MAX is true, of TYPE. */
2767 can_equal_min_or_max_val_p (tree val
, tree type
, bool max
)
2769 tree min_or_max_val
= (max
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
));
2771 if (TREE_CODE (min_or_max_val
) != INTEGER_CST
)
2774 if (TREE_CODE (val
) == NOP_EXPR
)
2776 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0)))
2777 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0))));
2779 if (TREE_CODE (val
) != INTEGER_CST
)
2783 return tree_int_cst_lt (val
, min_or_max_val
) == 0;
2785 return tree_int_cst_lt (min_or_max_val
, val
) == 0;
2788 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2789 If REVERSE is true, minimum value is taken as maximum value. */
2792 can_equal_min_val_p (tree val
, tree type
, bool reverse
)
2794 return can_equal_min_or_max_val_p (val
, type
, reverse
);
2797 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2798 If REVERSE is true, maximum value is taken as minimum value. */
2801 can_equal_max_val_p (tree val
, tree type
, bool reverse
)
2803 return can_equal_min_or_max_val_p (val
, type
, !reverse
);
2806 /* Return true if VAL1 can be lower than VAL2. */
2809 can_be_lower_p (tree val1
, tree val2
)
2811 if (TREE_CODE (val1
) == NOP_EXPR
)
2813 tree type
= TREE_TYPE (TREE_OPERAND (val1
, 0));
2814 if (can_be_lower_p (TYPE_MAX_VALUE (type
), TYPE_MIN_VALUE (type
)))
2817 val1
= TYPE_MIN_VALUE (type
);
2820 if (TREE_CODE (val1
) != INTEGER_CST
)
2823 if (TREE_CODE (val2
) == NOP_EXPR
)
2825 tree type
= TREE_TYPE (TREE_OPERAND (val2
, 0));
2826 if (can_be_lower_p (TYPE_MAX_VALUE (type
), TYPE_MIN_VALUE (type
)))
2829 val2
= TYPE_MAX_VALUE (type
);
2832 if (TREE_CODE (val2
) != INTEGER_CST
)
2835 return tree_int_cst_lt (val1
, val2
);
2838 /* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
2839 true if both expressions have been replaced and false otherwise. */
2842 make_invariant (tree
*expr1
, tree
*expr2
)
2844 tree inv_expr1
= gnat_invariant_expr (*expr1
);
2845 tree inv_expr2
= gnat_invariant_expr (*expr2
);
2853 return inv_expr1
&& inv_expr2
;
2856 /* Helper function for walk_tree, used by independent_iterations_p below. */
2859 scan_rhs_r (tree
*tp
, int *walk_subtrees
, void *data
)
2861 bitmap
*params
= (bitmap
*)data
;
2864 /* No need to walk into types or decls. */
2865 if (IS_TYPE_OR_DECL_P (t
))
2868 if (TREE_CODE (t
) == PARM_DECL
&& bitmap_bit_p (*params
, DECL_UID (t
)))
2874 /* Return true if STMT_LIST generates independent iterations in a loop. */
2877 independent_iterations_p (tree stmt_list
)
2879 tree_stmt_iterator tsi
;
2880 bitmap params
= BITMAP_GGC_ALLOC();
2881 auto_vec
<tree
, 16> rhs
;
2885 if (TREE_CODE (stmt_list
) == BIND_EXPR
)
2886 stmt_list
= BIND_EXPR_BODY (stmt_list
);
2888 /* Scan the list and return false on anything that is not either a check
2889 or an assignment to a parameter with restricted aliasing. */
2890 for (tsi
= tsi_start (stmt_list
); !tsi_end_p (tsi
); tsi_next (&tsi
))
2892 tree stmt
= tsi_stmt (tsi
);
2894 switch (TREE_CODE (stmt
))
2898 if (COND_EXPR_ELSE (stmt
))
2900 if (TREE_CODE (COND_EXPR_THEN (stmt
)) != CALL_EXPR
)
2902 tree func
= get_callee_fndecl (COND_EXPR_THEN (stmt
));
2903 if (!(func
&& TREE_THIS_VOLATILE (func
)))
2910 tree lhs
= TREE_OPERAND (stmt
, 0);
2911 while (handled_component_p (lhs
))
2912 lhs
= TREE_OPERAND (lhs
, 0);
2913 if (TREE_CODE (lhs
) != INDIRECT_REF
)
2915 lhs
= TREE_OPERAND (lhs
, 0);
2916 if (!(TREE_CODE (lhs
) == PARM_DECL
2917 && DECL_RESTRICTED_ALIASING_P (lhs
)))
2919 bitmap_set_bit (params
, DECL_UID (lhs
));
2920 rhs
.safe_push (TREE_OPERAND (stmt
, 1));
2929 /* At this point we know that the list contains only statements that will
2930 modify parameters with restricted aliasing. Check that the statements
2931 don't at the time read from these parameters. */
2932 FOR_EACH_VEC_ELT (rhs
, i
, iter
)
2933 if (walk_tree_without_duplicates (&iter
, scan_rhs_r
, ¶ms
))
2939 /* Helper for Loop_Statement_to_gnu, to translate the body of a loop not
2940 subject to any sort of parallelization directive or restriction, designated
2943 We expect the top of gnu_loop_stack to hold a pointer to the loop info
2944 setup for the translation, which holds a pointer to the initial gnu loop
2945 stmt node. We return the new gnu loop statement to use.
2947 We might also set *GNU_COND_EXPR_P to request a variant of the translation
2948 scheme in Loop_Statement_to_gnu. */
2951 Regular_Loop_to_gnu (Node_Id gnat_node
, tree
*gnu_cond_expr_p
)
2953 const Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2954 struct loop_info_d
*const gnu_loop_info
= gnu_loop_stack
->last ();
2955 tree gnu_loop_stmt
= gnu_loop_info
->stmt
;
2956 tree gnu_loop_label
= LOOP_STMT_LABEL (gnu_loop_stmt
);
2957 tree gnu_cond_expr
= *gnu_cond_expr_p
;
2958 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2960 /* Set the condition under which the loop must keep going. If we have an
2961 explicit condition, use it to set the location information throughout
2962 the translation of the loop statement to avoid having multiple SLOCs.
2964 For the case "LOOP .... END LOOP;" the condition is always true. */
2965 if (No (gnat_iter_scheme
))
2968 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2969 else if (Present (Condition (gnat_iter_scheme
)))
2971 LOOP_STMT_COND (gnu_loop_stmt
)
2972 = gnat_to_gnu (Condition (gnat_iter_scheme
));
2974 set_expr_location_from_node (gnu_loop_stmt
, gnat_iter_scheme
);
2977 /* Otherwise we have an iteration scheme and the condition is given by the
2978 bounds of the subtype of the iteration variable. */
2981 Node_Id gnat_loop_spec
= Loop_Parameter_Specification (gnat_iter_scheme
);
2982 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2983 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2984 tree gnu_type
= get_unpadded_type (gnat_type
);
2985 tree gnu_base_type
= maybe_character_type (get_base_type (gnu_type
));
2986 tree gnu_one_node
= build_int_cst (gnu_base_type
, 1);
2987 tree gnu_loop_var
, gnu_loop_iv
, gnu_first
, gnu_last
, gnu_stmt
;
2988 enum tree_code update_code
, test_code
, shift_code
;
2989 bool reverse
= Reverse_Present (gnat_loop_spec
), use_iv
= false;
2991 gnu_low
= convert (gnu_base_type
, TYPE_MIN_VALUE (gnu_type
));
2992 gnu_high
= convert (gnu_base_type
, TYPE_MAX_VALUE (gnu_type
));
2994 /* We must disable modulo reduction for the iteration variable, if any,
2995 in order for the loop comparison to be effective. */
2998 gnu_first
= gnu_high
;
3000 update_code
= MINUS_NOMOD_EXPR
;
3001 test_code
= GE_EXPR
;
3002 shift_code
= PLUS_NOMOD_EXPR
;
3006 gnu_first
= gnu_low
;
3007 gnu_last
= gnu_high
;
3008 update_code
= PLUS_NOMOD_EXPR
;
3009 test_code
= LE_EXPR
;
3010 shift_code
= MINUS_NOMOD_EXPR
;
3013 /* We use two different strategies to translate the loop, depending on
3014 whether optimization is enabled.
3016 If it is, we generate the canonical loop form expected by the loop
3017 optimizer and the loop vectorizer, which is the do-while form:
3026 This avoids an implicit dependency on loop header copying and makes
3027 it possible to turn BOTTOM_COND into an inequality test.
3029 If optimization is disabled, loop header copying doesn't come into
3030 play and we try to generate the loop form with the fewer conditional
3031 branches. First, the default form, which is:
3039 It should catch most loops with constant ending point. Then, if we
3040 cannot, we try to generate the shifted form:
3048 which should catch loops with constant starting point. Otherwise, if
3049 we cannot, we generate the fallback form:
3058 which works in all cases. */
3060 if (optimize
&& !optimize_debug
)
3062 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
3064 if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
))
3067 /* Otherwise, use the do-while form with the help of a special
3068 induction variable in the unsigned version of the base type
3069 or the unsigned version of the size type, whichever is the
3070 largest, in order to have wrap-around arithmetics for it. */
3073 if (TYPE_PRECISION (gnu_base_type
)
3074 > TYPE_PRECISION (size_type_node
))
3076 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type
), 1);
3078 gnu_base_type
= size_type_node
;
3080 gnu_first
= convert (gnu_base_type
, gnu_first
);
3081 gnu_last
= convert (gnu_base_type
, gnu_last
);
3082 gnu_one_node
= build_int_cst (gnu_base_type
, 1);
3087 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
3089 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
3090 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
3094 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
3095 if (!can_equal_max_val_p (gnu_last
, gnu_base_type
, reverse
))
3098 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
3100 else if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
)
3101 && !can_equal_min_val_p (gnu_last
, gnu_base_type
, reverse
))
3104 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
3107 = build_binary_op (shift_code
, gnu_base_type
, gnu_last
,
3109 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
3112 /* Otherwise, use the fallback form. */
3114 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
3117 /* If we use the BOTTOM_COND, we can turn the test into an inequality
3118 test but we may have to add ENTRY_COND to protect the empty loop. */
3119 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
))
3121 test_code
= NE_EXPR
;
3122 if (can_be_lower_p (gnu_high
, gnu_low
))
3125 = build3 (COND_EXPR
, void_type_node
,
3126 build_binary_op (LE_EXPR
, boolean_type_node
,
3128 NULL_TREE
, alloc_stmt_list ());
3129 set_expr_location_from_node (gnu_cond_expr
, gnat_iter_scheme
);
3133 /* Open a new nesting level that will surround the loop to declare the
3134 iteration variable. */
3135 start_stmt_group ();
3138 /* If we use the special induction variable, create it and set it to
3139 its initial value. Morever, the regular iteration variable cannot
3140 itself be initialized, lest the initial value wrapped around. */
3144 = create_init_temporary ("I", gnu_first
, &gnu_stmt
, gnat_loop_var
);
3145 add_stmt (gnu_stmt
);
3146 gnu_first
= NULL_TREE
;
3149 gnu_loop_iv
= NULL_TREE
;
3151 /* Declare the iteration variable and set it to its initial value. */
3152 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, true);
3153 if (DECL_BY_REF_P (gnu_loop_var
))
3154 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_loop_var
);
3157 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var
));
3158 SET_DECL_INDUCTION_VAR (gnu_loop_var
, gnu_loop_iv
);
3160 gnu_loop_info
->loop_var
= gnu_loop_var
;
3161 gnu_loop_info
->low_bound
= gnu_low
;
3162 gnu_loop_info
->high_bound
= gnu_high
;
3164 /* Do all the arithmetics in the base type. */
3165 gnu_loop_var
= convert (gnu_base_type
, gnu_loop_var
);
3167 /* Set either the top or bottom exit condition. */
3169 LOOP_STMT_COND (gnu_loop_stmt
)
3170 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_iv
,
3173 LOOP_STMT_COND (gnu_loop_stmt
)
3174 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_var
,
3177 /* Set either the top or bottom update statement and give it the source
3178 location of the iteration for better coverage info. */
3182 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_iv
,
3183 build_binary_op (update_code
, gnu_base_type
,
3184 gnu_loop_iv
, gnu_one_node
));
3185 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3186 append_to_statement_list (gnu_stmt
,
3187 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
3189 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
3191 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3192 append_to_statement_list (gnu_stmt
,
3193 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
3198 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
3199 build_binary_op (update_code
, gnu_base_type
,
3200 gnu_loop_var
, gnu_one_node
));
3201 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
3202 LOOP_STMT_UPDATE (gnu_loop_stmt
) = gnu_stmt
;
3205 set_expr_location_from_node (gnu_loop_stmt
, gnat_iter_scheme
);
3208 /* If the loop was named, have the name point to this loop. In this case,
3209 the association is not a DECL node, but the end label of the loop. */
3210 if (Present (Identifier (gnat_node
)))
3211 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_label
, true);
3213 /* Make the loop body into its own block, so any allocated storage will be
3214 released every iteration. This is needed for stack allocation. */
3215 LOOP_STMT_BODY (gnu_loop_stmt
)
3216 = build_stmt_group (Statements (gnat_node
), true);
3217 TREE_SIDE_EFFECTS (gnu_loop_stmt
) = 1;
3219 /* If we have an iteration scheme, then we are in a statement group. Add
3220 the LOOP_STMT to it, finish it and make it the "loop". */
3221 if (Present (gnat_iter_scheme
) && No (Condition (gnat_iter_scheme
)))
3223 /* First, if we have computed invariant conditions for range (or index)
3224 checks applied to the iteration variable, find out whether they can
3225 be evaluated to false at compile time; otherwise, if there are not
3226 too many of them, combine them with the original checks. If loop
3227 unswitching is enabled, do not require the loop bounds to be also
3228 invariant, as their evaluation will still be ahead of the loop. */
3229 if (vec_safe_length (gnu_loop_info
->checks
) > 0
3230 && (make_invariant (&gnu_low
, &gnu_high
) || optimize
>= 3))
3232 struct range_check_info_d
*rci
;
3233 unsigned int i
, n_remaining_checks
= 0;
3235 FOR_EACH_VEC_ELT (*gnu_loop_info
->checks
, i
, rci
)
3237 tree low_ok
, high_ok
;
3241 tree gnu_adjusted_low
= convert (rci
->type
, gnu_low
);
3244 = fold_build2 (rci
->neg_p
? MINUS_EXPR
: PLUS_EXPR
,
3245 rci
->type
, gnu_adjusted_low
, rci
->disp
);
3247 = build_binary_op (GE_EXPR
, boolean_type_node
,
3248 gnu_adjusted_low
, rci
->low_bound
);
3251 low_ok
= boolean_true_node
;
3253 if (rci
->high_bound
)
3255 tree gnu_adjusted_high
= convert (rci
->type
, gnu_high
);
3258 = fold_build2 (rci
->neg_p
? MINUS_EXPR
: PLUS_EXPR
,
3259 rci
->type
, gnu_adjusted_high
, rci
->disp
);
3261 = build_binary_op (LE_EXPR
, boolean_type_node
,
3262 gnu_adjusted_high
, rci
->high_bound
);
3265 high_ok
= boolean_true_node
;
3268 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
3272 = build_unary_op (TRUTH_NOT_EXPR
, boolean_type_node
, range_ok
);
3274 if (rci
->invariant_cond
== boolean_false_node
)
3275 TREE_OPERAND (rci
->inserted_cond
, 0) = rci
->invariant_cond
;
3277 n_remaining_checks
++;
3280 /* Note that loop unswitching can only be applied a small number of
3281 times to a given loop (PARAM_MAX_UNSWITCH_LEVEL default to 3). */
3282 if (IN_RANGE (n_remaining_checks
, 1, 3)
3285 FOR_EACH_VEC_ELT (*gnu_loop_info
->checks
, i
, rci
)
3286 if (rci
->invariant_cond
!= boolean_false_node
)
3288 TREE_OPERAND (rci
->inserted_cond
, 0) = rci
->invariant_cond
;
3291 add_stmt_with_node_force (rci
->inserted_cond
, gnat_node
);
3295 /* Second, if loop vectorization is enabled and the iterations of the
3296 loop can easily be proved as independent, mark the loop. */
3298 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt
)))
3299 LOOP_STMT_IVDEP (gnu_loop_stmt
) = 1;
3301 add_stmt (gnu_loop_stmt
);
3303 gnu_loop_stmt
= end_stmt_group ();
3306 *gnu_cond_expr_p
= gnu_cond_expr
;
3308 return gnu_loop_stmt
;
3311 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
3312 to a GCC tree, which is returned. */
3315 Loop_Statement_to_gnu (Node_Id gnat_node
)
3317 struct loop_info_d
*gnu_loop_info
= ggc_cleared_alloc
<loop_info_d
> ();
3319 tree gnu_loop_stmt
= build4 (LOOP_STMT
, void_type_node
, NULL_TREE
,
3320 NULL_TREE
, NULL_TREE
, NULL_TREE
);
3321 tree gnu_cond_expr
= NULL_TREE
;
3322 tree gnu_loop_label
= create_artificial_label (input_location
);
3325 /* Push the loop_info structure associated with the LOOP_STMT. */
3326 vec_safe_push (gnu_loop_stack
, gnu_loop_info
);
3328 /* Set location information for statement and end label. */
3329 set_expr_location_from_node (gnu_loop_stmt
, gnat_node
);
3330 Sloc_to_locus (Sloc (End_Label (gnat_node
)),
3331 &DECL_SOURCE_LOCATION (gnu_loop_label
));
3332 LOOP_STMT_LABEL (gnu_loop_stmt
) = gnu_loop_label
;
3334 /* Save the statement for later reuse. */
3335 gnu_loop_info
->stmt
= gnu_loop_stmt
;
3337 /* Perform the core loop body translation. */
3338 gnu_loop_stmt
= Regular_Loop_to_gnu (gnat_node
, &gnu_cond_expr
);
3340 /* If we have an outer COND_EXPR, that's our result and this loop is its
3341 "true" statement. Otherwise, the result is the LOOP_STMT. */
3344 COND_EXPR_THEN (gnu_cond_expr
) = gnu_loop_stmt
;
3345 TREE_SIDE_EFFECTS (gnu_cond_expr
) = 1;
3346 gnu_result
= gnu_cond_expr
;
3349 gnu_result
= gnu_loop_stmt
;
3351 gnu_loop_stack
->pop ();
3356 /* This page implements a form of Named Return Value optimization modeled
3357 on the C++ optimization of the same name. The main difference is that
3358 we disregard any semantical considerations when applying it here, the
3359 counterpart being that we don't try to apply it to semantically loaded
3360 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3362 We consider a function body of the following GENERIC form:
3366 RETURN_EXPR [<retval> = ...]
3368 RETURN_EXPR [<retval> = R1]
3372 RETURN_EXPR [<retval> = ...]
3374 RETURN_EXPR [<retval> = Ri]
3377 where the Ri are not addressable and we try to fulfill a simple criterion
3378 that would make it possible to replace one or several Ri variables by the
3379 single RESULT_DECL of the function.
3381 The first observation is that RETURN_EXPRs that don't directly reference
3382 any of the Ri variables on the RHS of their assignment are transparent wrt
3383 the optimization. This is because the Ri variables aren't addressable so
3384 any transformation applied to them doesn't affect the RHS; moreover, the
3385 assignment writes the full <retval> object so existing values are entirely
3388 This property can be extended to some forms of RETURN_EXPRs that reference
3389 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3390 case, in particular when function calls are involved.
3392 Therefore the algorithm is as follows:
3394 1. Collect the list of candidates for a Named Return Value (Ri variables
3395 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3396 other expressions on the RHS of such assignments.
3398 2. Prune the members of the first list (candidates) that are referenced
3399 by a member of the second list (expressions).
3401 3. Extract a set of candidates with non-overlapping live ranges from the
3402 first list. These are the Named Return Values.
3404 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3405 Named Return Values in the function with the RESULT_DECL.
3407 If the function returns an unconstrained type, things are a bit different
3408 because the anonymous return object is allocated on the secondary stack
3409 and RESULT_DECL is only a pointer to it. Each return object can be of a
3410 different size and is allocated separately so we need not care about the
3411 addressability and the aforementioned overlapping issues. Therefore, we
3412 don't collect the other expressions and skip step #2 in the algorithm. */
3419 hash_set
<tree
> *visited
;
3422 /* Return true if T is a Named Return Value. */
3425 is_nrv_p (bitmap nrv
, tree t
)
3427 return TREE_CODE (t
) == VAR_DECL
&& bitmap_bit_p (nrv
, DECL_UID (t
));
3430 /* Helper function for walk_tree, used by finalize_nrv below. */
3433 prune_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
3435 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3438 /* No need to walk into types or decls. */
3439 if (IS_TYPE_OR_DECL_P (t
))
3442 if (is_nrv_p (dp
->nrv
, t
))
3443 bitmap_clear_bit (dp
->nrv
, DECL_UID (t
));
3448 /* Prune Named Return Values in BLOCK and return true if there is still a
3449 Named Return Value in BLOCK or one of its sub-blocks. */
3452 prune_nrv_in_block (bitmap nrv
, tree block
)
3454 bool has_nrv
= false;
3457 /* First recurse on the sub-blocks. */
3458 for (t
= BLOCK_SUBBLOCKS (block
); t
; t
= BLOCK_CHAIN (t
))
3459 has_nrv
|= prune_nrv_in_block (nrv
, t
);
3461 /* Then make sure to keep at most one NRV per block. */
3462 for (t
= BLOCK_VARS (block
); t
; t
= DECL_CHAIN (t
))
3463 if (is_nrv_p (nrv
, t
))
3466 bitmap_clear_bit (nrv
, DECL_UID (t
));
3474 /* Helper function for walk_tree, used by finalize_nrv below. */
3477 finalize_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
3479 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3482 /* No need to walk into types. */
3486 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3487 nop, but differs from using NULL_TREE in that it indicates that we care
3488 about the value of the RESULT_DECL. */
3489 else if (TREE_CODE (t
) == RETURN_EXPR
3490 && TREE_CODE (TREE_OPERAND (t
, 0)) == INIT_EXPR
)
3492 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1);
3494 /* Strip useless conversions around the return value. */
3495 if (gnat_useless_type_conversion (ret_val
))
3496 ret_val
= TREE_OPERAND (ret_val
, 0);
3498 if (is_nrv_p (dp
->nrv
, ret_val
))
3499 TREE_OPERAND (t
, 0) = dp
->result
;
3502 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3504 else if (TREE_CODE (t
) == DECL_EXPR
3505 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
3507 tree var
= DECL_EXPR_DECL (t
), init
;
3509 if (DECL_INITIAL (var
))
3511 init
= build_binary_op (INIT_EXPR
, NULL_TREE
, dp
->result
,
3512 DECL_INITIAL (var
));
3513 SET_EXPR_LOCATION (init
, EXPR_LOCATION (t
));
3514 DECL_INITIAL (var
) = NULL_TREE
;
3517 init
= build_empty_stmt (EXPR_LOCATION (t
));
3520 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3521 SET_DECL_VALUE_EXPR (var
, dp
->result
);
3522 DECL_HAS_VALUE_EXPR_P (var
) = 1;
3523 /* ??? Kludge to avoid an assertion failure during inlining. */
3524 DECL_SIZE (var
) = bitsize_unit_node
;
3525 DECL_SIZE_UNIT (var
) = size_one_node
;
3528 /* And replace all uses of NRVs with the RESULT_DECL. */
3529 else if (is_nrv_p (dp
->nrv
, t
))
3530 *tp
= convert (TREE_TYPE (t
), dp
->result
);
3532 /* Avoid walking into the same tree more than once. Unfortunately, we
3533 can't just use walk_tree_without_duplicates because it would only
3534 call us for the first occurrence of NRVs in the function body. */
3535 if (dp
->visited
->add (*tp
))
3541 /* Likewise, but used when the function returns an unconstrained type. */
3544 finalize_nrv_unc_r (tree
*tp
, int *walk_subtrees
, void *data
)
3546 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3549 /* No need to walk into types. */
3553 /* We need to see the DECL_EXPR of NRVs before any other references so we
3554 walk the body of BIND_EXPR before walking its variables. */
3555 else if (TREE_CODE (t
) == BIND_EXPR
)
3556 walk_tree (&BIND_EXPR_BODY (t
), finalize_nrv_unc_r
, data
, NULL
);
3558 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3559 return value built by the allocator instead of the whole construct. */
3560 else if (TREE_CODE (t
) == RETURN_EXPR
3561 && TREE_CODE (TREE_OPERAND (t
, 0)) == INIT_EXPR
)
3563 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1);
3565 /* This is the construct returned by the allocator. */
3566 if (TREE_CODE (ret_val
) == COMPOUND_EXPR
3567 && TREE_CODE (TREE_OPERAND (ret_val
, 0)) == INIT_EXPR
)
3569 tree rhs
= TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 1);
3571 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val
)))
3572 ret_val
= CONSTRUCTOR_ELT (rhs
, 1)->value
;
3577 /* Strip useless conversions around the return value. */
3578 if (gnat_useless_type_conversion (ret_val
)
3579 || TREE_CODE (ret_val
) == VIEW_CONVERT_EXPR
)
3580 ret_val
= TREE_OPERAND (ret_val
, 0);
3582 /* Strip unpadding around the return value. */
3583 if (TREE_CODE (ret_val
) == COMPONENT_REF
3584 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
3585 ret_val
= TREE_OPERAND (ret_val
, 0);
3587 /* Assign the new return value to the RESULT_DECL. */
3588 if (is_nrv_p (dp
->nrv
, ret_val
))
3589 TREE_OPERAND (TREE_OPERAND (t
, 0), 1)
3590 = TREE_OPERAND (DECL_INITIAL (ret_val
), 0);
3593 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3594 into a new variable. */
3595 else if (TREE_CODE (t
) == DECL_EXPR
3596 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
3598 tree saved_current_function_decl
= current_function_decl
;
3599 tree var
= DECL_EXPR_DECL (t
);
3600 tree alloc
, p_array
, new_var
, new_ret
;
3601 vec
<constructor_elt
, va_gc
> *v
;
3604 /* Create an artificial context to build the allocation. */
3605 current_function_decl
= decl_function_context (var
);
3606 start_stmt_group ();
3609 /* This will return a COMPOUND_EXPR with the allocation in the first
3610 arm and the final return value in the second arm. */
3611 alloc
= build_allocator (TREE_TYPE (var
), DECL_INITIAL (var
),
3612 TREE_TYPE (dp
->result
),
3613 Procedure_To_Call (dp
->gnat_ret
),
3614 Storage_Pool (dp
->gnat_ret
),
3617 /* The new variable is built as a reference to the allocated space. */
3619 = build_decl (DECL_SOURCE_LOCATION (var
), VAR_DECL
, DECL_NAME (var
),
3620 build_reference_type (TREE_TYPE (var
)));
3621 DECL_BY_REFERENCE (new_var
) = 1;
3623 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc
)))
3625 tree cst
= TREE_OPERAND (alloc
, 1);
3627 /* The new initial value is a COMPOUND_EXPR with the allocation in
3628 the first arm and the value of P_ARRAY in the second arm. */
3629 DECL_INITIAL (new_var
)
3630 = build2 (COMPOUND_EXPR
, TREE_TYPE (new_var
),
3631 TREE_OPERAND (alloc
, 0),
3632 CONSTRUCTOR_ELT (cst
, 0)->value
);
3634 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3635 p_array
= TYPE_FIELDS (TREE_TYPE (alloc
));
3636 CONSTRUCTOR_APPEND_ELT (v
, p_array
,
3637 fold_convert (TREE_TYPE (p_array
), new_var
));
3638 CONSTRUCTOR_APPEND_ELT (v
, DECL_CHAIN (p_array
),
3639 CONSTRUCTOR_ELT (cst
, 1)->value
);
3640 new_ret
= build_constructor (TREE_TYPE (alloc
), v
);
3644 /* The new initial value is just the allocation. */
3645 DECL_INITIAL (new_var
) = alloc
;
3646 new_ret
= fold_convert (TREE_TYPE (alloc
), new_var
);
3649 gnat_pushdecl (new_var
, Empty
);
3651 /* Destroy the artificial context and insert the new statements. */
3653 *tp
= end_stmt_group ();
3654 current_function_decl
= saved_current_function_decl
;
3656 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3657 DECL_CHAIN (new_var
) = DECL_CHAIN (var
);
3658 DECL_CHAIN (var
) = new_var
;
3659 DECL_IGNORED_P (var
) = 1;
3661 /* Save the new return value and the dereference of NEW_VAR. */
3663 = build2 (COMPOUND_EXPR
, TREE_TYPE (var
), new_ret
,
3664 build1 (INDIRECT_REF
, TREE_TYPE (var
), new_var
));
3665 /* ??? Kludge to avoid messing up during inlining. */
3666 DECL_CONTEXT (var
) = NULL_TREE
;
3669 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3670 else if (is_nrv_p (dp
->nrv
, t
))
3671 *tp
= TREE_OPERAND (DECL_INITIAL (t
), 1);
3673 /* Avoid walking into the same tree more than once. Unfortunately, we
3674 can't just use walk_tree_without_duplicates because it would only
3675 call us for the first occurrence of NRVs in the function body. */
3676 if (dp
->visited
->add (*tp
))
3682 /* Apply FUNC to all the sub-trees of nested functions in NODE. FUNC is called
3683 with the DATA and the address of each sub-tree. If FUNC returns a non-NULL
3684 value, the traversal is stopped. */
3687 walk_nesting_tree (struct cgraph_node
*node
, walk_tree_fn func
, void *data
)
3689 for (node
= node
->nested
; node
; node
= node
->next_nested
)
3691 walk_tree_without_duplicates (&DECL_SAVED_TREE (node
->decl
), func
, data
);
3692 walk_nesting_tree (node
, func
, data
);
3696 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3697 contains the candidates for Named Return Value and OTHER is a list of
3698 the other return values. GNAT_RET is a representative return node. */
3701 finalize_nrv (tree fndecl
, bitmap nrv
, vec
<tree
, va_gc
> *other
, Node_Id gnat_ret
)
3703 struct nrv_data data
;
3708 /* We shouldn't be applying the optimization to return types that we aren't
3709 allowed to manipulate freely. */
3710 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl
))));
3712 /* Prune the candidates that are referenced by other return values. */
3714 data
.result
= NULL_TREE
;
3715 data
.gnat_ret
= Empty
;
3716 data
.visited
= NULL
;
3717 FOR_EACH_VEC_SAFE_ELT (other
, i
, iter
)
3718 walk_tree_without_duplicates (&iter
, prune_nrv_r
, &data
);
3719 if (bitmap_empty_p (nrv
))
3722 /* Prune also the candidates that are referenced by nested functions. */
3723 walk_nesting_tree (cgraph_node::get_create (fndecl
), prune_nrv_r
, &data
);
3724 if (bitmap_empty_p (nrv
))
3727 /* Extract a set of NRVs with non-overlapping live ranges. */
3728 if (!prune_nrv_in_block (nrv
, DECL_INITIAL (fndecl
)))
3731 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3733 data
.result
= DECL_RESULT (fndecl
);
3734 data
.gnat_ret
= gnat_ret
;
3735 data
.visited
= new hash_set
<tree
>;
3736 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl
)))
3737 func
= finalize_nrv_unc_r
;
3739 func
= finalize_nrv_r
;
3740 walk_tree (&DECL_SAVED_TREE (fndecl
), func
, &data
, NULL
);
3741 delete data
.visited
;
3744 /* Return true if RET_VAL can be used as a Named Return Value for the
3745 anonymous return object RET_OBJ. */
3748 return_value_ok_for_nrv_p (tree ret_obj
, tree ret_val
)
3750 if (TREE_CODE (ret_val
) != VAR_DECL
)
3753 if (TREE_THIS_VOLATILE (ret_val
))
3756 if (DECL_CONTEXT (ret_val
) != current_function_decl
)
3759 if (TREE_STATIC (ret_val
))
3762 /* For the constrained case, test for addressability. */
3763 if (ret_obj
&& TREE_ADDRESSABLE (ret_val
))
3766 /* For the constrained case, test for overalignment. */
3767 if (ret_obj
&& DECL_ALIGN (ret_val
) > DECL_ALIGN (ret_obj
))
3770 /* For the unconstrained case, test for bogus initialization. */
3772 && DECL_INITIAL (ret_val
)
3773 && TREE_CODE (DECL_INITIAL (ret_val
)) == NULL_EXPR
)
3779 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3780 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3781 around RESULT_OBJ, which may be null in this case. */
3784 build_return_expr (tree ret_obj
, tree ret_val
)
3790 /* The gimplifier explicitly enforces the following invariant:
3799 As a consequence, type consistency dictates that we use the type
3800 of the RET_OBJ as the operation type. */
3801 tree operation_type
= TREE_TYPE (ret_obj
);
3803 /* Convert the right operand to the operation type. Note that this is
3804 the transformation applied in the INIT_EXPR case of build_binary_op,
3805 with the assumption that the type cannot involve a placeholder. */
3806 if (operation_type
!= TREE_TYPE (ret_val
))
3807 ret_val
= convert (operation_type
, ret_val
);
3809 /* We always can use an INIT_EXPR for the return object. */
3810 result_expr
= build2 (INIT_EXPR
, void_type_node
, ret_obj
, ret_val
);
3812 /* If the function returns an aggregate type, find out whether this is
3813 a candidate for Named Return Value. If so, record it. Otherwise,
3814 if this is an expression of some kind, record it elsewhere. */
3817 && AGGREGATE_TYPE_P (operation_type
)
3818 && !TYPE_IS_FAT_POINTER_P (operation_type
)
3819 && TYPE_MODE (operation_type
) == BLKmode
3820 && aggregate_value_p (operation_type
, current_function_decl
))
3822 /* Strip useless conversions around the return value. */
3823 if (gnat_useless_type_conversion (ret_val
))
3824 ret_val
= TREE_OPERAND (ret_val
, 0);
3826 /* Now apply the test to the return value. */
3827 if (return_value_ok_for_nrv_p (ret_obj
, ret_val
))
3829 if (!f_named_ret_val
)
3830 f_named_ret_val
= BITMAP_GGC_ALLOC ();
3831 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
3834 /* Note that we need not care about CONSTRUCTORs here, as they are
3835 totally transparent given the read-compose-write semantics of
3836 assignments from CONSTRUCTORs. */
3837 else if (EXPR_P (ret_val
))
3838 vec_safe_push (f_other_ret_val
, ret_val
);
3842 result_expr
= ret_obj
;
3844 return build1 (RETURN_EXPR
, void_type_node
, result_expr
);
3847 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3848 don't return anything. */
3851 Subprogram_Body_to_gnu (Node_Id gnat_node
)
3853 /* Defining identifier of a parameter to the subprogram. */
3854 Entity_Id gnat_param
;
3855 /* The defining identifier for the subprogram body. Note that if a
3856 specification has appeared before for this body, then the identifier
3857 occurring in that specification will also be a defining identifier and all
3858 the calls to this subprogram will point to that specification. */
3859 Entity_Id gnat_subprog_id
3860 = (Present (Corresponding_Spec (gnat_node
))
3861 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
3862 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3863 tree gnu_subprog_decl
;
3864 /* Its RESULT_DECL node. */
3865 tree gnu_result_decl
;
3866 /* Its FUNCTION_TYPE node. */
3867 tree gnu_subprog_type
;
3868 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3870 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3871 tree gnu_return_var_elmt
= NULL_TREE
;
3874 struct language_function
*gnu_subprog_language
;
3875 vec
<parm_attr
, va_gc
> *cache
;
3877 /* If this is a generic object or if it has been eliminated,
3879 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
3880 || Ekind (gnat_subprog_id
) == E_Generic_Function
3881 || Is_Eliminated (gnat_subprog_id
))
3884 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3885 the already-elaborated tree node. However, if this subprogram had its
3886 elaboration deferred, we will already have made a tree node for it. So
3887 treat it as not being defined in that case. Such a subprogram cannot
3888 have an address clause or a freeze node, so this test is safe, though it
3889 does disable some otherwise-useful error checking. */
3891 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
3892 Acts_As_Spec (gnat_node
)
3893 && !present_gnu_tree (gnat_subprog_id
));
3894 DECL_FUNCTION_IS_DEF (gnu_subprog_decl
) = true;
3895 gnu_result_decl
= DECL_RESULT (gnu_subprog_decl
);
3896 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
3897 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3898 if (gnu_cico_list
&& TREE_VALUE (gnu_cico_list
) == void_type_node
)
3899 gnu_return_var_elmt
= gnu_cico_list
;
3901 /* If the function returns by invisible reference, make it explicit in the
3902 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
3903 if (TREE_ADDRESSABLE (gnu_subprog_type
))
3905 TREE_TYPE (gnu_result_decl
)
3906 = build_reference_type (TREE_TYPE (gnu_result_decl
));
3907 relayout_decl (gnu_result_decl
);
3910 /* Set the line number in the decl to correspond to that of the body. */
3911 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
, false, gnu_subprog_decl
))
3912 locus
= input_location
;
3913 DECL_SOURCE_LOCATION (gnu_subprog_decl
) = locus
;
3915 /* If the body comes from an expression function, arrange it to be inlined
3916 in almost all cases. */
3917 if (Was_Expression_Function (gnat_node
))
3918 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog_decl
) = 1;
3920 /* Try to create a bona-fide thunk and hand it over to the middle-end. */
3921 if (Is_Thunk (gnat_subprog_id
)
3922 && maybe_make_gnu_thunk (gnat_subprog_id
, gnu_subprog_decl
))
3925 /* Initialize the information structure for the function. */
3926 allocate_struct_function (gnu_subprog_decl
, false);
3927 gnu_subprog_language
= ggc_cleared_alloc
<language_function
> ();
3928 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->language
= gnu_subprog_language
;
3929 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->function_start_locus
= locus
;
3932 begin_subprog_body (gnu_subprog_decl
);
3934 /* If there are copy-in/copy-out parameters, we need to ensure that they are
3935 properly copied out by the return statement. We do this by making a new
3936 block and converting any return into a goto to a label at the end of the
3940 tree gnu_return_var
= NULL_TREE
;
3942 vec_safe_push (gnu_return_label_stack
,
3943 create_artificial_label (input_location
));
3945 start_stmt_group ();
3948 /* If this is a function with copy-in/copy-out parameters and which does
3949 not return by invisible reference, we also need a variable for the
3950 return value to be placed. */
3951 if (gnu_return_var_elmt
&& !TREE_ADDRESSABLE (gnu_subprog_type
))
3953 tree gnu_return_type
3954 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt
));
3957 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE
,
3958 gnu_return_type
, NULL_TREE
,
3959 false, false, false, false, false,
3960 true, false, NULL
, gnat_subprog_id
);
3961 TREE_VALUE (gnu_return_var_elmt
) = gnu_return_var
;
3964 vec_safe_push (gnu_return_var_stack
, gnu_return_var
);
3966 /* See whether there are parameters for which we don't have a GCC tree
3967 yet. These must be Out parameters. Make a VAR_DECL for them and
3968 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3969 We can match up the entries because TYPE_CI_CO_LIST is in the order
3970 of the parameters. */
3971 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
3972 Present (gnat_param
);
3973 gnat_param
= Next_Formal_With_Extras (gnat_param
))
3974 if (!present_gnu_tree (gnat_param
))
3976 tree gnu_cico_entry
= gnu_cico_list
;
3979 /* Skip any entries that have been already filled in; they must
3980 correspond to In Out parameters. */
3981 while (gnu_cico_entry
&& TREE_VALUE (gnu_cico_entry
))
3982 gnu_cico_entry
= TREE_CHAIN (gnu_cico_entry
);
3984 /* Do any needed dereferences for by-ref objects. */
3985 gnu_decl
= gnat_to_gnu_entity (gnat_param
, NULL_TREE
, true);
3986 gcc_assert (DECL_P (gnu_decl
));
3987 if (DECL_BY_REF_P (gnu_decl
))
3988 gnu_decl
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_decl
);
3990 /* Do any needed references for padded types. */
3991 TREE_VALUE (gnu_cico_entry
)
3992 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry
)), gnu_decl
);
3996 vec_safe_push (gnu_return_label_stack
, NULL_TREE
);
3998 /* Get a tree corresponding to the code for the subprogram. */
3999 start_stmt_group ();
4002 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
4004 /* Generate the code of the subprogram itself. A return statement will be
4005 present and any Out parameters will be handled there. */
4006 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
4008 gnu_result
= end_stmt_group ();
4010 /* If we populated the parameter attributes cache, we need to make sure that
4011 the cached expressions are evaluated on all the possible paths leading to
4012 their uses. So we force their evaluation on entry of the function. */
4013 cache
= gnu_subprog_language
->parm_attr_cache
;
4016 struct parm_attr_d
*pa
;
4019 start_stmt_group ();
4021 FOR_EACH_VEC_ELT (*cache
, i
, pa
)
4024 add_stmt_with_node_force (pa
->first
, gnat_node
);
4026 add_stmt_with_node_force (pa
->last
, gnat_node
);
4028 add_stmt_with_node_force (pa
->length
, gnat_node
);
4031 add_stmt (gnu_result
);
4032 gnu_result
= end_stmt_group ();
4034 gnu_subprog_language
->parm_attr_cache
= NULL
;
4037 /* If we are dealing with a return from an Ada procedure with parameters
4038 passed by copy-in/copy-out, we need to return a record containing the
4039 final values of these parameters. If the list contains only one entry,
4040 return just that entry though.
4042 For a full description of the copy-in/copy-out parameter mechanism, see
4043 the part of the gnat_to_gnu_entity routine dealing with the translation
4046 We need to make a block that contains the definition of that label and
4047 the copying of the return value. It first contains the function, then
4048 the label and copy statement. */
4051 const Node_Id gnat_end_label
4052 = End_Label (Handled_Statement_Sequence (gnat_node
));
4054 gnu_return_var_stack
->pop ();
4056 add_stmt (gnu_result
);
4057 add_stmt (build1 (LABEL_EXPR
, void_type_node
,
4058 gnu_return_label_stack
->last ()));
4060 /* If this is a function which returns by invisible reference, the
4061 return value has already been dealt with at the return statements,
4062 so we only need to indirectly copy out the parameters. */
4063 if (TREE_ADDRESSABLE (gnu_subprog_type
))
4066 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result_decl
);
4069 gcc_assert (TREE_VALUE (gnu_cico_list
) == void_type_node
);
4071 for (t
= TREE_CHAIN (gnu_cico_list
); t
; t
= TREE_CHAIN (t
))
4073 tree gnu_field_deref
4074 = build_component_ref (gnu_ret_deref
, TREE_PURPOSE (t
), true);
4075 gnu_result
= build2 (MODIFY_EXPR
, void_type_node
,
4076 gnu_field_deref
, TREE_VALUE (t
));
4077 add_stmt_with_node (gnu_result
, gnat_end_label
);
4081 /* Otherwise, if this is a procedure or a function which does not return
4082 by invisible reference, we can do a direct block-copy out. */
4087 if (list_length (gnu_cico_list
) == 1)
4088 gnu_retval
= TREE_VALUE (gnu_cico_list
);
4091 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type
),
4094 gnu_result
= build_return_expr (gnu_result_decl
, gnu_retval
);
4095 add_stmt_with_node (gnu_result
, gnat_end_label
);
4099 gnu_result
= end_stmt_group ();
4102 gnu_return_label_stack
->pop ();
4104 /* Attempt setting the end_locus of our GCC body tree, typically a
4105 BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
4106 declaration tree. */
4107 set_end_locus_from_node (gnu_result
, gnat_node
);
4108 set_end_locus_from_node (gnu_subprog_decl
, gnat_node
);
4110 /* On SEH targets, install an exception handler around the main entry
4111 point to catch unhandled exceptions. */
4112 if (DECL_NAME (gnu_subprog_decl
) == main_identifier_node
4113 && targetm_common
.except_unwind_info (&global_options
) == UI_SEH
)
4118 t
= build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
4119 1, integer_zero_node
);
4120 t
= build_call_n_expr (unhandled_except_decl
, 1, t
);
4122 etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, unhandled_others_decl
);
4123 etype
= tree_cons (NULL_TREE
, etype
, NULL_TREE
);
4125 t
= build2 (CATCH_EXPR
, void_type_node
, etype
, t
);
4126 gnu_result
= build2 (TRY_CATCH_EXPR
, TREE_TYPE (gnu_result
),
4130 end_subprog_body (gnu_result
);
4132 /* Finally annotate the parameters and disconnect the trees for parameters
4133 that we have turned into variables since they are now unusable. */
4134 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
4135 Present (gnat_param
);
4136 gnat_param
= Next_Formal_With_Extras (gnat_param
))
4138 tree gnu_param
= get_gnu_tree (gnat_param
);
4139 bool is_var_decl
= (TREE_CODE (gnu_param
) == VAR_DECL
);
4141 annotate_object (gnat_param
, TREE_TYPE (gnu_param
), NULL_TREE
,
4142 DECL_BY_REF_P (gnu_param
));
4145 save_gnu_tree (gnat_param
, NULL_TREE
, false);
4148 /* Disconnect the variable created for the return value. */
4149 if (gnu_return_var_elmt
)
4150 TREE_VALUE (gnu_return_var_elmt
) = void_type_node
;
4152 /* If the function returns an aggregate type and we have candidates for
4153 a Named Return Value, finalize the optimization. */
4154 if (optimize
&& !optimize_debug
&& gnu_subprog_language
->named_ret_val
)
4156 finalize_nrv (gnu_subprog_decl
,
4157 gnu_subprog_language
->named_ret_val
,
4158 gnu_subprog_language
->other_ret_val
,
4159 gnu_subprog_language
->gnat_ret
);
4160 gnu_subprog_language
->named_ret_val
= NULL
;
4161 gnu_subprog_language
->other_ret_val
= NULL
;
4164 /* If this is an inlined external function that has been marked uninlinable,
4165 drop the body and stop there. Otherwise compile the body. */
4166 if (DECL_EXTERNAL (gnu_subprog_decl
) && DECL_UNINLINABLE (gnu_subprog_decl
))
4167 DECL_SAVED_TREE (gnu_subprog_decl
) = NULL_TREE
;
4169 rest_of_subprog_body_compilation (gnu_subprog_decl
);
4172 /* The type of an atomic access. */
4174 typedef enum { NOT_ATOMIC
, SIMPLE_ATOMIC
, OUTER_ATOMIC
} atomic_acces_t
;
4176 /* Return true if GNAT_NODE references an Atomic entity. This is modeled on
4177 the Is_Atomic_Object predicate of the front-end, but additionally handles
4178 explicit dereferences. */
4181 node_is_atomic (Node_Id gnat_node
)
4183 Entity_Id gnat_entity
;
4185 switch (Nkind (gnat_node
))
4188 case N_Expanded_Name
:
4189 gnat_entity
= Entity (gnat_node
);
4190 if (Ekind (gnat_entity
) != E_Variable
)
4192 return Is_Atomic (gnat_entity
) || Is_Atomic (Etype (gnat_entity
));
4194 case N_Selected_Component
:
4195 return Is_Atomic (Etype (gnat_node
))
4196 || Is_Atomic (Entity (Selector_Name (gnat_node
)));
4198 case N_Indexed_Component
:
4199 return Is_Atomic (Etype (gnat_node
))
4200 || Has_Atomic_Components (Etype (Prefix (gnat_node
)))
4201 || (Is_Entity_Name (Prefix (gnat_node
))
4202 && Has_Atomic_Components (Entity (Prefix (gnat_node
))));
4204 case N_Explicit_Dereference
:
4205 return Is_Atomic (Etype (gnat_node
));
4214 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. This is
4215 modeled on the Is_Volatile_Full_Access_Object predicate of the front-end,
4216 but additionally handles explicit dereferences. */
4219 node_is_volatile_full_access (Node_Id gnat_node
)
4221 Entity_Id gnat_entity
;
4223 switch (Nkind (gnat_node
))
4226 case N_Expanded_Name
:
4227 gnat_entity
= Entity (gnat_node
);
4228 if (!Is_Object (gnat_entity
))
4230 return Is_Volatile_Full_Access (gnat_entity
)
4231 || Is_Volatile_Full_Access (Etype (gnat_entity
));
4233 case N_Selected_Component
:
4234 return Is_Volatile_Full_Access (Etype (gnat_node
))
4235 || Is_Volatile_Full_Access (Entity (Selector_Name (gnat_node
)));
4237 case N_Indexed_Component
:
4238 case N_Explicit_Dereference
:
4239 return Is_Volatile_Full_Access (Etype (gnat_node
));
4248 /* Return true if GNAT_NODE references a component of a larger object. */
4251 node_is_component (Node_Id gnat_node
)
4253 const Node_Kind k
= Nkind (gnat_node
);
4255 (k
== N_Indexed_Component
|| k
== N_Selected_Component
|| k
== N_Slice
);
4258 /* Compute whether GNAT_NODE requires atomic access and set TYPE to the type
4259 of access and SYNC according to the associated synchronization setting.
4261 We implement 3 different semantics of atomicity in this function:
4263 1. the Ada 95/2005/2012 semantics of the Atomic aspect/pragma,
4264 2. the Ada 2020 semantics of the Atomic aspect/pragma,
4265 3. the semantics of the Volatile_Full_Access GNAT aspect/pragma.
4267 They are mutually exclusive and the FE should have rejected conflicts. */
4270 get_atomic_access (Node_Id gnat_node
, atomic_acces_t
*type
, bool *sync
)
4272 Node_Id gnat_parent
, gnat_temp
;
4273 unsigned char attr_id
;
4275 /* First, scan the parent to filter out irrelevant cases. */
4276 gnat_parent
= Parent (gnat_node
);
4277 switch (Nkind (gnat_parent
))
4279 case N_Attribute_Reference
:
4280 attr_id
= Get_Attribute_Id (Attribute_Name (gnat_parent
));
4281 /* Do not mess up machine code insertions. */
4282 if (attr_id
== Attr_Asm_Input
|| attr_id
== Attr_Asm_Output
)
4285 /* Nothing to do if we are the prefix of an attribute, since we do not
4286 want an atomic access for things like 'Size. */
4288 /* ... fall through ... */
4291 /* The N_Reference node is like an attribute. */
4292 if (Prefix (gnat_parent
) == gnat_node
)
4296 case N_Object_Renaming_Declaration
:
4297 /* Nothing to do for the identifier in an object renaming declaration,
4298 the renaming itself does not need atomic access. */
4305 /* Now strip any type conversion from GNAT_NODE. */
4306 if (Nkind (gnat_node
) == N_Type_Conversion
4307 || Nkind (gnat_node
) == N_Unchecked_Type_Conversion
)
4308 gnat_node
= Expression (gnat_node
);
4310 /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as
4311 a whole require atomic access (RM C.6(15)). But, starting with Ada 2020,
4312 reads of or writes to a nonatomic subcomponent of the object also require
4313 atomic access (RM C.6(19)). */
4314 if (node_is_atomic (gnat_node
))
4316 bool as_a_whole
= true;
4318 /* If we are the prefix of the parent, then the access is partial. */
4319 for (gnat_temp
= gnat_node
, gnat_parent
= Parent (gnat_temp
);
4320 node_is_component (gnat_parent
) && Prefix (gnat_parent
) == gnat_temp
;
4321 gnat_temp
= gnat_parent
, gnat_parent
= Parent (gnat_temp
))
4322 if (Ada_Version
< Ada_2020
|| node_is_atomic (gnat_parent
))
4327 /* We consider that partial accesses are not sequential actions and,
4328 therefore, do not require synchronization. */
4329 *type
= SIMPLE_ATOMIC
;
4330 *sync
= as_a_whole
? Atomic_Sync_Required (gnat_node
) : false;
4334 /* Look for an outer atomic access of a nonatomic subcomponent. Note that,
4335 for VFA, we do this before looking at the node itself because we need to
4336 access the outermost VFA object atomically, unlike for Atomic where it is
4337 the innermost atomic object (RM C.6(19)). */
4338 for (gnat_temp
= gnat_node
;
4339 node_is_component (gnat_temp
);
4340 gnat_temp
= Prefix (gnat_temp
))
4341 if ((Ada_Version
>= Ada_2020
&& node_is_atomic (Prefix (gnat_temp
)))
4342 || node_is_volatile_full_access (Prefix (gnat_temp
)))
4344 *type
= OUTER_ATOMIC
;
4349 /* Unlike Atomic, accessing a VFA object always requires atomic access. */
4350 if (node_is_volatile_full_access (gnat_node
))
4352 *type
= SIMPLE_ATOMIC
;
4362 \f/* Return true if GNAT_NODE requires simple atomic access and, if so, set SYNC
4363 according to the associated synchronization setting. */
4366 simple_atomic_access_required_p (Node_Id gnat_node
, bool *sync
)
4368 atomic_acces_t type
;
4369 get_atomic_access (gnat_node
, &type
, sync
);
4370 return type
== SIMPLE_ATOMIC
;
4373 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4376 create_temporary (const char *prefix
, tree type
)
4379 = create_var_decl (create_tmp_var_name (prefix
), NULL_TREE
,
4381 false, false, false, false, false,
4382 true, false, NULL
, Empty
);
4386 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4387 Put the initialization statement into GNU_INIT_STMT and annotate it with
4388 the SLOC of GNAT_NODE. Return the temporary variable. */
4391 create_init_temporary (const char *prefix
, tree gnu_init
, tree
*gnu_init_stmt
,
4394 tree gnu_temp
= create_temporary (prefix
, TREE_TYPE (gnu_init
));
4396 *gnu_init_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_temp
, gnu_init
);
4397 set_expr_location_from_node (*gnu_init_stmt
, gnat_node
);
4402 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
4403 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4404 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4405 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4406 N_Assignment_Statement and the result is to be placed into that object.
4407 ATOMIC_ACCESS is the type of atomic access to be used for the assignment
4408 to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment
4409 to GNU_TARGET requires atomic synchronization. */
4412 Call_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, tree gnu_target
,
4413 atomic_acces_t atomic_access
, bool atomic_sync
)
4415 const bool function_call
= (Nkind (gnat_node
) == N_Function_Call
);
4416 const bool returning_value
= (function_call
&& !gnu_target
);
4417 /* The GCC node corresponding to the GNAT subprogram name. This can either
4418 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
4419 or an indirect reference expression (an INDIRECT_REF node) pointing to a
4421 tree gnu_subprog
= gnat_to_gnu (Name (gnat_node
));
4422 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
4423 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog
);
4424 /* The return type of the FUNCTION_TYPE. */
4425 tree gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
4426 const bool frontend_builtin
4427 = (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
4428 && DECL_BUILT_IN_CLASS (gnu_subprog
) == BUILT_IN_FRONTEND
);
4429 auto_vec
<tree
, 16> gnu_actual_vec
;
4430 tree gnu_name_list
= NULL_TREE
;
4431 tree gnu_stmt_list
= NULL_TREE
;
4432 tree gnu_after_list
= NULL_TREE
;
4433 tree gnu_retval
= NULL_TREE
;
4434 tree gnu_call
, gnu_result
;
4435 bool went_into_elab_proc
= false;
4436 bool pushed_binding_level
= false;
4439 Entity_Id gnat_formal
;
4440 Node_Id gnat_actual
;
4441 atomic_acces_t aa_type
;
4444 gcc_assert (FUNC_OR_METHOD_TYPE_P (gnu_subprog_type
));
4446 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
4447 all our args first. */
4448 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
&& DECL_STUBBED_P (gnu_subprog
))
4450 tree call_expr
= build_call_raise (PE_Stubbed_Subprogram_Called
,
4451 gnat_node
, N_Raise_Program_Error
);
4453 for (gnat_actual
= First_Actual (gnat_node
);
4454 Present (gnat_actual
);
4455 gnat_actual
= Next_Actual (gnat_actual
))
4456 add_stmt (gnat_to_gnu (gnat_actual
));
4458 if (returning_value
)
4460 *gnu_result_type_p
= gnu_result_type
;
4461 return build1 (NULL_EXPR
, gnu_result_type
, call_expr
);
4467 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
)
4469 /* For a call to a nested function, check the inlining status. */
4470 if (decl_function_context (gnu_subprog
))
4471 check_inlining_for_nested_subprog (gnu_subprog
);
4473 /* For a recursive call, avoid explosion due to recursive inlining. */
4474 if (gnu_subprog
== current_function_decl
)
4475 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog
) = 0;
4478 /* The only way we can be making a call via an access type is if Name is an
4479 explicit dereference. In that case, get the list of formal args from the
4480 type the access type is pointing to. Otherwise, get the formals from the
4481 entity being called. */
4482 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
4484 const Entity_Id gnat_prefix_type
4485 = Underlying_Type (Etype (Prefix (Name (gnat_node
))));
4487 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
4488 variadic
= IN (Convention (gnat_prefix_type
), Convention_C_Variadic
);
4490 /* If the access type doesn't require foreign-compatible representation,
4491 be prepared for descriptors. */
4493 = targetm
.calls
.custom_function_descriptors
> 0
4494 && Can_Use_Internal_Rep (gnat_prefix_type
);
4496 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
4498 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4499 gnat_formal
= Empty
;
4501 by_descriptor
= false;
4505 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
4507 = IN (Convention (Entity (Name (gnat_node
))), Convention_C_Variadic
);
4508 by_descriptor
= false;
4511 /* The lifetime of the temporaries created for the call ends right after the
4512 return value is copied, so we can give them the scope of the elaboration
4513 routine at top level. */
4514 if (!current_function_decl
)
4516 current_function_decl
= get_elaboration_procedure ();
4517 went_into_elab_proc
= true;
4520 /* First, create the temporary for the return value when:
4522 1. There is no target and the function has copy-in/copy-out parameters,
4523 because we need to preserve the return value before copying back the
4526 2. There is no target and the call is made for neither an object, nor a
4527 renaming declaration, nor a return statement, nor an allocator, and
4528 the return type has variable size because in this case the gimplifier
4529 cannot create the temporary, or more generally is an aggregate type,
4530 because the gimplifier would create the temporary in the outermost
4531 scope instead of locally. But there is an exception for an allocator
4532 of an unconstrained record type with default discriminant because we
4533 allocate the actual size in this case, unlike the other 3 cases, so
4534 we need a temporary to fetch the discriminant and we create it here.
4536 3. There is a target and it is a slice or an array with fixed size,
4537 and the return type has variable size, because the gimplifier
4538 doesn't handle these cases.
4540 4. There is no target and we have misaligned In Out or Out parameters
4541 passed by reference, because we need to preserve the return value
4542 before copying back the parameters. However, in this case, we'll
4543 defer creating the temporary, see below.
4545 This must be done before we push a binding level around the call, since
4546 we will pop it before copying the return value. */
4548 && ((!gnu_target
&& TYPE_CI_CO_LIST (gnu_subprog_type
))
4550 && Nkind (Parent (gnat_node
)) != N_Object_Declaration
4551 && Nkind (Parent (gnat_node
)) != N_Object_Renaming_Declaration
4552 && Nkind (Parent (gnat_node
)) != N_Simple_Return_Statement
4553 && (!(Nkind (Parent (gnat_node
)) == N_Qualified_Expression
4554 && Nkind (Parent (Parent (gnat_node
))) == N_Allocator
)
4555 || type_is_padding_self_referential (gnu_result_type
))
4556 && AGGREGATE_TYPE_P (gnu_result_type
)
4557 && !TYPE_IS_FAT_POINTER_P (gnu_result_type
))
4559 && (TREE_CODE (gnu_target
) == ARRAY_RANGE_REF
4560 || (TREE_CODE (TREE_TYPE (gnu_target
)) == ARRAY_TYPE
4561 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target
)))
4563 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
)))
4565 gnu_retval
= create_temporary ("R", gnu_result_type
);
4566 DECL_RETURN_VALUE_P (gnu_retval
) = 1;
4569 /* If we don't need a value or have already created it, push a binding level
4570 around the call. This will narrow the lifetime of the temporaries we may
4571 need to make when translating the parameters as much as possible. */
4572 if (!returning_value
|| gnu_retval
)
4574 start_stmt_group ();
4576 pushed_binding_level
= true;
4579 /* Create the list of the actual parameters as GCC expects it, namely a
4580 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4581 is an expression and the TREE_PURPOSE field is null. But skip Out
4582 parameters not passed by reference and that need not be copied in. */
4583 for (gnat_actual
= First_Actual (gnat_node
);
4584 Present (gnat_actual
);
4585 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
4586 gnat_actual
= Next_Actual (gnat_actual
))
4588 Entity_Id gnat_formal_type
= Etype (gnat_formal
);
4589 tree gnu_formal_type
= gnat_to_gnu_type (gnat_formal_type
);
4590 tree gnu_formal
= present_gnu_tree (gnat_formal
)
4591 ? get_gnu_tree (gnat_formal
) : NULL_TREE
;
4592 const bool in_param
= (Ekind (gnat_formal
) == E_In_Parameter
);
4593 const bool is_true_formal_parm
4594 = gnu_formal
&& TREE_CODE (gnu_formal
) == PARM_DECL
;
4595 const bool is_by_ref_formal_parm
4596 = is_true_formal_parm
4597 && (DECL_BY_REF_P (gnu_formal
)
4598 || DECL_BY_COMPONENT_PTR_P (gnu_formal
));
4599 /* In the In Out or Out case, we must suppress conversions that yield
4600 an lvalue but can nevertheless cause the creation of a temporary,
4601 because we need the real object in this case, either to pass its
4602 address if it's passed by reference or as target of the back copy
4603 done after the call if it uses the copy-in/copy-out mechanism.
4604 We do it in the In case too, except for an unchecked conversion
4605 to an elementary type or a constrained composite type because it
4606 alone can cause the actual to be misaligned and the addressability
4607 test is applied to the real object. */
4608 const bool suppress_type_conversion
4609 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
4611 || !is_by_ref_formal_parm
4612 || (Is_Composite_Type (Underlying_Type (gnat_formal_type
))
4613 && !Is_Constrained (Underlying_Type (gnat_formal_type
)))))
4614 || (Nkind (gnat_actual
) == N_Type_Conversion
4615 && Is_Composite_Type (Underlying_Type (gnat_formal_type
))));
4616 Node_Id gnat_name
= suppress_type_conversion
4617 ? Expression (gnat_actual
) : gnat_actual
;
4618 tree gnu_name
= gnat_to_gnu (gnat_name
), gnu_name_type
;
4620 /* If it's possible we may need to use this expression twice, make sure
4621 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4622 to force side-effects before the call. */
4623 if (!in_param
&& !is_by_ref_formal_parm
)
4625 tree init
= NULL_TREE
;
4626 gnu_name
= gnat_stabilize_reference (gnu_name
, true, &init
);
4629 = build_compound_expr (TREE_TYPE (gnu_name
), init
, gnu_name
);
4632 /* If we are passing a non-addressable parameter by reference, pass the
4633 address of a copy. In the In Out or Out case, set up to copy back
4634 out after the call. */
4635 if (is_by_ref_formal_parm
4636 && (gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
)))
4637 && !addressable_p (gnu_name
, gnu_name_type
))
4639 tree gnu_orig
= gnu_name
, gnu_temp
, gnu_stmt
;
4641 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4642 but sort of an instantiation for them. */
4643 if (TREE_CODE (remove_conversions (gnu_name
, true)) == CONSTRUCTOR
)
4646 /* If the formal is passed by reference, a copy is not allowed. */
4647 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type
)
4648 || Is_Aliased (gnat_formal
))
4649 post_error ("misaligned actual cannot be passed by reference",
4652 /* If the mechanism was forced to by-ref, a copy is not allowed but
4653 we issue only a warning because this case is not strict Ada. */
4654 else if (DECL_FORCED_BY_REF_P (gnu_formal
))
4655 post_error ("misaligned actual cannot be passed by reference??",
4658 /* If the actual type of the object is already the nominal type,
4659 we have nothing to do, except if the size is self-referential
4660 in which case we'll remove the unpadding below. */
4661 if (TREE_TYPE (gnu_name
) == gnu_name_type
4662 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type
)))
4665 /* Otherwise remove the unpadding from all the objects. */
4666 else if (TREE_CODE (gnu_name
) == COMPONENT_REF
4667 && TYPE_IS_PADDING_P
4668 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))
4669 gnu_orig
= gnu_name
= TREE_OPERAND (gnu_name
, 0);
4671 /* Otherwise convert to the nominal type of the object if needed.
4672 There are several cases in which we need to make the temporary
4673 using this type instead of the actual type of the object when
4674 they are distinct, because the expectations of the callee would
4675 otherwise not be met:
4676 - if it's a justified modular type,
4677 - if the actual type is a smaller form of it,
4678 - if it's a smaller form of the actual type. */
4679 else if ((TREE_CODE (gnu_name_type
) == RECORD_TYPE
4680 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type
)
4681 || smaller_form_type_p (TREE_TYPE (gnu_name
),
4683 || (INTEGRAL_TYPE_P (gnu_name_type
)
4684 && smaller_form_type_p (gnu_name_type
,
4685 TREE_TYPE (gnu_name
))))
4686 gnu_name
= convert (gnu_name_type
, gnu_name
);
4688 /* If this is an In Out or Out parameter and we're returning a value,
4689 we need to create a temporary for the return value because we must
4690 preserve it before copying back at the very end. */
4691 if (!in_param
&& returning_value
&& !gnu_retval
)
4693 gnu_retval
= create_temporary ("R", gnu_result_type
);
4694 DECL_RETURN_VALUE_P (gnu_retval
) = 1;
4697 /* If we haven't pushed a binding level, push it now. This will
4698 narrow the lifetime of the temporary we are about to make as
4699 much as possible. */
4700 if (!pushed_binding_level
&& (!returning_value
|| gnu_retval
))
4702 start_stmt_group ();
4704 pushed_binding_level
= true;
4707 /* Create an explicit temporary holding the copy. */
4708 /* Do not initialize it for the _Init parameter of an initialization
4709 procedure since no data is meant to be passed in. */
4710 if (Ekind (gnat_formal
) == E_Out_Parameter
4711 && Is_Entity_Name (Name (gnat_node
))
4712 && Is_Init_Proc (Entity (Name (gnat_node
))))
4713 gnu_name
= gnu_temp
= create_temporary ("A", TREE_TYPE (gnu_name
));
4715 /* Initialize it on the fly like for an implicit temporary in the
4716 other cases, as we don't necessarily have a statement list. */
4719 gnu_temp
= create_init_temporary ("A", gnu_name
, &gnu_stmt
,
4721 gnu_name
= build_compound_expr (TREE_TYPE (gnu_name
), gnu_stmt
,
4725 /* Set up to move the copy back to the original if needed. */
4728 /* If the original is a COND_EXPR whose first arm isn't meant to
4729 be further used, just deal with the second arm. This is very
4730 likely the conditional expression built for a check. */
4731 if (TREE_CODE (gnu_orig
) == COND_EXPR
4732 && TREE_CODE (TREE_OPERAND (gnu_orig
, 1)) == COMPOUND_EXPR
4734 (TREE_OPERAND (TREE_OPERAND (gnu_orig
, 1), 1)))
4735 gnu_orig
= TREE_OPERAND (gnu_orig
, 2);
4738 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_orig
, gnu_temp
);
4739 set_expr_location_from_node (gnu_stmt
, gnat_node
);
4741 append_to_statement_list (gnu_stmt
, &gnu_after_list
);
4745 /* Start from the real object and build the actual. */
4746 tree gnu_actual
= gnu_name
;
4748 /* If atomic access is required for an In or In Out actual parameter,
4749 build the atomic load. */
4750 if (is_true_formal_parm
4751 && !is_by_ref_formal_parm
4752 && Ekind (gnat_formal
) != E_Out_Parameter
4753 && simple_atomic_access_required_p (gnat_actual
, &aa_sync
))
4754 gnu_actual
= build_atomic_load (gnu_actual
, aa_sync
);
4756 /* If this was a procedure call, we may not have removed any padding.
4757 So do it here for the part we will use as an input, if any. */
4758 if (Ekind (gnat_formal
) != E_Out_Parameter
4759 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
4761 = convert (get_unpadded_type (Etype (gnat_actual
)), gnu_actual
);
4763 /* Put back the conversion we suppressed above in the computation of the
4764 real object. And even if we didn't suppress any conversion there, we
4765 may have suppressed a conversion to the Etype of the actual earlier,
4766 since the parent is a procedure call, so put it back here. Note that
4767 we might have a dummy type here if the actual is the dereference of a
4768 pointer to it, but that's OK if the formal is passed by reference. */
4769 tree gnu_actual_type
= get_unpadded_type (Etype (gnat_actual
));
4770 if (TYPE_IS_DUMMY_P (gnu_actual_type
))
4771 gcc_assert (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
));
4772 else if (suppress_type_conversion
4773 && Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
4774 gnu_actual
= unchecked_convert (gnu_actual_type
, gnu_actual
,
4775 No_Truncation (gnat_actual
));
4777 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
4779 gigi_checking_assert (!Do_Range_Check (gnat_actual
));
4781 /* First see if the parameter is passed by reference. */
4782 if (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
))
4786 /* In Out or Out parameters passed by reference don't use the
4787 copy-in/copy-out mechanism so the address of the real object
4788 must be passed to the function. */
4789 gnu_actual
= gnu_name
;
4791 /* If we have a padded type, be sure we've removed padding. */
4792 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
4793 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
4796 /* If we have the constructed subtype of an aliased object
4797 with an unconstrained nominal subtype, the type of the
4798 actual includes the template, although it is formally
4799 constrained. So we need to convert it back to the real
4800 constructed subtype to retrieve the constrained part
4801 and takes its address. */
4802 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
4803 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual
))
4804 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual
))
4805 && Is_Array_Type (Underlying_Type (Etype (gnat_actual
))))
4806 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
4809 /* There is no need to convert the actual to the formal's type before
4810 taking its address. The only exception is for unconstrained array
4811 types because of the way we build fat pointers. */
4812 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4814 /* Put back the conversion we suppressed above for In Out or Out
4815 parameters, since it may set the bounds of the actual. */
4816 if (!in_param
&& suppress_type_conversion
)
4817 gnu_actual
= convert (gnu_actual_type
, gnu_actual
);
4818 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4821 /* Take the address of the object and convert to the proper pointer
4823 gnu_formal_type
= TREE_TYPE (gnu_formal
);
4824 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4827 /* Then see if the parameter is an array passed to a foreign convention
4829 else if (is_true_formal_parm
&& DECL_BY_COMPONENT_PTR_P (gnu_formal
))
4831 gnu_actual
= maybe_padded_object (gnu_actual
);
4832 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
4834 /* Take the address of the object and convert to the proper pointer
4835 type. We'd like to actually compute the address of the beginning
4836 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4837 possibility that the ARRAY_REF might return a constant and we'd be
4838 getting the wrong address. Neither approach is exactly correct,
4839 but this is the most likely to work in all cases. */
4840 gnu_formal_type
= TREE_TYPE (gnu_formal
);
4841 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4844 /* Then see if the parameter is passed by copy. */
4845 else if (is_true_formal_parm
)
4848 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
4850 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4852 /* If this is a front-end built-in function, there is no need to
4853 convert to the type used to pass the argument. */
4854 if (!frontend_builtin
)
4855 gnu_actual
= convert (DECL_ARG_TYPE (gnu_formal
), gnu_actual
);
4858 /* Then see if this is an unnamed parameter in a variadic C function. */
4861 /* This is based on the processing done in gnat_to_gnu_param, but
4862 we expect the mechanism to be set in (almost) all cases. */
4863 const Mechanism_Type mech
= Mechanism (gnat_formal
);
4865 /* Strip off possible padding type. */
4866 if (TYPE_IS_PADDING_P (gnu_formal_type
))
4867 gnu_formal_type
= TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
4869 /* Arrays are passed as pointers to element type. First check for
4870 unconstrained array and get the underlying array. */
4871 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4874 (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_formal_type
))));
4876 /* Arrays are passed as pointers to element type. */
4877 if (mech
!= By_Copy
&& TREE_CODE (gnu_formal_type
) == ARRAY_TYPE
)
4879 gnu_actual
= maybe_padded_object (gnu_actual
);
4880 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
4882 /* Strip off any multi-dimensional entries, then strip
4883 off the last array to get the component type. */
4884 while (TREE_CODE (TREE_TYPE (gnu_formal_type
)) == ARRAY_TYPE
4885 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_formal_type
)))
4886 gnu_formal_type
= TREE_TYPE (gnu_formal_type
);
4888 gnu_formal_type
= TREE_TYPE (gnu_formal_type
);
4889 gnu_formal_type
= build_pointer_type (gnu_formal_type
);
4891 = build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4894 /* Fat pointers are passed as thin pointers. */
4895 else if (TYPE_IS_FAT_POINTER_P (gnu_formal_type
))
4897 = make_type_from_size (gnu_formal_type
,
4898 size_int (POINTER_SIZE
), 0);
4900 /* If we were requested or muss pass by reference, do so.
4901 If we were requested to pass by copy, do so.
4902 Otherwise, pass In Out or Out parameters or aggregates by
4904 else if (mech
== By_Reference
4905 || must_pass_by_ref (gnu_formal_type
)
4907 && (!in_param
|| AGGREGATE_TYPE_P (gnu_formal_type
))))
4909 gnu_formal_type
= build_reference_type (gnu_formal_type
);
4911 = build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4914 /* Otherwise pass by copy after applying default C promotions. */
4917 if (INTEGRAL_TYPE_P (gnu_formal_type
)
4918 && TYPE_PRECISION (gnu_formal_type
)
4919 < TYPE_PRECISION (integer_type_node
))
4920 gnu_formal_type
= integer_type_node
;
4922 else if (SCALAR_FLOAT_TYPE_P (gnu_formal_type
)
4923 && TYPE_PRECISION (gnu_formal_type
)
4924 < TYPE_PRECISION (double_type_node
))
4925 gnu_formal_type
= double_type_node
;
4928 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4931 /* If we didn't create a PARM_DECL for the formal, this means that
4932 it is an Out parameter not passed by reference and that need not
4933 be copied in. In this case, the value of the actual need not be
4934 read. However, we still need to make sure that its side-effects
4935 are evaluated before the call, so we evaluate its address. */
4939 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
4941 if (TREE_SIDE_EFFECTS (gnu_name
))
4943 tree addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_name
);
4944 append_to_statement_list (addr
, &gnu_stmt_list
);
4950 gnu_actual_vec
.safe_push (gnu_actual
);
4953 if (frontend_builtin
)
4955 tree pred_cst
= build_int_cst (integer_type_node
, PRED_BUILTIN_EXPECT
);
4956 enum internal_fn icode
= IFN_BUILTIN_EXPECT
;
4958 switch (DECL_FE_FUNCTION_CODE (gnu_subprog
))
4960 case BUILT_IN_EXPECT
:
4962 case BUILT_IN_LIKELY
:
4963 gnu_actual_vec
.safe_push (boolean_true_node
);
4965 case BUILT_IN_UNLIKELY
:
4966 gnu_actual_vec
.safe_push (boolean_false_node
);
4972 gnu_actual_vec
.safe_push (pred_cst
);
4975 = build_call_expr_internal_loc_array (UNKNOWN_LOCATION
,
4978 gnu_actual_vec
.length (),
4979 gnu_actual_vec
.begin ());
4984 = build_call_array_loc (UNKNOWN_LOCATION
,
4986 build_unary_op (ADDR_EXPR
, NULL_TREE
,
4988 gnu_actual_vec
.length (),
4989 gnu_actual_vec
.begin ());
4990 CALL_EXPR_BY_DESCRIPTOR (gnu_call
) = by_descriptor
;
4993 set_expr_location_from_node (gnu_call
, gnat_node
);
4995 /* If we have created a temporary for the return value, initialize it. */
4999 = build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_retval
, gnu_call
);
5000 set_expr_location_from_node (gnu_stmt
, gnat_node
);
5001 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
5002 gnu_call
= gnu_retval
;
5005 /* If this is a subprogram with copy-in/copy-out parameters, we need to
5006 unpack the valued returned from the function into the In Out or Out
5007 parameters. We deal with the function return (if this is an Ada
5009 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
5011 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
5012 copy-out parameters. */
5013 tree gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
5014 const int length
= list_length (gnu_cico_list
);
5016 /* The call sequence must contain one and only one call, even though the
5017 function is pure. Save the result into a temporary if needed. */
5024 = create_init_temporary ("P", gnu_call
, &gnu_stmt
, gnat_node
);
5025 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
5028 gnu_name_list
= nreverse (gnu_name_list
);
5031 /* The first entry is for the actual return value if this is a
5032 function, so skip it. */
5034 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
5036 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
5037 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
5039 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
5041 for (gnat_actual
= First_Actual (gnat_node
);
5042 Present (gnat_actual
);
5043 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
5044 gnat_actual
= Next_Actual (gnat_actual
))
5045 /* If we are dealing with a copy-in/copy-out parameter, we must
5046 retrieve its value from the record returned in the call. */
5047 if (!(present_gnu_tree (gnat_formal
)
5048 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
5049 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
5050 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))))
5051 && Ekind (gnat_formal
) != E_In_Parameter
)
5053 /* Get the value to assign to this In Out or Out parameter. It is
5054 either the result of the function if there is only a single such
5055 parameter or the appropriate field from the record returned. */
5059 : build_component_ref (gnu_call
, TREE_PURPOSE (gnu_cico_list
),
5062 /* If the actual is a conversion, get the inner expression, which
5063 will be the real destination, and convert the result to the
5064 type of the actual parameter. */
5066 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
5068 /* If the result is padded, remove the padding. */
5069 gnu_result
= maybe_padded_object (gnu_result
);
5071 /* If the actual is a type conversion, the real target object is
5072 denoted by the inner Expression and we need to convert the
5073 result to the associated type.
5074 We also need to convert our gnu assignment target to this type
5075 if the corresponding GNU_NAME was constructed from the GNAT
5076 conversion node and not from the inner Expression. */
5077 if (Nkind (gnat_actual
) == N_Type_Conversion
)
5079 const Node_Id gnat_expr
= Expression (gnat_actual
);
5081 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
5084 = convert_with_check (Etype (gnat_expr
), gnu_result
,
5085 Do_Overflow_Check (gnat_actual
),
5086 Float_Truncate (gnat_actual
),
5089 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal
))))
5090 gnu_actual
= convert (TREE_TYPE (gnu_result
), gnu_actual
);
5093 /* Unchecked conversions as actuals for Out parameters are not
5094 allowed in user code because they are not variables, but do
5095 occur in front-end expansions. The associated GNU_NAME is
5096 always obtained from the inner expression in such cases. */
5097 else if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
5098 gnu_result
= unchecked_convert (TREE_TYPE (gnu_actual
),
5100 No_Truncation (gnat_actual
));
5103 gigi_checking_assert (!Do_Range_Check (gnat_actual
));
5105 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
5106 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
5107 gnu_result
= convert (TREE_TYPE (gnu_actual
), gnu_result
);
5110 get_atomic_access (gnat_actual
, &aa_type
, &aa_sync
);
5112 /* If an outer atomic access is required for an actual parameter,
5113 build the load-modify-store sequence. */
5114 if (aa_type
== OUTER_ATOMIC
)
5116 = build_load_modify_store (gnu_actual
, gnu_result
, gnat_node
);
5118 /* Or else, if a simple atomic access is required, build the atomic
5120 else if (aa_type
== SIMPLE_ATOMIC
)
5122 = build_atomic_store (gnu_actual
, gnu_result
, aa_sync
);
5124 /* Otherwise build a regular assignment. */
5126 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5127 gnu_actual
, gnu_result
);
5129 if (EXPR_P (gnu_result
))
5130 set_expr_location_from_node (gnu_result
, gnat_node
);
5131 append_to_statement_list (gnu_result
, &gnu_stmt_list
);
5132 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
5133 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
5137 /* If this is a function call, the result is the call expression unless a
5138 target is specified, in which case we copy the result into the target
5139 and return the assignment statement. */
5142 /* If this is a function with copy-in/copy-out parameters, extract the
5143 return value from it and update the return type. */
5144 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
5146 tree gnu_elmt
= TYPE_CI_CO_LIST (gnu_subprog_type
);
5148 = build_component_ref (gnu_call
, TREE_PURPOSE (gnu_elmt
), false);
5149 gnu_result_type
= TREE_TYPE (gnu_call
);
5152 /* If the function returns an unconstrained array or by direct reference,
5153 we have to dereference the pointer. */
5154 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
)
5155 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
))
5156 gnu_call
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_call
);
5160 Node_Id gnat_parent
= Parent (gnat_node
);
5161 enum tree_code op_code
;
5163 gigi_checking_assert (!Do_Range_Check (gnat_node
));
5165 /* ??? If the return type has variable size, then force the return
5166 slot optimization as we would not be able to create a temporary.
5167 That's what has been done historically. */
5168 if (return_type_with_variable_size_p (gnu_result_type
))
5169 op_code
= INIT_EXPR
;
5171 op_code
= MODIFY_EXPR
;
5173 /* Use the required method to move the result to the target. */
5174 if (atomic_access
== OUTER_ATOMIC
)
5176 = build_load_modify_store (gnu_target
, gnu_call
, gnat_node
);
5177 else if (atomic_access
== SIMPLE_ATOMIC
)
5178 gnu_call
= build_atomic_store (gnu_target
, gnu_call
, atomic_sync
);
5181 = build_binary_op (op_code
, NULL_TREE
, gnu_target
, gnu_call
);
5183 if (EXPR_P (gnu_call
))
5184 set_expr_location_from_node (gnu_call
, gnat_parent
);
5185 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
5188 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
5191 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
5192 parameters, the result is just the call statement. */
5193 else if (!TYPE_CI_CO_LIST (gnu_subprog_type
))
5194 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
5196 /* Finally, add the copy back statements, if any. */
5197 append_to_statement_list (gnu_after_list
, &gnu_stmt_list
);
5199 if (went_into_elab_proc
)
5200 current_function_decl
= NULL_TREE
;
5202 /* If we have pushed a binding level, pop it and finish up the enclosing
5204 if (pushed_binding_level
)
5206 add_stmt (gnu_stmt_list
);
5208 gnu_result
= end_stmt_group ();
5211 /* Otherwise, retrieve the statement list, if any. */
5212 else if (gnu_stmt_list
)
5213 gnu_result
= gnu_stmt_list
;
5215 /* Otherwise, just return the call expression. */
5219 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
5220 But first simplify if we have only one statement in the list. */
5221 if (returning_value
)
5223 tree first
= expr_first (gnu_result
), last
= expr_last (gnu_result
);
5227 = build_compound_expr (TREE_TYPE (gnu_call
), gnu_result
, gnu_call
);
5233 /* Subroutine of gnat_to_gnu to translate gnat_node, an
5234 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
5237 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node
)
5239 /* If just annotating, ignore all EH and cleanups. */
5241 = (!type_annotate_only
5242 && Present (Exception_Handlers (gnat_node
))
5243 && Back_End_Exceptions ());
5244 const bool fe_sjlj_eh
5245 = (!type_annotate_only
5246 && Present (Exception_Handlers (gnat_node
))
5247 && Exception_Mechanism
== Front_End_SJLJ
);
5248 const bool at_end
= !type_annotate_only
&& Present (At_End_Proc (gnat_node
));
5249 const bool binding_for_block
= (at_end
|| gcc_eh
|| fe_sjlj_eh
);
5250 tree gnu_jmpsave_decl
= NULL_TREE
;
5251 tree gnu_jmpbuf_decl
= NULL_TREE
;
5252 tree gnu_inner_block
; /* The statement(s) for the block itself. */
5257 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
5258 and the front-end has its own SJLJ mechanism. To call the GCC mechanism,
5259 we call add_cleanup, and when we leave the binding, end_stmt_group will
5260 create the TRY_FINALLY_EXPR construct.
5262 ??? The region level calls down there have been specifically put in place
5263 for a ZCX context and currently the order in which things are emitted
5264 (region/handlers) is different from the SJLJ case. Instead of putting
5265 other calls with different conditions at other places for the SJLJ case,
5266 it seems cleaner to reorder things for the SJLJ case and generalize the
5267 condition to make it not ZCX specific.
5269 If there are any exceptions or cleanup processing involved, we need an
5270 outer statement group (for front-end SJLJ) and binding level. */
5271 if (binding_for_block
)
5273 start_stmt_group ();
5277 /* If using fe_sjlj_eh, make the variables for the setjmp buffer and save
5278 area for address of previous buffer. Do this first since we need to have
5279 the setjmp buf known for any decls in this block. */
5283 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
5285 build_call_n_expr (get_jmpbuf_decl
, 0),
5286 false, false, false, false, false, true, false,
5289 /* The __builtin_setjmp receivers will immediately reinstall it. Now
5290 because of the unstructured form of EH used by fe_sjlj_eh, there
5291 might be forward edges going to __builtin_setjmp receivers on which
5292 it is uninitialized, although they will never be actually taken. */
5293 TREE_NO_WARNING (gnu_jmpsave_decl
) = 1;
5295 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE
,
5298 false, false, false, false, false, true, false,
5301 set_block_jmpbuf_decl (gnu_jmpbuf_decl
);
5303 /* When we exit this block, restore the saved value. */
5304 add_cleanup (build_call_n_expr (set_jmpbuf_decl
, 1, gnu_jmpsave_decl
),
5305 Present (End_Label (gnat_node
))
5306 ? End_Label (gnat_node
) : gnat_node
);
5309 /* If we are to call a function when exiting this block, add a cleanup
5310 to the binding level we made above. Note that add_cleanup is FIFO
5311 so we must register this cleanup after the EH cleanup just above. */
5314 tree proc_decl
= gnat_to_gnu (At_End_Proc (gnat_node
));
5316 /* When not optimizing, disable inlining of finalizers as this can
5317 create a more complex CFG in the parent function. */
5318 if (!optimize
|| optimize_debug
)
5319 DECL_DECLARED_INLINE_P (proc_decl
) = 0;
5321 /* If there is no end label attached, we use the location of the At_End
5322 procedure because Expand_Cleanup_Actions might reset the location of
5323 the enclosing construct to that of an inner statement. */
5324 add_cleanup (build_call_n_expr (proc_decl
, 0),
5325 Present (End_Label (gnat_node
))
5326 ? End_Label (gnat_node
) : At_End_Proc (gnat_node
));
5329 /* Now build the tree for the declarations and statements inside this block.
5330 If this is SJLJ, set our jmp_buf as the current buffer. */
5331 start_stmt_group ();
5335 gnu_expr
= build_call_n_expr (set_jmpbuf_decl
, 1,
5336 build_unary_op (ADDR_EXPR
, NULL_TREE
,
5338 set_expr_location_from_node (gnu_expr
, gnat_node
);
5339 add_stmt (gnu_expr
);
5342 if (Present (First_Real_Statement (gnat_node
)))
5343 process_decls (Statements (gnat_node
), Empty
,
5344 First_Real_Statement (gnat_node
), true, true);
5346 /* Generate code for each statement in the block. */
5347 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
5348 ? First_Real_Statement (gnat_node
)
5349 : First (Statements (gnat_node
)));
5350 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
5351 add_stmt (gnat_to_gnu (gnat_temp
));
5353 gnu_inner_block
= end_stmt_group ();
5355 /* Now generate code for the two exception models, if either is relevant for
5359 tree
*gnu_else_ptr
= 0;
5362 /* Make a binding level for the exception handling declarations and code
5363 and set up gnu_except_ptr_stack for the handlers to use. */
5364 start_stmt_group ();
5367 vec_safe_push (gnu_except_ptr_stack
,
5368 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
5369 build_pointer_type (except_type_node
),
5370 build_call_n_expr (get_excptr_decl
, 0),
5371 false, false, false, false, false,
5372 true, false, NULL
, gnat_node
));
5374 /* Generate code for each handler. The N_Exception_Handler case does the
5375 real work and returns a COND_EXPR for each handler, which we chain
5377 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
5378 Present (gnat_temp
); gnat_temp
= Next_Non_Pragma (gnat_temp
))
5380 gnu_expr
= gnat_to_gnu (gnat_temp
);
5382 /* If this is the first one, set it as the outer one. Otherwise,
5383 point the "else" part of the previous handler to us. Then point
5384 to our "else" part. */
5386 add_stmt (gnu_expr
);
5388 *gnu_else_ptr
= gnu_expr
;
5390 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
5393 /* If none of the exception handlers did anything, re-raise but do not
5395 gnu_expr
= build_call_n_expr (raise_nodefer_decl
, 1,
5396 gnu_except_ptr_stack
->last ());
5397 set_expr_location_from_node
5399 Present (End_Label (gnat_node
)) ? End_Label (gnat_node
) : gnat_node
);
5402 *gnu_else_ptr
= gnu_expr
;
5404 add_stmt (gnu_expr
);
5406 /* End the binding level dedicated to the exception handlers and get the
5407 whole statement group. */
5408 gnu_except_ptr_stack
->pop ();
5410 gnu_handler
= end_stmt_group ();
5412 /* If the setjmp returns 1, we restore our incoming longjmp value and
5413 then check the handlers. */
5414 start_stmt_group ();
5415 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl
, 1,
5418 add_stmt (gnu_handler
);
5419 gnu_handler
= end_stmt_group ();
5421 /* This block is now "if (setjmp) ... <handlers> else <block>". */
5422 gnu_result
= build3 (COND_EXPR
, void_type_node
,
5425 build_unary_op (ADDR_EXPR
, NULL_TREE
,
5427 gnu_handler
, gnu_inner_block
);
5434 /* First make a block containing the handlers. */
5435 start_stmt_group ();
5436 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
5437 Present (gnat_temp
);
5438 gnat_temp
= Next_Non_Pragma (gnat_temp
))
5439 add_stmt (gnat_to_gnu (gnat_temp
));
5440 gnu_handlers
= end_stmt_group ();
5442 /* Now make the TRY_CATCH_EXPR for the block. */
5443 gnu_result
= build2 (TRY_CATCH_EXPR
, void_type_node
,
5444 gnu_inner_block
, gnu_handlers
);
5445 /* Set a location. We need to find a unique location for the dispatching
5446 code, otherwise we can get coverage or debugging issues. Try with
5447 the location of the end label. */
5448 if (Present (End_Label (gnat_node
))
5449 && Sloc_to_locus (Sloc (End_Label (gnat_node
)), &locus
))
5450 SET_EXPR_LOCATION (gnu_result
, locus
);
5452 /* Clear column information so that the exception handler of an
5453 implicit transient block does not incorrectly inherit the slocs
5454 of a decision, which would otherwise confuse control flow based
5455 coverage analysis tools. */
5456 set_expr_location_from_node (gnu_result
, gnat_node
, true);
5459 gnu_result
= gnu_inner_block
;
5461 /* Now close our outer block, if we had to make one. */
5462 if (binding_for_block
)
5464 add_stmt (gnu_result
);
5466 gnu_result
= end_stmt_group ();
5472 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5473 to a GCC tree, which is returned. This is the variant for front-end sjlj
5474 exception handling. */
5477 Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node
)
5479 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
5480 an "if" statement to select the proper exceptions. For "Others", exclude
5481 exceptions where Handled_By_Others is nonzero unless the All_Others flag
5482 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
5483 tree gnu_choice
= boolean_false_node
;
5484 tree gnu_body
= build_stmt_group (Statements (gnat_node
), false);
5487 for (gnat_temp
= First (Exception_Choices (gnat_node
));
5488 gnat_temp
; gnat_temp
= Next (gnat_temp
))
5492 if (Nkind (gnat_temp
) == N_Others_Choice
)
5494 if (All_Others (gnat_temp
))
5495 this_choice
= boolean_true_node
;
5499 (EQ_EXPR
, boolean_type_node
,
5504 (INDIRECT_REF
, NULL_TREE
,
5505 gnu_except_ptr_stack
->last ()),
5506 not_handled_by_others_decl
,
5511 else if (Nkind (gnat_temp
) == N_Identifier
5512 || Nkind (gnat_temp
) == N_Expanded_Name
)
5514 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
5517 /* Exception may be a renaming. Recover original exception which is
5518 the one elaborated and registered. */
5519 if (Present (Renamed_Object (gnat_ex_id
)))
5520 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
5522 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, false);
5526 (EQ_EXPR
, boolean_type_node
,
5527 gnu_except_ptr_stack
->last (),
5528 convert (TREE_TYPE (gnu_except_ptr_stack
->last ()),
5529 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
5534 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
5535 gnu_choice
, this_choice
);
5538 return build3 (COND_EXPR
, void_type_node
, gnu_choice
, gnu_body
, NULL_TREE
);
5541 /* Return true if no statement in GNAT_LIST can alter the control flow. */
5544 stmt_list_cannot_alter_control_flow_p (List_Id gnat_list
)
5549 /* This is very conservative, we reject everything except for simple
5550 assignments between identifiers or literals. */
5551 for (Node_Id gnat_node
= First (gnat_list
);
5552 Present (gnat_node
);
5553 gnat_node
= Next (gnat_node
))
5555 if (Nkind (gnat_node
) != N_Assignment_Statement
)
5558 if (Nkind (Name (gnat_node
)) != N_Identifier
)
5561 Node_Kind nkind
= Nkind (Expression (gnat_node
));
5562 if (nkind
!= N_Identifier
5563 && nkind
!= N_Integer_Literal
5564 && nkind
!= N_Real_Literal
)
5571 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5572 to a GCC tree, which is returned. This is the variant for GCC exception
5576 Exception_Handler_to_gnu_gcc (Node_Id gnat_node
)
5578 tree gnu_etypes_list
= NULL_TREE
;
5580 /* We build a TREE_LIST of nodes representing what exception types this
5581 handler can catch, with special cases for others and all others cases.
5583 Each exception type is actually identified by a pointer to the exception
5584 id, or to a dummy object for "others" and "all others". */
5585 for (Node_Id gnat_temp
= First (Exception_Choices (gnat_node
));
5587 gnat_temp
= Next (gnat_temp
))
5589 tree gnu_expr
, gnu_etype
;
5591 if (Nkind (gnat_temp
) == N_Others_Choice
)
5593 gnu_expr
= All_Others (gnat_temp
) ? all_others_decl
: others_decl
;
5594 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
5596 else if (Nkind (gnat_temp
) == N_Identifier
5597 || Nkind (gnat_temp
) == N_Expanded_Name
)
5599 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
5601 /* Exception may be a renaming. Recover original exception which is
5602 the one elaborated and registered. */
5603 if (Present (Renamed_Object (gnat_ex_id
)))
5604 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
5606 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, false);
5607 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
5612 /* The GCC interface expects NULL to be passed for catch all handlers, so
5613 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
5614 is integer_zero_node. It would not work, however, because GCC's
5615 notion of "catch all" is stronger than our notion of "others". Until
5616 we correctly use the cleanup interface as well, doing that would
5617 prevent the "all others" handlers from being seen, because nothing
5618 can be caught beyond a catch all from GCC's point of view. */
5619 gnu_etypes_list
= tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
5622 start_stmt_group ();
5625 /* Expand a call to the begin_handler hook at the beginning of the
5626 handler, and arrange for a call to the end_handler hook to occur
5627 on every possible exit path. GDB sets a breakpoint in the
5628 begin_handler for catchpoints.
5630 A v1 begin handler saves the cleanup from the exception object,
5631 and marks the exception as in use, so that it will not be
5632 released by other handlers. A v1 end handler restores the
5633 cleanup and releases the exception object, unless it is still
5634 claimed, or the exception is being propagated (reraised).
5636 __builtin_eh_pointer references the exception occurrence being
5637 handled or propagated. Within the handler region, it is the
5638 former, but within the else branch of the EH_ELSE_EXPR, i.e. the
5639 exceptional cleanup path, it is the latter, so we must save the
5640 occurrence being handled early on, so that, should an exception
5641 be (re)raised, we can release the current exception, or figure
5642 out we're not to release it because we're propagating a reraise
5645 We use local variables to retrieve the incoming value at handler
5646 entry time (EXPTR), the saved cleanup (EXCLN) and the token
5647 (EXVTK), and reuse them to feed the end_handler hook's argument
5650 /* CODE: void *EXPTR = __builtin_eh_pointer (0); */
5651 tree gnu_current_exc_ptr
5652 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
5653 1, integer_zero_node
);
5655 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
5656 ptr_type_node
, gnu_current_exc_ptr
,
5657 true, false, false, false, false, true, true,
5660 tree prev_gnu_incoming_exc_ptr
= gnu_incoming_exc_ptr
;
5661 gnu_incoming_exc_ptr
= exc_ptr
;
5663 /* begin_handler_decl must not throw, so we can use it as an
5664 initializer for a variable used in cleanups.
5666 CODE: void *EXCLN = __gnat_begin_handler_v1 (EXPTR); */
5668 = create_var_decl (get_identifier ("EXCLN"), NULL_TREE
,
5670 build_call_n_expr (begin_handler_decl
, 1,
5672 true, false, false, false, false,
5673 true, true, NULL
, gnat_node
);
5675 /* Declare and initialize the choice parameter, if present. */
5676 if (Present (Choice_Parameter (gnat_node
)))
5679 = gnat_to_gnu_entity (Choice_Parameter (gnat_node
), NULL_TREE
, true);
5681 /* CODE: __gnat_set_exception_parameter (&choice_param, EXPTR); */
5682 add_stmt (build_call_n_expr
5683 (set_exception_parameter_decl
, 2,
5684 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_param
),
5685 gnu_incoming_exc_ptr
));
5688 /* CODE: <handler proper> */
5689 add_stmt_list (Statements (gnat_node
));
5691 tree call
= build_call_n_expr (end_handler_decl
, 3,
5695 /* If the handler can only end by falling off the end, don't bother
5697 if (stmt_list_cannot_alter_control_flow_p (Statements (gnat_node
)))
5698 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, NULL); */
5699 add_stmt_with_node (call
, gnat_node
);
5700 /* Otherwise, all of the above is after
5703 The call above will appear after
5706 And the code below will appear after
5709 The else block to a finally block is taken instead of the finally
5710 block when an exception propagates out of the try block. */
5713 start_stmt_group ();
5715 /* CODE: void *EXPRP = __builtin_eh_handler (0); */
5717 = create_var_decl (get_identifier ("EXPRP"), NULL_TREE
,
5719 build_call_expr (builtin_decl_explicit
5720 (BUILT_IN_EH_POINTER
),
5721 1, integer_zero_node
),
5722 true, false, false, false, false,
5723 true, true, NULL
, gnat_node
);
5725 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, EXPRP); */
5726 tree ecall
= build_call_n_expr (end_handler_decl
, 3,
5731 add_stmt_with_node (ecall
, gnat_node
);
5735 tree eblk
= end_stmt_group ();
5736 tree ehls
= build2 (EH_ELSE_EXPR
, void_type_node
, call
, eblk
);
5737 add_cleanup (ehls
, gnat_node
);
5742 gnu_incoming_exc_ptr
= prev_gnu_incoming_exc_ptr
;
5745 build2 (CATCH_EXPR
, void_type_node
, gnu_etypes_list
, end_stmt_group ());
5748 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
5751 Compilation_Unit_to_gnu (Node_Id gnat_node
)
5753 const Node_Id gnat_unit
= Unit (gnat_node
);
5754 const bool body_p
= (Nkind (gnat_unit
) == N_Package_Body
5755 || Nkind (gnat_unit
) == N_Subprogram_Body
);
5756 const Entity_Id gnat_unit_entity
= Defining_Entity (gnat_unit
);
5757 Entity_Id gnat_entity
;
5758 Node_Id gnat_pragma
, gnat_iter
;
5759 /* Make the decl for the elaboration procedure. Emit debug info for it, so
5760 that users can break into their elaboration code in debuggers. Kludge:
5761 don't consider it as a definition so that we have a line map for its
5762 body, but no subprogram description in debug info. In addition, don't
5763 qualify it as artificial, even though it is not a user subprogram per se,
5764 in particular for specs. Unlike, say, clones created internally by the
5765 compiler, this subprogram materializes specific user code and flagging it
5766 artificial would take elab code away from gcov's analysis. */
5767 tree gnu_elab_proc_decl
5768 = create_subprog_decl
5769 (create_concat_name (gnat_unit_entity
, body_p
? "elabb" : "elabs"),
5770 NULL_TREE
, void_ftype
, NULL_TREE
,
5771 is_default
, true, false, false, true, false, NULL
, gnat_unit
);
5772 struct elab_info
*info
;
5774 vec_safe_push (gnu_elab_proc_stack
, gnu_elab_proc_decl
);
5775 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl
) = 1;
5777 /* Initialize the information structure for the function. */
5778 allocate_struct_function (gnu_elab_proc_decl
, false);
5781 current_function_decl
= NULL_TREE
;
5783 start_stmt_group ();
5786 /* For a body, first process the spec if there is one. */
5787 if (Nkind (gnat_unit
) == N_Package_Body
5788 || (Nkind (gnat_unit
) == N_Subprogram_Body
&& !Acts_As_Spec (gnat_node
)))
5789 add_stmt (gnat_to_gnu (Library_Unit (gnat_node
)));
5791 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
5793 elaborate_all_entities (gnat_node
);
5795 if (Nkind (gnat_unit
) == N_Subprogram_Declaration
5796 || Nkind (gnat_unit
) == N_Generic_Package_Declaration
5797 || Nkind (gnat_unit
) == N_Generic_Subprogram_Declaration
)
5801 /* Then process any pragmas and declarations preceding the unit. */
5802 for (gnat_pragma
= First (Context_Items (gnat_node
));
5803 Present (gnat_pragma
);
5804 gnat_pragma
= Next (gnat_pragma
))
5805 if (Nkind (gnat_pragma
) == N_Pragma
)
5806 add_stmt (gnat_to_gnu (gnat_pragma
));
5807 process_decls (Declarations (Aux_Decls_Node (gnat_node
)), Empty
, Empty
,
5810 /* Process the unit itself. */
5811 add_stmt (gnat_to_gnu (gnat_unit
));
5813 /* Generate code for all the inlined subprograms. */
5814 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
5815 Present (gnat_entity
);
5816 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
5820 /* Without optimization, process only the required subprograms. */
5821 if (!optimize
&& !Has_Pragma_Inline_Always (gnat_entity
))
5824 /* The set of inlined subprograms is computed from data recorded early
5825 during expansion and it can be a strict superset of the final set
5826 computed after semantic analysis, for example if a call to such a
5827 subprogram occurs in a pragma Assert and assertions are disabled.
5828 In that case, semantic analysis resets Is_Public to false but the
5829 entry for the subprogram in the inlining tables is stalled. */
5830 if (!Is_Public (gnat_entity
))
5833 gnat_body
= Parent (Declaration_Node (gnat_entity
));
5834 if (Nkind (gnat_body
) != N_Subprogram_Body
)
5836 /* ??? This happens when only the spec of a package is provided. */
5837 if (No (Corresponding_Body (gnat_body
)))
5841 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
5844 /* Define the entity first so we set DECL_EXTERNAL. */
5845 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
5846 add_stmt (gnat_to_gnu (gnat_body
));
5849 /* Process any pragmas and actions following the unit. */
5850 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node
)));
5851 add_stmt_list (Actions (Aux_Decls_Node (gnat_node
)));
5852 finalize_from_limited_with ();
5854 /* Then process the expressions of pragma Compile_Time_{Error|Warning} to
5855 annotate types referenced therein if they have not been annotated. */
5856 for (int i
= 0; gnat_compile_time_expr_list
.iterate (i
, &gnat_iter
); i
++)
5857 (void) gnat_to_gnu_external (gnat_iter
);
5858 gnat_compile_time_expr_list
.release ();
5860 /* Save away what we've made so far and finish it up. */
5861 set_current_block_context (gnu_elab_proc_decl
);
5863 DECL_SAVED_TREE (gnu_elab_proc_decl
) = end_stmt_group ();
5864 set_end_locus_from_node (gnu_elab_proc_decl
, gnat_unit
);
5865 gnu_elab_proc_stack
->pop ();
5867 /* Record this potential elaboration procedure for later processing. */
5868 info
= ggc_alloc
<elab_info
> ();
5869 info
->next
= elab_info_list
;
5870 info
->elab_proc
= gnu_elab_proc_decl
;
5871 info
->gnat_node
= gnat_node
;
5872 elab_info_list
= info
;
5874 /* Force the processing for all nodes that remain in the queue. */
5875 process_deferred_decl_context (true);
5878 /* Mark COND, a boolean expression, as predicating a call to a noreturn
5879 function, i.e. predict that it is very likely false, and return it.
5881 The compiler will automatically predict the last edge leading to a call
5882 to a noreturn function as very unlikely taken. This function makes it
5883 possible to extend the prediction to predecessors in case the condition
5884 is made up of several short-circuit operators. */
5887 build_noreturn_cond (tree cond
)
5889 tree pred_cst
= build_int_cst (integer_type_node
, PRED_NORETURN
);
5891 build_call_expr_internal_loc (UNKNOWN_LOCATION
, IFN_BUILTIN_EXPECT
,
5892 boolean_type_node
, 3, cond
,
5893 boolean_false_node
, pred_cst
);
5896 /* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a
5897 range of values, into GNU_LOW and GNU_HIGH bounds. */
5900 Range_to_gnu (Node_Id gnat_range
, tree
*gnu_low
, tree
*gnu_high
)
5902 /* GNAT_RANGE is either an N_Range or an identifier denoting a subtype. */
5903 switch (Nkind (gnat_range
))
5906 *gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
5907 *gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
5910 case N_Expanded_Name
:
5913 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
5914 tree gnu_range_base_type
= get_base_type (gnu_range_type
);
5917 = convert (gnu_range_base_type
, TYPE_MIN_VALUE (gnu_range_type
));
5919 = convert (gnu_range_base_type
, TYPE_MAX_VALUE (gnu_range_type
));
5928 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
5929 to a GCC tree and return it. GNU_RESULT_TYPE_P is a pointer to where
5930 we should place the result type. */
5933 Raise_Error_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
5935 const Node_Kind kind
= Nkind (gnat_node
);
5936 const Node_Id gnat_cond
= Condition (gnat_node
);
5937 const int reason
= UI_To_Int (Reason (gnat_node
));
5938 const bool with_extra_info
5939 = Exception_Extra_Info
5940 && !No_Exception_Handlers_Set ()
5941 && No (get_exception_label (kind
));
5942 tree gnu_result
= NULL_TREE
, gnu_cond
= NULL_TREE
;
5945 /* The following processing is not required for correctness. Its purpose is
5946 to give more precise error messages and to record some information. */
5949 case CE_Access_Check_Failed
:
5950 if (with_extra_info
)
5951 gnu_result
= build_call_raise_column (reason
, gnat_node
, kind
);
5954 case CE_Index_Check_Failed
:
5955 case CE_Range_Check_Failed
:
5956 case CE_Invalid_Data
:
5957 if (No (gnat_cond
) || Nkind (gnat_cond
) != N_Op_Not
)
5959 gnat_rcond
= Right_Opnd (gnat_cond
);
5960 if (Nkind (gnat_rcond
) == N_In
5961 || Nkind (gnat_rcond
) == N_Op_Ge
5962 || Nkind (gnat_rcond
) == N_Op_Le
)
5964 const Node_Id gnat_index
= Left_Opnd (gnat_rcond
);
5965 const Node_Id gnat_type
= Etype (gnat_index
);
5966 tree gnu_index
= gnat_to_gnu (gnat_index
);
5967 tree gnu_type
= get_unpadded_type (gnat_type
);
5968 tree gnu_low_bound
, gnu_high_bound
, disp
;
5969 struct loop_info_d
*loop
;
5972 switch (Nkind (gnat_rcond
))
5975 Range_to_gnu (Right_Opnd (gnat_rcond
),
5976 &gnu_low_bound
, &gnu_high_bound
);
5980 gnu_low_bound
= gnat_to_gnu (Right_Opnd (gnat_rcond
));
5981 gnu_high_bound
= TYPE_MAX_VALUE (gnu_type
);
5985 gnu_low_bound
= TYPE_MIN_VALUE (gnu_type
);
5986 gnu_high_bound
= gnat_to_gnu (Right_Opnd (gnat_rcond
));
5993 gnu_type
= maybe_character_type (gnu_type
);
5994 if (TREE_TYPE (gnu_index
) != gnu_type
)
5996 gnu_low_bound
= convert (gnu_type
, gnu_low_bound
);
5997 gnu_high_bound
= convert (gnu_type
, gnu_high_bound
);
5998 gnu_index
= convert (gnu_type
, gnu_index
);
6002 && Known_Esize (gnat_type
)
6003 && UI_To_Int (Esize (gnat_type
)) <= 32)
6005 = build_call_raise_range (reason
, gnat_node
, kind
, gnu_index
,
6006 gnu_low_bound
, gnu_high_bound
);
6008 /* If optimization is enabled and we are inside a loop, we try to
6009 compute invariant conditions for checks applied to the iteration
6010 variable, i.e. conditions that are independent of the variable
6011 and necessary in order for the checks to fail in the course of
6012 some iteration. If we succeed, we consider an alternative:
6014 1. If loop unswitching is enabled, we prepend these conditions
6015 to the original conditions of the checks. This will make it
6016 possible for the loop unswitching pass to replace the loop
6017 with two loops, one of which has the checks eliminated and
6018 the other has the original checks reinstated, and a prologue
6019 implementing a run-time selection. The former loop will be
6020 for example suitable for vectorization.
6022 2. Otherwise, we instead append the conditions to the original
6023 conditions of the checks. At worse, if the conditions cannot
6024 be evaluated at compile time, they will be evaluated as true
6025 at run time only when the checks have already failed, thus
6026 contributing negatively only to the size of the executable.
6027 But the hope is that these invariant conditions be evaluated
6028 at compile time to false, thus taking away the entire checks
6033 || (gnu_low_bound
= gnat_invariant_expr (gnu_low_bound
)))
6035 || (gnu_high_bound
= gnat_invariant_expr (gnu_high_bound
)))
6036 && (loop
= find_loop_for (gnu_index
, &disp
, &neg_p
)))
6038 struct range_check_info_d
*rci
= ggc_alloc
<range_check_info_d
> ();
6039 rci
->low_bound
= gnu_low_bound
;
6040 rci
->high_bound
= gnu_high_bound
;
6043 rci
->type
= gnu_type
;
6045 = build1 (SAVE_EXPR
, boolean_type_node
, boolean_true_node
);
6046 vec_safe_push (loop
->checks
, rci
);
6047 gnu_cond
= build_noreturn_cond (gnat_to_gnu (gnat_cond
));
6049 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6054 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6057 rci
->inserted_cond
);
6066 /* The following processing does the real work, but we must nevertheless make
6067 sure not to override the result of the previous processing. */
6069 gnu_result
= build_call_raise (reason
, gnat_node
, kind
);
6070 set_expr_location_from_node (gnu_result
, gnat_node
);
6072 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
6074 /* If the type is VOID, this is a statement, so we need to generate the code
6075 for the call. Handle a condition, if there is one. */
6076 if (VOID_TYPE_P (*gnu_result_type_p
))
6078 if (Present (gnat_cond
))
6081 gnu_cond
= gnat_to_gnu (gnat_cond
);
6082 gnu_result
= build3 (COND_EXPR
, void_type_node
, gnu_cond
, gnu_result
,
6083 alloc_stmt_list ());
6087 gnu_result
= build1 (NULL_EXPR
, *gnu_result_type_p
, gnu_result
);
6092 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
6093 parameter of a call. */
6096 lhs_or_actual_p (Node_Id gnat_node
)
6098 const Node_Id gnat_parent
= Parent (gnat_node
);
6099 const Node_Kind kind
= Nkind (gnat_parent
);
6101 if (kind
== N_Assignment_Statement
&& Name (gnat_parent
) == gnat_node
)
6104 if ((kind
== N_Procedure_Call_Statement
|| kind
== N_Function_Call
)
6105 && Name (gnat_parent
) != gnat_node
)
6108 if (kind
== N_Parameter_Association
)
6114 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
6115 of an assignment or an actual parameter of a call. */
6118 present_in_lhs_or_actual_p (Node_Id gnat_node
)
6120 if (lhs_or_actual_p (gnat_node
))
6123 const Node_Kind kind
= Nkind (Parent (gnat_node
));
6125 if ((kind
== N_Type_Conversion
|| kind
== N_Unchecked_Type_Conversion
)
6126 && lhs_or_actual_p (Parent (gnat_node
)))
6132 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
6133 as gigi is concerned. This is used to avoid conversions on the LHS. */
6136 unchecked_conversion_nop (Node_Id gnat_node
)
6138 Entity_Id from_type
, to_type
;
6140 /* The conversion must be on the LHS of an assignment or an actual parameter
6141 of a call. Otherwise, even if the conversion was essentially a no-op, it
6142 could de facto ensure type consistency and this should be preserved. */
6143 if (!lhs_or_actual_p (gnat_node
))
6146 from_type
= Etype (Expression (gnat_node
));
6148 /* We're interested in artificial conversions generated by the front-end
6149 to make private types explicit, e.g. in Expand_Assign_Array. */
6150 if (!Is_Private_Type (from_type
))
6153 from_type
= Underlying_Type (from_type
);
6154 to_type
= Etype (gnat_node
);
6156 /* The direct conversion to the underlying type is a no-op. */
6157 if (to_type
== from_type
)
6160 /* For an array subtype, the conversion to the PAIT is a no-op. */
6161 if (Ekind (from_type
) == E_Array_Subtype
6162 && to_type
== Packed_Array_Impl_Type (from_type
))
6165 /* For a record subtype, the conversion to the type is a no-op. */
6166 if (Ekind (from_type
) == E_Record_Subtype
6167 && to_type
== Etype (from_type
))
6173 /* Return true if GNAT_NODE represents a statement. */
6176 statement_node_p (Node_Id gnat_node
)
6178 const Node_Kind kind
= Nkind (gnat_node
);
6180 if (kind
== N_Label
)
6183 if (IN (kind
, N_Statement_Other_Than_Procedure_Call
))
6186 if (kind
== N_Procedure_Call_Statement
)
6189 if (IN (kind
, N_Raise_xxx_Error
) && Ekind (Etype (gnat_node
)) == E_Void
)
6195 /* This function is the driver of the GNAT to GCC tree transformation process.
6196 It is the entry point of the tree transformer. GNAT_NODE is the root of
6197 some GNAT tree. Return the root of the corresponding GCC tree. If this
6198 is an expression, return the GCC equivalent of the expression. If this
6199 is a statement, return the statement or add it to the current statement
6200 group, in which case anything returned is to be interpreted as occurring
6201 after anything added. */
6204 gnat_to_gnu (Node_Id gnat_node
)
6206 const Node_Kind kind
= Nkind (gnat_node
);
6207 bool went_into_elab_proc
= false;
6208 tree gnu_result
= error_mark_node
; /* Default to no value. */
6209 tree gnu_result_type
= void_type_node
;
6210 tree gnu_expr
, gnu_lhs
, gnu_rhs
;
6212 atomic_acces_t aa_type
;
6215 /* Save node number for error message and set location information. */
6216 Current_Error_Node
= gnat_node
;
6217 Sloc_to_locus (Sloc (gnat_node
), &input_location
);
6219 /* If we are only annotating types and this node is a statement, return
6220 an empty statement list. */
6221 if (type_annotate_only
&& statement_node_p (gnat_node
))
6222 return alloc_stmt_list ();
6224 /* If we are only annotating types and this node is a subexpression, return
6225 a NULL_EXPR, but filter out nodes appearing in the expressions attached
6226 to packed array implementation types. */
6227 if (type_annotate_only
6228 && IN (kind
, N_Subexpr
)
6229 && !(((IN (kind
, N_Op
) && kind
!= N_Op_Expon
)
6230 || kind
== N_Type_Conversion
)
6231 && Is_Integer_Type (Etype (gnat_node
)))
6232 && !(kind
== N_Attribute_Reference
6233 && (Get_Attribute_Id (Attribute_Name (gnat_node
)) == Attr_Length
6234 || Get_Attribute_Id (Attribute_Name (gnat_node
)) == Attr_Size
)
6235 && Is_Constrained (Etype (Prefix (gnat_node
)))
6236 && !Is_Constr_Subt_For_U_Nominal (Etype (Prefix (gnat_node
))))
6237 && kind
!= N_Expanded_Name
6238 && kind
!= N_Identifier
6239 && !Compile_Time_Known_Value (gnat_node
))
6240 return build1 (NULL_EXPR
, get_unpadded_type (Etype (gnat_node
)),
6241 build_call_raise (CE_Range_Check_Failed
, gnat_node
,
6242 N_Raise_Constraint_Error
));
6244 if ((statement_node_p (gnat_node
) && kind
!= N_Null_Statement
)
6245 || kind
== N_Handled_Sequence_Of_Statements
6246 || kind
== N_Implicit_Label_Declaration
)
6248 tree current_elab_proc
= get_elaboration_procedure ();
6250 /* If this is a statement and we are at top level, it must be part of
6251 the elaboration procedure, so mark us as being in that procedure. */
6252 if (!current_function_decl
)
6254 current_function_decl
= current_elab_proc
;
6255 went_into_elab_proc
= true;
6258 /* If we are in the elaboration procedure, check if we are violating a
6259 No_Elaboration_Code restriction by having a statement there. Don't
6260 check for a possible No_Elaboration_Code restriction violation on
6261 N_Handled_Sequence_Of_Statements, as we want to signal an error on
6262 every nested real statement instead. This also avoids triggering
6263 spurious errors on dummy (empty) sequences created by the front-end
6264 for package bodies in some cases. */
6265 if (current_function_decl
== current_elab_proc
6266 && kind
!= N_Handled_Sequence_Of_Statements
6267 && kind
!= N_Implicit_Label_Declaration
)
6268 Check_Elaboration_Code_Allowed (gnat_node
);
6273 /********************************/
6274 /* Chapter 2: Lexical Elements */
6275 /********************************/
6278 case N_Expanded_Name
:
6279 case N_Operator_Symbol
:
6280 case N_Defining_Identifier
:
6281 case N_Defining_Operator_Symbol
:
6282 gnu_result
= Identifier_to_gnu (gnat_node
, &gnu_result_type
);
6284 /* If atomic access is required on the RHS, build the atomic load. */
6285 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6286 && !present_in_lhs_or_actual_p (gnat_node
))
6287 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6290 case N_Integer_Literal
:
6294 /* Get the type of the result, looking inside any padding and
6295 justified modular types. Then get the value in that type. */
6296 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6298 if (TREE_CODE (gnu_type
) == RECORD_TYPE
6299 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
6300 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
6302 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
6304 /* If the result overflows (meaning it doesn't fit in its base type),
6305 abort, unless this is for a named number because that's not fatal.
6306 We would like to check that the value is within the range of the
6307 subtype, but that causes problems with subtypes whose usage will
6308 raise Constraint_Error and also with biased representation. */
6309 if (TREE_OVERFLOW (gnu_result
))
6311 if (Nkind (Parent (gnat_node
)) == N_Number_Declaration
)
6312 gnu_result
= error_mark_node
;
6319 case N_Character_Literal
:
6320 /* If a Entity is present, it means that this was one of the
6321 literals in a user-defined character type. In that case,
6322 just return the value in the CONST_DECL. Otherwise, use the
6323 character code. In that case, the base type should be an
6324 INTEGER_TYPE, but we won't bother checking for that. */
6325 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6326 if (Present (Entity (gnat_node
)))
6327 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
6330 = build_int_cst (gnu_result_type
,
6331 UI_To_CC (Char_Literal_Value (gnat_node
)));
6334 case N_Real_Literal
:
6335 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6337 /* If this is of a fixed-point type, the value we want is the value of
6338 the corresponding integer. */
6339 if (Is_Fixed_Point_Type (Underlying_Type (Etype (gnat_node
))))
6341 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
6343 gcc_assert (!TREE_OVERFLOW (gnu_result
));
6348 Ureal ur_realval
= Realval (gnat_node
);
6350 /* First convert the value to a machine number if it isn't already.
6351 That will force the base to 2 for non-zero values and simplify
6352 the rest of the logic. */
6353 if (!Is_Machine_Number (gnat_node
))
6355 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
6356 ur_realval
, Round_Even
, gnat_node
);
6358 if (UR_Is_Zero (ur_realval
))
6359 gnu_result
= build_real (gnu_result_type
, dconst0
);
6362 REAL_VALUE_TYPE tmp
;
6364 gnu_result
= UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
6366 /* The base must be 2 as Machine guarantees this, so we scale
6367 the value, which we know can fit in the mantissa of the type
6368 (hence the use of that type above). */
6369 gcc_assert (Rbase (ur_realval
) == 2);
6370 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
6371 - UI_To_Int (Denominator (ur_realval
)));
6372 gnu_result
= build_real (gnu_result_type
, tmp
);
6375 /* Now see if we need to negate the result. Do it this way to
6376 properly handle -0. */
6377 if (UR_Is_Negative (Realval (gnat_node
)))
6379 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
6385 case N_String_Literal
:
6386 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6387 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
6389 String_Id gnat_string
= Strval (gnat_node
);
6390 int length
= String_Length (gnat_string
);
6393 if (length
>= ALLOCA_THRESHOLD
)
6394 string
= XNEWVEC (char, length
);
6396 string
= (char *) alloca (length
);
6398 /* Build the string with the characters in the literal. Note
6399 that Ada strings are 1-origin. */
6400 for (i
= 0; i
< length
; i
++)
6401 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
6403 gnu_result
= build_string (length
, string
);
6405 /* Strings in GCC don't normally have types, but we want
6406 this to not be converted to the array type. */
6407 TREE_TYPE (gnu_result
) = gnu_result_type
;
6409 if (length
>= ALLOCA_THRESHOLD
)
6414 /* Build a list consisting of each character, then make
6416 String_Id gnat_string
= Strval (gnat_node
);
6417 int length
= String_Length (gnat_string
);
6419 tree gnu_idx
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
6420 tree gnu_one_node
= convert (TREE_TYPE (gnu_idx
), integer_one_node
);
6421 vec
<constructor_elt
, va_gc
> *gnu_vec
;
6422 vec_alloc (gnu_vec
, length
);
6424 for (i
= 0; i
< length
; i
++)
6426 tree t
= build_int_cst (TREE_TYPE (gnu_result_type
),
6427 Get_String_Char (gnat_string
, i
+ 1));
6429 CONSTRUCTOR_APPEND_ELT (gnu_vec
, gnu_idx
, t
);
6430 gnu_idx
= int_const_binop (PLUS_EXPR
, gnu_idx
, gnu_one_node
);
6433 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
6438 gnu_result
= Pragma_to_gnu (gnat_node
);
6441 /**************************************/
6442 /* Chapter 3: Declarations and Types */
6443 /**************************************/
6445 case N_Subtype_Declaration
:
6446 case N_Full_Type_Declaration
:
6447 case N_Incomplete_Type_Declaration
:
6448 case N_Private_Type_Declaration
:
6449 case N_Private_Extension_Declaration
:
6450 case N_Task_Type_Declaration
:
6451 process_type (Defining_Entity (gnat_node
));
6452 gnu_result
= alloc_stmt_list ();
6455 case N_Object_Declaration
:
6456 case N_Number_Declaration
:
6457 case N_Exception_Declaration
:
6458 gnat_temp
= Defining_Entity (gnat_node
);
6459 gnu_result
= alloc_stmt_list ();
6461 /* If we are just annotating types and this object has an unconstrained
6462 or task type, don't elaborate it. */
6463 if (type_annotate_only
6464 && (((Is_Array_Type (Etype (gnat_temp
))
6465 || Is_Record_Type (Etype (gnat_temp
)))
6466 && !Is_Constrained (Etype (gnat_temp
)))
6467 || Is_Concurrent_Type (Etype (gnat_temp
))))
6470 if (Present (Expression (gnat_node
))
6471 && !(kind
== N_Object_Declaration
&& No_Initialization (gnat_node
))
6472 && (!type_annotate_only
6473 || Compile_Time_Known_Value (Expression (gnat_node
))))
6475 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node
)));
6477 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
6479 if (TREE_CODE (gnu_expr
) == ERROR_MARK
)
6481 /* If this is a named number for which we cannot manipulate
6482 the value, just skip the declaration altogether. */
6483 if (kind
== N_Number_Declaration
)
6485 else if (type_annotate_only
)
6486 gnu_expr
= NULL_TREE
;
6490 gnu_expr
= NULL_TREE
;
6492 /* If this is a deferred constant with an address clause, we ignore the
6493 full view since the clause is on the partial view and we cannot have
6494 2 different GCC trees for the object. The only bits of the full view
6495 we will use is the initializer, but it will be directly fetched. */
6496 if (Ekind (gnat_temp
) == E_Constant
6497 && Present (Address_Clause (gnat_temp
))
6498 && Present (Full_View (gnat_temp
)))
6499 save_gnu_tree (Full_View (gnat_temp
), error_mark_node
, true);
6501 /* If this object has its elaboration delayed, we must force evaluation
6502 of GNU_EXPR now and save it for the freeze point. Note that we need
6503 not do anything special at the global level since the lifetime of the
6504 temporary is fully contained within the elaboration routine. */
6505 if (Present (Freeze_Node (gnat_temp
)))
6509 gnu_result
= gnat_save_expr (gnu_expr
);
6510 save_gnu_tree (gnat_node
, gnu_result
, true);
6514 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, true);
6517 case N_Object_Renaming_Declaration
:
6518 gnat_temp
= Defining_Entity (gnat_node
);
6519 gnu_result
= alloc_stmt_list ();
6521 /* Don't do anything if this renaming is handled by the front end and it
6522 does not need debug info. Note that we consider renamings don't need
6523 debug info when optimizing: our way to describe them has a
6524 memory/elaboration footprint.
6526 Don't do anything neither if we are just annotating types and this
6527 object has a composite or task type, don't elaborate it. */
6528 if ((!Is_Renaming_Of_Object (gnat_temp
)
6529 || (Needs_Debug_Info (gnat_temp
)
6531 && can_materialize_object_renaming_p
6532 (Renamed_Object (gnat_temp
))))
6533 && ! (type_annotate_only
6534 && (Is_Array_Type (Etype (gnat_temp
))
6535 || Is_Record_Type (Etype (gnat_temp
))
6536 || Is_Concurrent_Type (Etype (gnat_temp
)))))
6537 gnat_to_gnu_entity (gnat_temp
,
6538 gnat_to_gnu (Renamed_Object (gnat_temp
)),
6542 case N_Exception_Renaming_Declaration
:
6543 gnat_temp
= Defining_Entity (gnat_node
);
6544 gnu_result
= alloc_stmt_list ();
6546 if (Present (Renamed_Entity (gnat_temp
)))
6547 gnat_to_gnu_entity (gnat_temp
,
6548 gnat_to_gnu (Renamed_Entity (gnat_temp
)),
6552 case N_Subprogram_Renaming_Declaration
:
6554 const Node_Id gnat_renaming
= Defining_Entity (gnat_node
);
6555 const Node_Id gnat_renamed
= Renamed_Entity (gnat_renaming
);
6557 gnu_result
= alloc_stmt_list ();
6559 /* Materializing renamed subprograms will only benefit the debugging
6560 information as they aren't referenced in the generated code. So
6561 skip them when they aren't needed. Avoid doing this if:
6563 - there is a freeze node: in this case the renamed entity is not
6565 - the renamed subprogram is intrinsic: it will not be available in
6566 the debugging information (note that both or only one of the
6567 renaming and the renamed subprograms can be intrinsic). */
6568 if (!type_annotate_only
6569 && Needs_Debug_Info (gnat_renaming
)
6570 && No (Freeze_Node (gnat_renaming
))
6571 && Present (gnat_renamed
)
6572 && (Ekind (gnat_renamed
) == E_Function
6573 || Ekind (gnat_renamed
) == E_Procedure
)
6574 && !Is_Intrinsic_Subprogram (gnat_renaming
)
6575 && !Is_Intrinsic_Subprogram (gnat_renamed
))
6576 gnat_to_gnu_entity (gnat_renaming
, gnat_to_gnu (gnat_renamed
), true);
6580 case N_Implicit_Label_Declaration
:
6581 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, true);
6582 gnu_result
= alloc_stmt_list ();
6585 case N_Package_Renaming_Declaration
:
6586 /* These are fully handled in the front end. */
6587 /* ??? For package renamings, find a way to use GENERIC namespaces so
6588 that we get proper debug information for them. */
6589 gnu_result
= alloc_stmt_list ();
6592 /*************************************/
6593 /* Chapter 4: Names and Expressions */
6594 /*************************************/
6596 case N_Explicit_Dereference
:
6597 /* Make sure the designated type is complete before dereferencing. */
6598 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6599 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
6600 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
6602 /* If atomic access is required on the RHS, build the atomic load. */
6603 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6604 && !present_in_lhs_or_actual_p (gnat_node
))
6605 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6608 case N_Indexed_Component
:
6610 tree gnu_array_object
= gnat_to_gnu ((Prefix (gnat_node
)));
6613 Node_Id
*gnat_expr_array
;
6615 gnu_array_object
= maybe_padded_object (gnu_array_object
);
6616 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
6618 /* Convert vector inputs to their representative array type, to fit
6619 what the code below expects. */
6620 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object
)))
6622 if (present_in_lhs_or_actual_p (gnat_node
))
6623 gnat_mark_addressable (gnu_array_object
);
6624 gnu_array_object
= maybe_vector_array (gnu_array_object
);
6627 /* The failure of this assertion will very likely come from a missing
6628 expansion for a packed array access. */
6629 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object
)) == ARRAY_TYPE
);
6631 /* First compute the number of dimensions of the array, then
6632 fill the expression array, the order depending on whether
6633 this is a Convention_Fortran array or not. */
6634 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
6635 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
6636 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
6637 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
6640 gnat_expr_array
= XALLOCAVEC (Node_Id
, ndim
);
6642 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
6643 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
6645 i
--, gnat_temp
= Next (gnat_temp
))
6646 gnat_expr_array
[i
] = gnat_temp
;
6648 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
6650 i
++, gnat_temp
= Next (gnat_temp
))
6651 gnat_expr_array
[i
] = gnat_temp
;
6653 /* Start with the prefix and build the successive references. */
6654 gnu_result
= gnu_array_object
;
6656 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
6658 i
++, gnu_type
= TREE_TYPE (gnu_type
))
6660 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
6661 gnat_temp
= gnat_expr_array
[i
];
6662 gnu_expr
= maybe_character_value (gnat_to_gnu (gnat_temp
));
6665 = build_binary_op (ARRAY_REF
, NULL_TREE
, gnu_result
, gnu_expr
);
6668 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6670 /* If atomic access is required on the RHS, build the atomic load. */
6671 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6672 && !present_in_lhs_or_actual_p (gnat_node
))
6673 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6679 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
6681 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6683 gnu_array_object
= maybe_padded_object (gnu_array_object
);
6684 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
6686 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
6687 gnu_expr
= maybe_character_value (gnu_expr
);
6689 /* If this is a slice with non-constant size of an array with constant
6690 size, set the maximum size for the allocation of temporaries. */
6691 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type
))
6692 && TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object
))))
6693 TYPE_ARRAY_MAX_SIZE (gnu_result_type
)
6694 = TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object
));
6696 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
6697 gnu_array_object
, gnu_expr
);
6701 case N_Selected_Component
:
6703 const Entity_Id gnat_prefix
= Prefix (gnat_node
);
6704 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
6705 tree gnu_prefix
= gnat_to_gnu (gnat_prefix
);
6707 gnu_prefix
= maybe_padded_object (gnu_prefix
);
6709 /* gnat_to_gnu_entity does not save the GNU tree made for renamed
6710 discriminants so avoid making recursive calls on each reference
6711 to them by following the appropriate link directly here. */
6712 if (Ekind (gnat_field
) == E_Discriminant
)
6714 /* For discriminant references in tagged types always substitute
6715 the corresponding discriminant as the actual component. */
6716 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix
))))
6717 while (Present (Corresponding_Discriminant (gnat_field
)))
6718 gnat_field
= Corresponding_Discriminant (gnat_field
);
6720 /* For discriminant references in untagged types always substitute
6721 the corresponding stored discriminant. */
6722 else if (Present (Corresponding_Discriminant (gnat_field
)))
6723 gnat_field
= Original_Record_Component (gnat_field
);
6726 /* Handle extracting the real or imaginary part of a complex.
6727 The real part is the first field and the imaginary the last. */
6728 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
6729 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
6730 ? REALPART_EXPR
: IMAGPART_EXPR
,
6731 NULL_TREE
, gnu_prefix
);
6734 tree gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
6737 = build_component_ref (gnu_prefix
, gnu_field
,
6738 (Nkind (Parent (gnat_node
))
6739 == N_Attribute_Reference
)
6740 && lvalue_required_for_attribute_p
6741 (Parent (gnat_node
)));
6744 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6746 /* If atomic access is required on the RHS, build the atomic load. */
6747 if (simple_atomic_access_required_p (gnat_node
, &aa_sync
)
6748 && !present_in_lhs_or_actual_p (gnat_node
))
6749 gnu_result
= build_atomic_load (gnu_result
, aa_sync
);
6753 case N_Attribute_Reference
:
6755 /* The attribute designator. */
6756 const int attr
= Get_Attribute_Id (Attribute_Name (gnat_node
));
6758 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
6759 is a unit, not an object with a GCC equivalent. */
6760 if (attr
== Attr_Elab_Spec
|| attr
== Attr_Elab_Body
)
6762 create_subprog_decl (create_concat_name
6763 (Entity (Prefix (gnat_node
)),
6764 attr
== Attr_Elab_Body
? "elabb" : "elabs"),
6765 NULL_TREE
, void_ftype
, NULL_TREE
, is_default
,
6766 true, true, true, true, false, NULL
,
6769 gnu_result
= Attribute_to_gnu (gnat_node
, &gnu_result_type
, attr
);
6774 /* Like 'Access as far as we are concerned. */
6775 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
6776 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
6777 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6781 case N_Extension_Aggregate
:
6785 /* Check that this aggregate has not slipped through the cracks. */
6786 gcc_assert (!Expansion_Delayed (gnat_node
));
6788 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6790 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
6791 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
6793 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type
)));
6794 else if (TREE_CODE (gnu_result_type
) == VECTOR_TYPE
)
6795 gnu_aggr_type
= TYPE_REPRESENTATIVE_ARRAY (gnu_result_type
);
6797 gnu_aggr_type
= gnu_result_type
;
6799 if (Null_Record_Present (gnat_node
))
6800 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL
);
6802 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
6803 || TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
6805 = assoc_to_constructor (Etype (gnat_node
),
6806 First (Component_Associations (gnat_node
)),
6808 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
6809 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
6811 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
6814 (COMPLEX_EXPR
, gnu_aggr_type
,
6815 gnat_to_gnu (Expression (First
6816 (Component_Associations (gnat_node
)))),
6817 gnat_to_gnu (Expression
6819 (First (Component_Associations (gnat_node
))))));
6823 gnu_result
= convert (gnu_result_type
, gnu_result
);
6828 if (TARGET_VTABLE_USES_DESCRIPTORS
6829 && Ekind (Etype (gnat_node
)) == E_Access_Subprogram_Type
6830 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
6831 gnu_result
= null_fdesc_node
;
6833 gnu_result
= null_pointer_node
;
6834 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6837 case N_Type_Conversion
:
6838 case N_Qualified_Expression
:
6839 gnu_expr
= maybe_character_value (gnat_to_gnu (Expression (gnat_node
)));
6840 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6842 /* If this is a qualified expression for a tagged type, we mark the type
6843 as used. Because of polymorphism, this might be the only reference to
6844 the tagged type in the program while objects have it as dynamic type.
6845 The debugger needs to see it to display these objects properly. */
6846 if (kind
== N_Qualified_Expression
&& Is_Tagged_Type (Etype (gnat_node
)))
6847 used_types_insert (gnu_result_type
);
6849 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node
)));
6852 = convert_with_check (Etype (gnat_node
), gnu_expr
,
6853 Do_Overflow_Check (gnat_node
),
6854 kind
== N_Type_Conversion
6855 && Float_Truncate (gnat_node
), gnat_node
);
6858 case N_Unchecked_Type_Conversion
:
6859 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6860 gnu_expr
= maybe_character_value (gnat_to_gnu (Expression (gnat_node
)));
6862 /* Skip further processing if the conversion is deemed a no-op. */
6863 if (unchecked_conversion_nop (gnat_node
))
6865 gnu_result
= gnu_expr
;
6866 gnu_result_type
= TREE_TYPE (gnu_result
);
6870 /* If the result is a pointer type, see if we are improperly
6871 converting to a stricter alignment. */
6872 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
6873 && Is_Access_Type (Etype (gnat_node
)))
6875 unsigned int align
= known_alignment (gnu_expr
);
6876 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
6877 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
6879 if (align
!= 0 && align
< oalign
&& !TYPE_ALIGN_OK (gnu_obj_type
))
6880 post_error_ne_tree_2
6881 ("?source alignment (^) '< alignment of & (^)",
6882 gnat_node
, Designated_Type (Etype (gnat_node
)),
6883 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
6886 /* If we are converting a descriptor to a function pointer, first
6887 build the pointer. */
6888 if (TARGET_VTABLE_USES_DESCRIPTORS
6889 && TREE_TYPE (gnu_expr
) == fdesc_type_node
6890 && POINTER_TYPE_P (gnu_result_type
))
6891 gnu_expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
6893 gnu_result
= unchecked_convert (gnu_result_type
, gnu_expr
,
6894 No_Truncation (gnat_node
));
6900 tree gnu_obj
= gnat_to_gnu (Left_Opnd (gnat_node
));
6901 tree gnu_low
, gnu_high
;
6903 Range_to_gnu (Right_Opnd (gnat_node
), &gnu_low
, &gnu_high
);
6904 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6906 tree gnu_op_type
= maybe_character_type (TREE_TYPE (gnu_obj
));
6907 if (TREE_TYPE (gnu_obj
) != gnu_op_type
)
6909 gnu_obj
= convert (gnu_op_type
, gnu_obj
);
6910 gnu_low
= convert (gnu_op_type
, gnu_low
);
6911 gnu_high
= convert (gnu_op_type
, gnu_high
);
6914 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
6915 ensure that GNU_OBJ is evaluated only once and perform a full range
6917 if (operand_equal_p (gnu_low
, gnu_high
, 0))
6919 = build_binary_op (EQ_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
6923 gnu_obj
= gnat_protect_expr (gnu_obj
);
6924 t1
= build_binary_op (GE_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
6926 set_expr_location_from_node (t1
, gnat_node
);
6927 t2
= build_binary_op (LE_EXPR
, gnu_result_type
, gnu_obj
, gnu_high
);
6929 set_expr_location_from_node (t2
, gnat_node
);
6931 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
, t1
, t2
);
6934 if (kind
== N_Not_In
)
6936 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result
), gnu_result
);
6941 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
6942 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
6943 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6944 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
6946 : (Rounded_Result (gnat_node
)
6947 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
6948 gnu_result_type
, gnu_lhs
, gnu_rhs
);
6962 case N_Op_Rotate_Left
:
6963 case N_Op_Rotate_Right
:
6964 case N_Op_Shift_Left
:
6965 case N_Op_Shift_Right
:
6966 case N_Op_Shift_Right_Arithmetic
:
6973 enum tree_code code
= gnu_codes
[kind
];
6974 bool ignore_lhs_overflow
= false;
6975 location_t saved_location
= input_location
;
6976 tree gnu_type
, gnu_max_shift
= NULL_TREE
;
6978 /* Fix operations set up for boolean types in GNU_CODES above. */
6979 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node
))))
6983 code
= BIT_AND_EXPR
;
6986 code
= BIT_IOR_EXPR
;
6989 code
= BIT_XOR_EXPR
;
6995 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
6996 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
6997 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6999 /* If this is a shift, take the count as unsigned since that is what
7000 most machines do and will generate simpler adjustments below. */
7001 if (IN (kind
, N_Op_Shift
))
7004 = gnat_unsigned_type_for (get_base_type (TREE_TYPE (gnu_rhs
)));
7005 gnu_rhs
= convert (gnu_count_type
, gnu_rhs
);
7007 = convert (TREE_TYPE (gnu_rhs
), TYPE_SIZE (gnu_type
));
7010 /* Pending generic support for efficient vector logical operations in
7011 GCC, convert vectors to their representative array type view and
7013 gnu_lhs
= maybe_vector_array (gnu_lhs
);
7014 gnu_rhs
= maybe_vector_array (gnu_rhs
);
7016 /* If this is a comparison operator, convert any references to an
7017 unconstrained array value into a reference to the actual array. */
7018 if (TREE_CODE_CLASS (code
) == tcc_comparison
)
7020 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
7021 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
7023 tree gnu_op_type
= maybe_character_type (TREE_TYPE (gnu_lhs
));
7024 if (TREE_TYPE (gnu_lhs
) != gnu_op_type
)
7026 gnu_lhs
= convert (gnu_op_type
, gnu_lhs
);
7027 gnu_rhs
= convert (gnu_op_type
, gnu_rhs
);
7031 /* If this is a shift whose count is not guaranteed to be correct,
7032 we need to adjust the shift count. */
7033 if ((kind
== N_Op_Rotate_Left
|| kind
== N_Op_Rotate_Right
)
7034 && !Shift_Count_OK (gnat_node
))
7035 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, TREE_TYPE (gnu_rhs
),
7036 gnu_rhs
, gnu_max_shift
);
7037 else if (kind
== N_Op_Shift_Right_Arithmetic
7038 && !Shift_Count_OK (gnat_node
))
7040 = build_binary_op (MIN_EXPR
, TREE_TYPE (gnu_rhs
),
7041 build_binary_op (MINUS_EXPR
,
7042 TREE_TYPE (gnu_rhs
),
7045 (TREE_TYPE (gnu_rhs
), 1)),
7048 /* For right shifts, the type says what kind of shift to do,
7049 so we may need to choose a different type. In this case,
7050 we have to ignore integer overflow lest it propagates all
7051 the way down and causes a CE to be explicitly raised. */
7052 if (kind
== N_Op_Shift_Right
&& !TYPE_UNSIGNED (gnu_type
))
7054 gnu_type
= gnat_unsigned_type_for (gnu_type
);
7055 ignore_lhs_overflow
= true;
7057 else if (kind
== N_Op_Shift_Right_Arithmetic
7058 && TYPE_UNSIGNED (gnu_type
))
7060 gnu_type
= gnat_signed_type_for (gnu_type
);
7061 ignore_lhs_overflow
= true;
7064 if (gnu_type
!= gnu_result_type
)
7066 tree gnu_old_lhs
= gnu_lhs
;
7067 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
7068 if (TREE_CODE (gnu_lhs
) == INTEGER_CST
&& ignore_lhs_overflow
)
7069 TREE_OVERFLOW (gnu_lhs
) = TREE_OVERFLOW (gnu_old_lhs
);
7070 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
7073 /* For signed integer addition, subtraction and multiplication, do an
7074 overflow check if required. */
7075 if (Do_Overflow_Check (gnat_node
)
7076 && (code
== PLUS_EXPR
|| code
== MINUS_EXPR
|| code
== MULT_EXPR
)
7077 && !TYPE_UNSIGNED (gnu_type
)
7078 && !FLOAT_TYPE_P (gnu_type
))
7080 = build_binary_op_trapv (code
, gnu_type
, gnu_lhs
, gnu_rhs
,
7084 /* Some operations, e.g. comparisons of arrays, generate complex
7085 trees that need to be annotated while they are being built. */
7086 input_location
= saved_location
;
7087 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
7090 /* If this is a logical shift with the shift count not verified,
7091 we must return zero if it is too large. We cannot compensate
7092 beforehand in this case. */
7093 if ((kind
== N_Op_Shift_Left
|| kind
== N_Op_Shift_Right
)
7094 && !Shift_Count_OK (gnat_node
))
7096 = build_cond_expr (gnu_type
,
7097 build_binary_op (GE_EXPR
, boolean_type_node
,
7098 gnu_rhs
, gnu_max_shift
),
7099 build_int_cst (gnu_type
, 0),
7104 case N_If_Expression
:
7106 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
7107 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
7109 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
7111 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7113 = build_cond_expr (gnu_result_type
, gnu_cond
, gnu_true
, gnu_false
);
7118 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
7119 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7123 /* This case can apply to a boolean or a modular type.
7124 Fall through for a boolean operand since GNU_CODES is set
7125 up to handle this. */
7126 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node
))))
7128 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
7129 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7130 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
7135 /* ... fall through ... */
7139 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
7140 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7142 /* For signed integer negation and absolute value, do an overflow check
7144 if (Do_Overflow_Check (gnat_node
)
7145 && !TYPE_UNSIGNED (gnu_result_type
)
7146 && !FLOAT_TYPE_P (gnu_result_type
))
7148 = build_unary_op_trapv (gnu_codes
[kind
], gnu_result_type
, gnu_expr
,
7152 = build_unary_op (gnu_codes
[kind
], gnu_result_type
, gnu_expr
);
7157 tree gnu_type
, gnu_init
;
7158 bool ignore_init_type
;
7160 gnat_temp
= Expression (gnat_node
);
7162 /* The expression can be either an N_Identifier or an Expanded_Name,
7163 which must represent a type, or a N_Qualified_Expression, which
7164 contains both the type and an initial value for the object. */
7165 if (Nkind (gnat_temp
) == N_Identifier
7166 || Nkind (gnat_temp
) == N_Expanded_Name
)
7168 ignore_init_type
= false;
7169 gnu_init
= NULL_TREE
;
7170 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
7173 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
7175 const Entity_Id gnat_desig_type
7176 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
7178 /* The flag is effectively only set on the base types. */
7180 = Has_Constrained_Partial_View (Base_Type (gnat_desig_type
));
7182 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
7183 gnu_init
= maybe_unconstrained_array (gnu_init
);
7185 gigi_checking_assert (!Do_Range_Check (Expression (gnat_temp
)));
7187 if (Is_Elementary_Type (gnat_desig_type
)
7188 || Is_Constrained (gnat_desig_type
))
7189 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
7192 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
7193 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
7194 gnu_type
= TREE_TYPE (gnu_init
);
7197 /* See the N_Qualified_Expression case for the rationale. */
7198 if (Is_Tagged_Type (gnat_desig_type
))
7199 used_types_insert (gnu_type
);
7201 gnu_init
= convert (gnu_type
, gnu_init
);
7206 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
7207 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
7208 Procedure_To_Call (gnat_node
),
7209 Storage_Pool (gnat_node
), gnat_node
,
7214 /**************************/
7215 /* Chapter 5: Statements */
7216 /**************************/
7219 gnu_result
= build1 (LABEL_EXPR
, void_type_node
,
7220 gnat_to_gnu (Identifier (gnat_node
)));
7223 case N_Null_Statement
:
7224 /* When not optimizing, turn null statements from source into gotos to
7225 the next statement that the middle-end knows how to preserve. */
7226 if (!optimize
&& Comes_From_Source (gnat_node
))
7228 tree stmt
, label
= create_label_decl (NULL_TREE
, gnat_node
);
7229 DECL_IGNORED_P (label
) = 1;
7230 start_stmt_group ();
7231 stmt
= build1 (GOTO_EXPR
, void_type_node
, label
);
7232 set_expr_location_from_node (stmt
, gnat_node
);
7234 stmt
= build1 (LABEL_EXPR
, void_type_node
, label
);
7235 set_expr_location_from_node (stmt
, gnat_node
);
7237 gnu_result
= end_stmt_group ();
7240 gnu_result
= alloc_stmt_list ();
7243 case N_Assignment_Statement
:
7244 /* Get the LHS and RHS of the statement and convert any reference to an
7245 unconstrained array into a reference to the underlying array. */
7246 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
7248 /* If the type has a size that overflows, convert this into raise of
7249 Storage_Error: execution shouldn't have gotten here anyway. */
7250 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
7251 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))))
7252 gnu_result
= build_call_raise (SE_Object_Too_Large
, gnat_node
,
7253 N_Raise_Storage_Error
);
7254 else if (Nkind (Expression (gnat_node
)) == N_Function_Call
)
7256 get_atomic_access (Name (gnat_node
), &aa_type
, &aa_sync
);
7258 = Call_to_gnu (Expression (gnat_node
), &gnu_result_type
, gnu_lhs
,
7263 const Node_Id gnat_expr
= Expression (gnat_node
);
7264 const Node_Id gnat_inner
7265 = Nkind (gnat_expr
) == N_Qualified_Expression
7266 ? Expression (gnat_expr
)
7268 const Entity_Id gnat_type
7269 = Underlying_Type (Etype (Name (gnat_node
)));
7270 const bool use_memset_p
7271 = Is_Array_Type (gnat_type
)
7272 && Nkind (gnat_inner
) == N_Aggregate
7273 && Is_Single_Aggregate (gnat_inner
);
7275 /* If we use memset, we need to find the innermost expression. */
7278 gnat_temp
= gnat_inner
;
7281 = Expression (First (Component_Associations (gnat_temp
)));
7282 } while (Nkind (gnat_temp
) == N_Aggregate
7283 && Is_Single_Aggregate (gnat_temp
));
7284 gnu_rhs
= gnat_to_gnu (gnat_temp
);
7287 gnu_rhs
= maybe_unconstrained_array (gnat_to_gnu (gnat_expr
));
7289 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
7291 get_atomic_access (Name (gnat_node
), &aa_type
, &aa_sync
);
7293 /* If an outer atomic access is required on the LHS, build the load-
7294 modify-store sequence. */
7295 if (aa_type
== OUTER_ATOMIC
)
7296 gnu_result
= build_load_modify_store (gnu_lhs
, gnu_rhs
, gnat_node
);
7298 /* Or else, if a simple atomic access is required, build the atomic
7300 else if (aa_type
== SIMPLE_ATOMIC
)
7301 gnu_result
= build_atomic_store (gnu_lhs
, gnu_rhs
, aa_sync
);
7303 /* Or else, use memset when the conditions are met. This has already
7304 been validated by Aggr_Assignment_OK_For_Backend in the front-end
7305 and the RHS is thus guaranteed to be of the appropriate form. */
7306 else if (use_memset_p
)
7309 = real_zerop (gnu_rhs
)
7311 : fold_convert (integer_type_node
, gnu_rhs
);
7312 tree dest
= build_fold_addr_expr (gnu_lhs
);
7313 tree t
= builtin_decl_explicit (BUILT_IN_MEMSET
);
7314 /* Be extra careful not to write too much data. */
7316 if (TREE_CODE (gnu_lhs
) == COMPONENT_REF
)
7317 size
= DECL_SIZE_UNIT (TREE_OPERAND (gnu_lhs
, 1));
7318 else if (DECL_P (gnu_lhs
))
7319 size
= DECL_SIZE_UNIT (gnu_lhs
);
7321 size
= TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
));
7322 size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_lhs
);
7323 if (TREE_CODE (value
) == INTEGER_CST
&& !integer_zerop (value
))
7326 = build_int_cst (integer_type_node
,
7327 ((HOST_WIDE_INT
) 1 << BITS_PER_UNIT
) - 1);
7328 value
= int_const_binop (BIT_AND_EXPR
, value
, mask
);
7330 gnu_result
= build_call_expr (t
, 3, dest
, value
, size
);
7333 /* Otherwise build a regular assignment. */
7336 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
7338 /* If the assignment type is a regular array and the two sides are
7339 not completely disjoint, play safe and use memmove. But don't do
7340 it for a bit-packed array as it might not be byte-aligned. */
7341 if (TREE_CODE (gnu_result
) == MODIFY_EXPR
7342 && Is_Array_Type (gnat_type
)
7343 && !Is_Bit_Packed_Array (gnat_type
)
7344 && !(Forwards_OK (gnat_node
) && Backwards_OK (gnat_node
)))
7346 tree to
= TREE_OPERAND (gnu_result
, 0);
7347 tree from
= TREE_OPERAND (gnu_result
, 1);
7348 tree type
= TREE_TYPE (from
);
7350 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type
), from
);
7351 tree to_ptr
= build_fold_addr_expr (to
);
7352 tree from_ptr
= build_fold_addr_expr (from
);
7353 tree t
= builtin_decl_explicit (BUILT_IN_MEMMOVE
);
7354 gnu_result
= build_call_expr (t
, 3, to_ptr
, from_ptr
, size
);
7359 case N_If_Statement
:
7361 tree
*gnu_else_ptr
; /* Point to put next "else if" or "else". */
7363 /* Make the outer COND_EXPR. Avoid non-determinism. */
7364 gnu_result
= build3 (COND_EXPR
, void_type_node
,
7365 gnat_to_gnu (Condition (gnat_node
)),
7366 NULL_TREE
, NULL_TREE
);
7367 COND_EXPR_THEN (gnu_result
)
7368 = build_stmt_group (Then_Statements (gnat_node
), false);
7369 TREE_SIDE_EFFECTS (gnu_result
) = 1;
7370 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_result
);
7372 /* Now make a COND_EXPR for each of the "else if" parts. Put each
7373 into the previous "else" part and point to where to put any
7374 outer "else". Also avoid non-determinism. */
7375 if (Present (Elsif_Parts (gnat_node
)))
7376 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
7377 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
7379 gnu_expr
= build3 (COND_EXPR
, void_type_node
,
7380 gnat_to_gnu (Condition (gnat_temp
)),
7381 NULL_TREE
, NULL_TREE
);
7382 COND_EXPR_THEN (gnu_expr
)
7383 = build_stmt_group (Then_Statements (gnat_temp
), false);
7384 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
7385 set_expr_location_from_node (gnu_expr
, gnat_temp
);
7386 *gnu_else_ptr
= gnu_expr
;
7387 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
7390 *gnu_else_ptr
= build_stmt_group (Else_Statements (gnat_node
), false);
7394 case N_Case_Statement
:
7395 gnu_result
= Case_Statement_to_gnu (gnat_node
);
7398 case N_Loop_Statement
:
7399 gnu_result
= Loop_Statement_to_gnu (gnat_node
);
7402 case N_Block_Statement
:
7403 /* The only way to enter the block is to fall through to it. */
7404 if (stmt_group_may_fallthru ())
7406 start_stmt_group ();
7408 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7409 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
7411 gnu_result
= end_stmt_group ();
7414 gnu_result
= alloc_stmt_list ();
7417 case N_Exit_Statement
:
7419 = build2 (EXIT_STMT
, void_type_node
,
7420 (Present (Condition (gnat_node
))
7421 ? gnat_to_gnu (Condition (gnat_node
)) : NULL_TREE
),
7422 (Present (Name (gnat_node
))
7423 ? get_gnu_tree (Entity (Name (gnat_node
)))
7424 : LOOP_STMT_LABEL (gnu_loop_stack
->last ()->stmt
)));
7427 case N_Simple_Return_Statement
:
7429 tree gnu_ret_obj
, gnu_ret_val
;
7431 /* If the subprogram is a function, we must return the expression. */
7432 if (Present (Expression (gnat_node
)))
7434 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
7436 /* If this function has copy-in/copy-out parameters parameters and
7437 doesn't return by invisible reference, get the real object for
7438 the return. See Subprogram_Body_to_gnu. */
7439 if (TYPE_CI_CO_LIST (gnu_subprog_type
)
7440 && !TREE_ADDRESSABLE (gnu_subprog_type
))
7441 gnu_ret_obj
= gnu_return_var_stack
->last ();
7443 gnu_ret_obj
= DECL_RESULT (current_function_decl
);
7445 /* Get the GCC tree for the expression to be returned. */
7446 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
7448 /* Do not remove the padding from GNU_RET_VAL if the inner type is
7449 self-referential since we want to allocate the fixed size. */
7450 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
7451 && type_is_padding_self_referential
7452 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
7453 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
7455 /* If the function returns by direct reference, return a pointer
7456 to the return value. */
7457 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
)
7458 || By_Ref (gnat_node
))
7459 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
7461 /* Otherwise, if it returns an unconstrained array, we have to
7462 allocate a new version of the result and return it. */
7463 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
))
7465 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
7467 /* And find out whether this is a candidate for Named Return
7468 Value. If so, record it. */
7471 && !TYPE_CI_CO_LIST (gnu_subprog_type
))
7473 tree ret_val
= gnu_ret_val
;
7475 /* Strip useless conversions around the return value. */
7476 if (gnat_useless_type_conversion (ret_val
))
7477 ret_val
= TREE_OPERAND (ret_val
, 0);
7479 /* Strip unpadding around the return value. */
7480 if (TREE_CODE (ret_val
) == COMPONENT_REF
7481 && TYPE_IS_PADDING_P
7482 (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
7483 ret_val
= TREE_OPERAND (ret_val
, 0);
7485 /* Now apply the test to the return value. */
7486 if (return_value_ok_for_nrv_p (NULL_TREE
, ret_val
))
7488 if (!f_named_ret_val
)
7489 f_named_ret_val
= BITMAP_GGC_ALLOC ();
7490 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
7492 f_gnat_ret
= gnat_node
;
7496 gnu_ret_val
= build_allocator (TREE_TYPE (gnu_ret_val
),
7498 TREE_TYPE (gnu_ret_obj
),
7499 Procedure_To_Call (gnat_node
),
7500 Storage_Pool (gnat_node
),
7504 /* Otherwise, if it returns by invisible reference, dereference
7505 the pointer it is passed using the type of the return value
7506 and build the copy operation manually. This ensures that we
7507 don't copy too much data, for example if the return type is
7508 unconstrained with a maximum size. */
7509 else if (TREE_ADDRESSABLE (gnu_subprog_type
))
7512 = build_unary_op (INDIRECT_REF
, TREE_TYPE (gnu_ret_val
),
7514 gnu_result
= build2 (INIT_EXPR
, void_type_node
,
7515 gnu_ret_deref
, gnu_ret_val
);
7516 add_stmt_with_node (gnu_result
, gnat_node
);
7517 gnu_ret_val
= NULL_TREE
;
7522 gnu_ret_obj
= gnu_ret_val
= NULL_TREE
;
7524 /* If we have a return label defined, convert this into a branch to
7525 that label. The return proper will be handled elsewhere. */
7526 if (gnu_return_label_stack
->last ())
7529 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_ret_obj
,
7532 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
7533 gnu_return_label_stack
->last ());
7535 /* When not optimizing, make sure the return is preserved. */
7536 if (!optimize
&& Comes_From_Source (gnat_node
))
7537 DECL_ARTIFICIAL (gnu_return_label_stack
->last ()) = 0;
7540 /* Otherwise, build a regular return. */
7542 gnu_result
= build_return_expr (gnu_ret_obj
, gnu_ret_val
);
7546 case N_Goto_Statement
:
7547 gnu_expr
= gnat_to_gnu (Name (gnat_node
));
7548 gnu_result
= build1 (GOTO_EXPR
, void_type_node
, gnu_expr
);
7549 TREE_USED (gnu_expr
) = 1;
7552 /***************************/
7553 /* Chapter 6: Subprograms */
7554 /***************************/
7556 case N_Subprogram_Declaration
:
7557 /* Unless there is a freeze node, declare the entity. We consider
7558 this a definition even though we're not generating code for the
7559 subprogram because we will be making the corresponding GCC node.
7560 When there is a freeze node, it is considered the definition of
7561 the subprogram and we do nothing until after it is encountered.
7562 That's an efficiency issue: the types involved in the profile
7563 are far more likely to be frozen between the declaration and
7564 the freeze node than before the declaration, so we save some
7565 updates of the GCC node by waiting until the freeze node.
7566 The counterpart is that we assume that there is no reference
7567 to the subprogram between the declaration and the freeze node
7568 in the expanded code; otherwise, it will be interpreted as an
7569 external reference and very likely give rise to a link failure. */
7570 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
7571 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
7573 gnu_result
= alloc_stmt_list ();
7576 case N_Abstract_Subprogram_Declaration
:
7577 /* This subprogram doesn't exist for code generation purposes, but we
7578 have to elaborate the types of any parameters and result, unless
7579 they are imported types (nothing to generate in this case).
7581 The parameter list may contain types with freeze nodes, e.g. not null
7582 subtypes, so the subprogram itself may carry a freeze node, in which
7583 case its elaboration must be deferred. */
7585 /* Process the parameter types first. */
7586 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
7588 = First_Formal_With_Extras
7589 (Defining_Entity (Specification (gnat_node
)));
7590 Present (gnat_temp
);
7591 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
7592 if (Is_Itype (Etype (gnat_temp
))
7593 && !From_Limited_With (Etype (gnat_temp
)))
7594 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, false);
7596 /* Then the result type, set to Standard_Void_Type for procedures. */
7598 Entity_Id gnat_temp_type
7599 = Etype (Defining_Entity (Specification (gnat_node
)));
7601 if (Is_Itype (gnat_temp_type
) && !From_Limited_With (gnat_temp_type
))
7602 gnat_to_gnu_entity (Etype (gnat_temp_type
), NULL_TREE
, false);
7605 gnu_result
= alloc_stmt_list ();
7608 case N_Defining_Program_Unit_Name
:
7609 /* For a child unit identifier go up a level to get the specification.
7610 We get this when we try to find the spec of a child unit package
7611 that is the compilation unit being compiled. */
7612 gnu_result
= gnat_to_gnu (Parent (gnat_node
));
7615 case N_Subprogram_Body
:
7616 Subprogram_Body_to_gnu (gnat_node
);
7617 gnu_result
= alloc_stmt_list ();
7620 case N_Function_Call
:
7621 case N_Procedure_Call_Statement
:
7622 gnu_result
= Call_to_gnu (gnat_node
, &gnu_result_type
, NULL_TREE
,
7626 /************************/
7627 /* Chapter 7: Packages */
7628 /************************/
7630 case N_Package_Declaration
:
7631 gnu_result
= gnat_to_gnu (Specification (gnat_node
));
7634 case N_Package_Specification
:
7636 start_stmt_group ();
7637 process_decls (Visible_Declarations (gnat_node
),
7638 Private_Declarations (gnat_node
), Empty
, true, true);
7639 gnu_result
= end_stmt_group ();
7642 case N_Package_Body
:
7644 /* If this is the body of a generic package - do nothing. */
7645 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
7647 gnu_result
= alloc_stmt_list ();
7651 start_stmt_group ();
7652 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7654 if (Present (Handled_Statement_Sequence (gnat_node
)))
7655 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
7657 gnu_result
= end_stmt_group ();
7660 /********************************/
7661 /* Chapter 8: Visibility Rules */
7662 /********************************/
7664 case N_Use_Package_Clause
:
7665 case N_Use_Type_Clause
:
7666 /* Nothing to do here - but these may appear in list of declarations. */
7667 gnu_result
= alloc_stmt_list ();
7670 /*********************/
7671 /* Chapter 9: Tasks */
7672 /*********************/
7674 case N_Protected_Type_Declaration
:
7675 gnu_result
= alloc_stmt_list ();
7678 case N_Single_Task_Declaration
:
7679 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, true);
7680 gnu_result
= alloc_stmt_list ();
7683 /*********************************************************/
7684 /* Chapter 10: Program Structure and Compilation Issues */
7685 /*********************************************************/
7687 case N_Compilation_Unit
:
7688 /* This is not called for the main unit on which gigi is invoked. */
7689 Compilation_Unit_to_gnu (gnat_node
);
7690 gnu_result
= alloc_stmt_list ();
7694 gnu_result
= gnat_to_gnu (Proper_Body (gnat_node
));
7698 case N_Protected_Body
:
7700 /* These nodes should only be present when annotating types. */
7701 gcc_assert (type_annotate_only
);
7702 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
7703 gnu_result
= alloc_stmt_list ();
7706 case N_Subprogram_Body_Stub
:
7707 case N_Package_Body_Stub
:
7708 case N_Protected_Body_Stub
:
7709 case N_Task_Body_Stub
:
7710 /* Simply process whatever unit is being inserted. */
7711 if (Present (Library_Unit (gnat_node
)))
7712 gnu_result
= gnat_to_gnu (Unit (Library_Unit (gnat_node
)));
7715 gcc_assert (type_annotate_only
);
7716 gnu_result
= alloc_stmt_list ();
7720 /***************************/
7721 /* Chapter 11: Exceptions */
7722 /***************************/
7724 case N_Handled_Sequence_Of_Statements
:
7725 /* If there is an At_End procedure attached to this node, and the EH
7726 mechanism is front-end, we must have at least a corresponding At_End
7727 handler, unless the No_Exception_Handlers restriction is set. */
7728 gcc_assert (type_annotate_only
7729 || !Front_End_Exceptions ()
7730 || No (At_End_Proc (gnat_node
))
7731 || Present (Exception_Handlers (gnat_node
))
7732 || No_Exception_Handlers_Set ());
7734 gnu_result
= Handled_Sequence_Of_Statements_to_gnu (gnat_node
);
7737 case N_Exception_Handler
:
7738 if (Back_End_Exceptions ())
7739 gnu_result
= Exception_Handler_to_gnu_gcc (gnat_node
);
7740 else if (Exception_Mechanism
== Front_End_SJLJ
)
7741 gnu_result
= Exception_Handler_to_gnu_fe_sjlj (gnat_node
);
7746 case N_Raise_Statement
:
7747 /* Only for reraise in back-end exceptions mode. */
7748 gcc_assert (No (Name (gnat_node
)) && Back_End_Exceptions ());
7750 start_stmt_group ();
7752 add_stmt_with_node (build_call_n_expr (reraise_zcx_decl
, 1,
7753 gnu_incoming_exc_ptr
),
7756 gnu_result
= end_stmt_group ();
7759 case N_Push_Constraint_Error_Label
:
7760 gnu_constraint_error_label_stack
.safe_push (Exception_Label (gnat_node
));
7763 case N_Push_Storage_Error_Label
:
7764 gnu_storage_error_label_stack
.safe_push (Exception_Label (gnat_node
));
7767 case N_Push_Program_Error_Label
:
7768 gnu_program_error_label_stack
.safe_push (Exception_Label (gnat_node
));
7771 case N_Pop_Constraint_Error_Label
:
7772 gnat_temp
= gnu_constraint_error_label_stack
.pop ();
7773 if (Present (gnat_temp
)
7774 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
7775 Warn_If_No_Local_Raise (gnat_temp
);
7778 case N_Pop_Storage_Error_Label
:
7779 gnat_temp
= gnu_storage_error_label_stack
.pop ();
7780 if (Present (gnat_temp
)
7781 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
7782 Warn_If_No_Local_Raise (gnat_temp
);
7785 case N_Pop_Program_Error_Label
:
7786 gnat_temp
= gnu_program_error_label_stack
.pop ();
7787 if (Present (gnat_temp
)
7788 && !TREE_USED (gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false)))
7789 Warn_If_No_Local_Raise (gnat_temp
);
7792 /******************************/
7793 /* Chapter 12: Generic Units */
7794 /******************************/
7796 case N_Generic_Function_Renaming_Declaration
:
7797 case N_Generic_Package_Renaming_Declaration
:
7798 case N_Generic_Procedure_Renaming_Declaration
:
7799 case N_Generic_Package_Declaration
:
7800 case N_Generic_Subprogram_Declaration
:
7801 case N_Package_Instantiation
:
7802 case N_Procedure_Instantiation
:
7803 case N_Function_Instantiation
:
7804 /* These nodes can appear on a declaration list but there is nothing to
7805 to be done with them. */
7806 gnu_result
= alloc_stmt_list ();
7809 /**************************************************/
7810 /* Chapter 13: Representation Clauses and */
7811 /* Implementation-Dependent Features */
7812 /**************************************************/
7814 case N_Attribute_Definition_Clause
:
7815 gnu_result
= alloc_stmt_list ();
7817 /* The only one we need to deal with is 'Address since, for the others,
7818 the front-end puts the information elsewhere. */
7819 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
)
7822 /* And we only deal with 'Address if the object has a Freeze node. */
7823 gnat_temp
= Entity (Name (gnat_node
));
7824 if (Freeze_Node (gnat_temp
))
7826 tree gnu_address
= gnat_to_gnu (Expression (gnat_node
)), gnu_temp
;
7828 /* Get the value to use as the address and save it as the equivalent
7829 for the object; when it is frozen, gnat_to_gnu_entity will do the
7830 right thing. For a subprogram, put the naked address but build a
7831 meaningfull expression for an object in case its address is taken
7832 before the Freeze node is encountered; this can happen if the type
7833 of the object is limited and it is initialized with the result of
7835 if (Is_Subprogram (gnat_temp
))
7836 gnu_temp
= gnu_address
;
7839 tree gnu_type
= gnat_to_gnu_type (Etype (gnat_temp
));
7840 /* Drop atomic and volatile qualifiers for the expression. */
7841 gnu_type
= TYPE_MAIN_VARIANT (gnu_type
);
7843 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
7844 gnu_address
= convert (gnu_type
, gnu_address
);
7846 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_address
);
7849 save_gnu_tree (gnat_temp
, gnu_temp
, true);
7853 case N_Enumeration_Representation_Clause
:
7854 case N_Record_Representation_Clause
:
7856 /* We do nothing with these. SEM puts the information elsewhere. */
7857 gnu_result
= alloc_stmt_list ();
7860 case N_Code_Statement
:
7861 if (!type_annotate_only
)
7863 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
7864 tree gnu_inputs
= NULL_TREE
, gnu_outputs
= NULL_TREE
;
7865 tree gnu_clobbers
= NULL_TREE
, tail
;
7866 bool allows_mem
, allows_reg
, fake
;
7867 int ninputs
, noutputs
, i
;
7868 const char **oconstraints
;
7869 const char *constraint
;
7872 /* First retrieve the 3 operand lists built by the front-end. */
7873 Setup_Asm_Outputs (gnat_node
);
7874 while (Present (gnat_temp
= Asm_Output_Variable ()))
7876 tree gnu_value
= gnat_to_gnu (gnat_temp
);
7877 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
7878 (Asm_Output_Constraint ()));
7880 gnu_outputs
= tree_cons (gnu_constr
, gnu_value
, gnu_outputs
);
7884 Setup_Asm_Inputs (gnat_node
);
7885 while (Present (gnat_temp
= Asm_Input_Value ()))
7887 tree gnu_value
= gnat_to_gnu (gnat_temp
);
7888 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
7889 (Asm_Input_Constraint ()));
7891 gnu_inputs
= tree_cons (gnu_constr
, gnu_value
, gnu_inputs
);
7895 Clobber_Setup (gnat_node
);
7896 while ((clobber
= Clobber_Get_Next ()))
7898 = tree_cons (NULL_TREE
,
7899 build_string (strlen (clobber
) + 1, clobber
),
7902 /* Then perform some standard checking and processing on the
7903 operands. In particular, mark them addressable if needed. */
7904 gnu_outputs
= nreverse (gnu_outputs
);
7905 noutputs
= list_length (gnu_outputs
);
7906 gnu_inputs
= nreverse (gnu_inputs
);
7907 ninputs
= list_length (gnu_inputs
);
7908 oconstraints
= XALLOCAVEC (const char *, noutputs
);
7910 for (i
= 0, tail
= gnu_outputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
7912 tree output
= TREE_VALUE (tail
);
7914 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
7915 oconstraints
[i
] = constraint
;
7917 if (parse_output_constraint (&constraint
, i
, ninputs
, noutputs
,
7918 &allows_mem
, &allows_reg
, &fake
))
7920 /* If the operand is going to end up in memory,
7921 mark it addressable. Note that we don't test
7922 allows_mem like in the input case below; this
7923 is modeled on the C front-end. */
7926 output
= remove_conversions (output
, false);
7927 if (TREE_CODE (output
) == CONST_DECL
7928 && DECL_CONST_CORRESPONDING_VAR (output
))
7929 output
= DECL_CONST_CORRESPONDING_VAR (output
);
7930 if (!gnat_mark_addressable (output
))
7931 output
= error_mark_node
;
7935 output
= error_mark_node
;
7937 TREE_VALUE (tail
) = output
;
7940 for (i
= 0, tail
= gnu_inputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
7942 tree input
= TREE_VALUE (tail
);
7944 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
7946 if (parse_input_constraint (&constraint
, i
, ninputs
, noutputs
,
7948 &allows_mem
, &allows_reg
))
7950 /* If the operand is going to end up in memory,
7951 mark it addressable. */
7952 if (!allows_reg
&& allows_mem
)
7954 input
= remove_conversions (input
, false);
7955 if (TREE_CODE (input
) == CONST_DECL
7956 && DECL_CONST_CORRESPONDING_VAR (input
))
7957 input
= DECL_CONST_CORRESPONDING_VAR (input
);
7958 if (!gnat_mark_addressable (input
))
7959 input
= error_mark_node
;
7963 input
= error_mark_node
;
7965 TREE_VALUE (tail
) = input
;
7968 gnu_result
= build5 (ASM_EXPR
, void_type_node
,
7969 gnu_template
, gnu_outputs
,
7970 gnu_inputs
, gnu_clobbers
, NULL_TREE
);
7971 ASM_VOLATILE_P (gnu_result
) = Is_Asm_Volatile (gnat_node
);
7974 gnu_result
= alloc_stmt_list ();
7982 /* Markers are created by the ABE mechanism to capture information which
7983 is either unavailable of expensive to recompute. Markers do not have
7984 and runtime semantics, and should be ignored. */
7987 case N_Variable_Reference_Marker
:
7988 gnu_result
= alloc_stmt_list ();
7991 case N_Expression_With_Actions
:
7992 /* This construct doesn't define a scope so we don't push a binding
7993 level around the statement list, but we wrap it in a SAVE_EXPR to
7994 protect it from unsharing. Elaborate the expression as part of the
7995 same statement group as the actions so that the type declaration
7996 gets inserted there as well. This ensures that the type elaboration
7997 code is issued past the actions computing values on which it might
7999 start_stmt_group ();
8000 add_stmt_list (Actions (gnat_node
));
8001 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
8002 gnu_result
= end_stmt_group ();
8004 gnu_result
= build1 (SAVE_EXPR
, void_type_node
, gnu_result
);
8005 TREE_SIDE_EFFECTS (gnu_result
) = 1;
8008 = build_compound_expr (TREE_TYPE (gnu_expr
), gnu_result
, gnu_expr
);
8009 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
8012 case N_Freeze_Entity
:
8013 start_stmt_group ();
8014 process_freeze_entity (gnat_node
);
8015 process_decls (Actions (gnat_node
), Empty
, Empty
, true, true);
8016 gnu_result
= end_stmt_group ();
8019 case N_Freeze_Generic_Entity
:
8020 gnu_result
= alloc_stmt_list ();
8023 case N_Itype_Reference
:
8024 if (!present_gnu_tree (Itype (gnat_node
)))
8025 process_type (Itype (gnat_node
));
8026 gnu_result
= alloc_stmt_list ();
8029 case N_Free_Statement
:
8030 gnat_temp
= Expression (gnat_node
);
8032 if (!type_annotate_only
)
8034 tree gnu_ptr
, gnu_ptr_type
, gnu_obj_type
, gnu_actual_obj_type
;
8036 const Entity_Id gnat_desig_type
8037 = Designated_Type (Underlying_Type (Etype (gnat_temp
)));
8039 /* Make sure the designated type is complete before dereferencing,
8040 in case it is a Taft Amendment type. */
8041 (void) gnat_to_gnu_entity (gnat_desig_type
, NULL_TREE
, false);
8043 gnu_ptr
= gnat_to_gnu (gnat_temp
);
8044 gnu_ptr_type
= TREE_TYPE (gnu_ptr
);
8046 /* If this is a thin pointer, we must first dereference it to create
8047 a fat pointer, then go back below to a thin pointer. The reason
8048 for this is that we need to have a fat pointer someplace in order
8049 to properly compute the size. */
8050 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
8051 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
8052 build_unary_op (INDIRECT_REF
, NULL_TREE
,
8055 /* If this is a fat pointer, the object must have been allocated with
8056 the template in front of the array. So pass the template address,
8057 and get the total size; do it by converting to a thin pointer. */
8058 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
8060 = convert (build_pointer_type
8061 (TYPE_OBJECT_RECORD_TYPE
8062 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
8065 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
8067 /* If this is a thin pointer, the object must have been allocated with
8068 the template in front of the array. So pass the template address,
8069 and get the total size. */
8070 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
8072 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
8074 fold_build1 (NEGATE_EXPR
, sizetype
,
8077 TYPE_FIELDS ((gnu_obj_type
)))));
8079 /* If we have a special dynamic constrained subtype on the node, use
8080 it to compute the size; otherwise, use the designated subtype. */
8081 if (Present (Actual_Designated_Subtype (gnat_node
)))
8084 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node
));
8086 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
))
8088 = build_unc_object_type_from_ptr (gnu_ptr_type
,
8089 gnu_actual_obj_type
,
8090 get_identifier ("DEALLOC"),
8094 gnu_actual_obj_type
= gnu_obj_type
;
8096 tree gnu_size
= TYPE_SIZE_UNIT (gnu_actual_obj_type
);
8097 gnu_size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size
, gnu_ptr
);
8100 = build_call_alloc_dealloc (gnu_ptr
, gnu_size
, gnu_obj_type
,
8101 Procedure_To_Call (gnat_node
),
8102 Storage_Pool (gnat_node
),
8107 case N_Raise_Constraint_Error
:
8108 case N_Raise_Program_Error
:
8109 case N_Raise_Storage_Error
:
8110 if (type_annotate_only
)
8111 gnu_result
= alloc_stmt_list ();
8113 gnu_result
= Raise_Error_to_gnu (gnat_node
, &gnu_result_type
);
8116 case N_Validate_Unchecked_Conversion
:
8117 /* The only validation we currently do on an unchecked conversion is
8118 that of aliasing assumptions. */
8119 if (flag_strict_aliasing
)
8120 gnat_validate_uc_list
.safe_push (gnat_node
);
8121 gnu_result
= alloc_stmt_list ();
8124 case N_Function_Specification
:
8125 case N_Procedure_Specification
:
8127 case N_Component_Association
:
8128 /* These nodes should only be present when annotating types. */
8129 gcc_assert (type_annotate_only
);
8130 gnu_result
= alloc_stmt_list ();
8134 /* Other nodes are not supposed to reach here. */
8138 /* If we pushed the processing of the elaboration routine, pop it back. */
8139 if (went_into_elab_proc
)
8140 current_function_decl
= NULL_TREE
;
8142 /* When not optimizing, turn boolean rvalues B into B != false tests
8143 so that we can put the location information of the reference to B on
8144 the inequality operator for better debug info. */
8146 && TREE_CODE (gnu_result
) != INTEGER_CST
8147 && TREE_CODE (gnu_result
) != TYPE_DECL
8148 && (kind
== N_Identifier
8149 || kind
== N_Expanded_Name
8150 || kind
== N_Explicit_Dereference
8151 || kind
== N_Indexed_Component
8152 || kind
== N_Selected_Component
)
8153 && TREE_CODE (get_base_type (gnu_result_type
)) == BOOLEAN_TYPE
8154 && Nkind (Parent (gnat_node
)) != N_Attribute_Reference
8155 && Nkind (Parent (gnat_node
)) != N_Variant_Part
8156 && !lvalue_required_p (gnat_node
, gnu_result_type
, false, false))
8159 = build_binary_op (NE_EXPR
, gnu_result_type
,
8160 convert (gnu_result_type
, gnu_result
),
8161 convert (gnu_result_type
, boolean_false_node
));
8162 if (TREE_CODE (gnu_result
) != INTEGER_CST
)
8163 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
8166 /* Set the location information on the result if it's not a simple name
8167 or something that contains a simple name, for example a tag, because
8168 we don"t want all the references to get the location of the first use.
8169 Note that we may have no result if we tried to build a CALL_EXPR node
8170 to a procedure with no side-effects and optimization is enabled. */
8171 else if (kind
!= N_Identifier
8172 && !(kind
== N_Selected_Component
8173 && Chars (Selector_Name (gnat_node
)) == Name_uTag
)
8175 && EXPR_P (gnu_result
))
8176 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
8178 /* If we're supposed to return something of void_type, it means we have
8179 something we're elaborating for effect, so just return. */
8180 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
8183 /* If the result is a constant that overflowed, raise Constraint_Error. */
8184 if (TREE_CODE (gnu_result
) == INTEGER_CST
&& TREE_OVERFLOW (gnu_result
))
8186 post_error ("?`Constraint_Error` will be raised at run time", gnat_node
);
8188 = build1 (NULL_EXPR
, gnu_result_type
,
8189 build_call_raise (CE_Overflow_Check_Failed
, gnat_node
,
8190 N_Raise_Constraint_Error
));
8193 /* If the result has side-effects and is of an unconstrained type, protect
8194 the expression in case it will be referenced multiple times, i.e. for
8195 its value and to compute the size of an object. But do it neither for
8196 an object nor a renaming declaration, nor a return statement of a call
8197 to a function that returns an unconstrained record type with default
8198 discriminant, because there is no size to be computed in these cases
8199 and this will create a useless temporary. We must do this before any
8201 if (TREE_SIDE_EFFECTS (gnu_result
)
8202 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
8203 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
)))
8204 && !(TREE_CODE (gnu_result
) == CALL_EXPR
8205 && type_is_padding_self_referential (TREE_TYPE (gnu_result
))
8206 && (Nkind (Parent (gnat_node
)) == N_Object_Declaration
8207 || Nkind (Parent (gnat_node
)) == N_Object_Renaming_Declaration
8208 || Nkind (Parent (gnat_node
)) == N_Simple_Return_Statement
)))
8209 gnu_result
= gnat_protect_expr (gnu_result
);
8211 /* Now convert the result to the result type, unless we are in one of the
8214 1. If this is the LHS of an assignment or an actual parameter of a
8215 call, return the result almost unmodified since the RHS will have
8216 to be converted to our type in that case, unless the result type
8217 has a simpler size or for array types because this size might be
8218 changed in-between. Likewise if there is just a no-op unchecked
8219 conversion in-between. Similarly, don't convert integral types
8220 that are the operands of an unchecked conversion since we need
8221 to ignore those conversions (for 'Valid).
8223 2. If we have a label (which doesn't have any well-defined type), a
8224 field or an error, return the result almost unmodified. Similarly,
8225 if the two types are record types with the same name, don't convert.
8226 This will be the case when we are converting from a packable version
8227 of a type to its original type and we need those conversions to be
8228 NOPs in order for assignments into these types to work properly.
8230 3. If the type is void or if we have no result, return error_mark_node
8231 to show we have no result.
8233 4. If this is a call to a function that returns with variable size and
8234 the call is used as the expression in either an object or a renaming
8235 declaration, return the result unmodified because we want to use the
8236 return slot optimization in this case.
8238 5. If this is a reference to an unconstrained array which is used as the
8239 prefix of an attribute reference that requires an lvalue, return the
8240 result unmodified because we want to return the original bounds.
8242 6. Finally, if the type of the result is already correct. */
8244 if (Present (Parent (gnat_node
))
8245 && (lhs_or_actual_p (gnat_node
)
8246 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
8247 && unchecked_conversion_nop (Parent (gnat_node
)))
8248 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
8249 && !AGGREGATE_TYPE_P (gnu_result_type
)
8250 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))))
8251 && !(TYPE_SIZE (gnu_result_type
)
8252 && TYPE_SIZE (TREE_TYPE (gnu_result
))
8253 && AGGREGATE_TYPE_P (gnu_result_type
)
8254 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))
8255 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
8256 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
8258 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
8259 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
8260 && (CONTAINS_PLACEHOLDER_P
8261 (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
8262 || (TREE_CODE (gnu_result_type
) == ARRAY_TYPE
8263 && TREE_CODE (TREE_TYPE (gnu_result
)) == ARRAY_TYPE
))
8264 && !(TREE_CODE (gnu_result_type
) == RECORD_TYPE
8265 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type
))))
8267 /* Remove padding only if the inner object is of self-referential
8268 size: in that case it must be an object of unconstrained type
8269 with a default discriminant and we want to avoid copying too
8271 if (type_is_padding_self_referential (TREE_TYPE (gnu_result
)))
8272 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
8276 else if (TREE_CODE (gnu_result
) == LABEL_DECL
8277 || TREE_CODE (gnu_result
) == FIELD_DECL
8278 || TREE_CODE (gnu_result
) == ERROR_MARK
8279 || (TYPE_NAME (gnu_result_type
)
8280 == TYPE_NAME (TREE_TYPE (gnu_result
))
8281 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
8282 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
))
8284 /* Remove any padding. */
8285 gnu_result
= maybe_padded_object (gnu_result
);
8288 else if (gnu_result
== error_mark_node
|| gnu_result_type
== void_type_node
)
8289 gnu_result
= error_mark_node
;
8291 else if (TREE_CODE (gnu_result
) == CALL_EXPR
8292 && Present (Parent (gnat_node
))
8293 && (Nkind (Parent (gnat_node
)) == N_Object_Declaration
8294 || Nkind (Parent (gnat_node
)) == N_Object_Renaming_Declaration
)
8295 && return_type_with_variable_size_p (TREE_TYPE (gnu_result
)))
8298 else if (TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
8299 && Present (Parent (gnat_node
))
8300 && Nkind (Parent (gnat_node
)) == N_Attribute_Reference
8301 && lvalue_required_for_attribute_p (Parent (gnat_node
)))
8304 else if (TREE_TYPE (gnu_result
) != gnu_result_type
)
8305 gnu_result
= convert (gnu_result_type
, gnu_result
);
8307 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
8308 while ((TREE_CODE (gnu_result
) == NOP_EXPR
8309 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
8310 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
8311 gnu_result
= TREE_OPERAND (gnu_result
, 0);
8316 /* Similar to gnat_to_gnu, but discard any object that might be created in
8317 the course of the translation of GNAT_NODE, which must be an "external"
8318 expression in the sense that it will be elaborated elsewhere. */
8321 gnat_to_gnu_external (Node_Id gnat_node
)
8323 const int save_force_global
= force_global
;
8324 bool went_into_elab_proc
= false;
8326 /* Force the local context and create a fake scope that we zap
8327 at the end so declarations will not be stuck either in the
8328 global varpool or in the current scope. */
8329 if (!current_function_decl
)
8331 current_function_decl
= get_elaboration_procedure ();
8332 went_into_elab_proc
= true;
8337 tree gnu_result
= gnat_to_gnu (gnat_node
);
8340 force_global
= save_force_global
;
8341 if (went_into_elab_proc
)
8342 current_function_decl
= NULL_TREE
;
8344 /* Do not import locations from external units. */
8345 if (gnu_result
&& EXPR_P (gnu_result
))
8346 SET_EXPR_LOCATION (gnu_result
, UNKNOWN_LOCATION
);
8351 /* Return true if the statement list STMT_LIST is empty. */
8354 empty_stmt_list_p (tree stmt_list
)
8356 tree_stmt_iterator tsi
;
8358 for (tsi
= tsi_start (stmt_list
); !tsi_end_p (tsi
); tsi_next (&tsi
))
8360 tree stmt
= tsi_stmt (tsi
);
8362 /* Anything else than an empty STMT_STMT counts as something. */
8363 if (TREE_CODE (stmt
) != STMT_STMT
|| STMT_STMT_STMT (stmt
))
8370 /* Record the current code position in GNAT_NODE. */
8373 record_code_position (Node_Id gnat_node
)
8375 tree stmt_stmt
= build1 (STMT_STMT
, void_type_node
, NULL_TREE
);
8377 add_stmt_with_node (stmt_stmt
, gnat_node
);
8378 save_gnu_tree (gnat_node
, stmt_stmt
, true);
8381 /* Insert the code for GNAT_NODE at the position saved for that node. */
8384 insert_code_for (Node_Id gnat_node
)
8386 tree code
= gnat_to_gnu (gnat_node
);
8388 /* It's too late to remove the STMT_STMT itself at this point. */
8389 if (!empty_stmt_list_p (code
))
8390 STMT_STMT_STMT (get_gnu_tree (gnat_node
)) = code
;
8392 save_gnu_tree (gnat_node
, NULL_TREE
, true);
8395 /* Start a new statement group chained to the previous group. */
8398 start_stmt_group (void)
8400 struct stmt_group
*group
= stmt_group_free_list
;
8402 /* First see if we can get one from the free list. */
8404 stmt_group_free_list
= group
->previous
;
8406 group
= ggc_alloc
<stmt_group
> ();
8408 group
->previous
= current_stmt_group
;
8409 group
->stmt_list
= group
->block
= group
->cleanups
= NULL_TREE
;
8410 current_stmt_group
= group
;
8413 /* Add GNU_STMT to the current statement group. If it is an expression with
8414 no effects, it is ignored. */
8417 add_stmt (tree gnu_stmt
)
8419 append_to_statement_list (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
8422 /* Similar, but the statement is always added, regardless of side-effects. */
8425 add_stmt_force (tree gnu_stmt
)
8427 append_to_statement_list_force (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
8430 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
8433 add_stmt_with_node (tree gnu_stmt
, Node_Id gnat_node
)
8435 if (Present (gnat_node
))
8436 set_expr_location_from_node (gnu_stmt
, gnat_node
);
8437 add_stmt (gnu_stmt
);
8440 /* Similar, but the statement is always added, regardless of side-effects. */
8443 add_stmt_with_node_force (tree gnu_stmt
, Node_Id gnat_node
)
8445 if (Present (gnat_node
))
8446 set_expr_location_from_node (gnu_stmt
, gnat_node
);
8447 add_stmt_force (gnu_stmt
);
8450 /* Add a declaration statement for GNU_DECL to the current statement group.
8451 Get the SLOC to be put onto the statement from GNAT_NODE. */
8454 add_decl_expr (tree gnu_decl
, Node_Id gnat_node
)
8456 tree type
= TREE_TYPE (gnu_decl
);
8457 tree gnu_stmt
, gnu_init
;
8459 /* If this is a variable that Gigi is to ignore, we may have been given
8460 an ERROR_MARK. So test for it. We also might have been given a
8461 reference for a renaming. So only do something for a decl. Also
8462 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
8463 if (!DECL_P (gnu_decl
)
8464 || (TREE_CODE (gnu_decl
) == TYPE_DECL
8465 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
))
8468 gnu_stmt
= build1 (DECL_EXPR
, void_type_node
, gnu_decl
);
8470 /* If we are external or global, we don't want to output the DECL_EXPR for
8471 this DECL node since we already have evaluated the expressions in the
8472 sizes and positions as globals and doing it again would be wrong. */
8473 if (DECL_EXTERNAL (gnu_decl
) || global_bindings_p ())
8475 /* Mark everything as used to prevent node sharing with subprograms.
8476 Note that walk_tree knows how to deal with TYPE_DECL, but neither
8477 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
8478 MARK_VISITED (gnu_stmt
);
8479 if (TREE_CODE (gnu_decl
) == VAR_DECL
8480 || TREE_CODE (gnu_decl
) == CONST_DECL
)
8482 MARK_VISITED (DECL_SIZE (gnu_decl
));
8483 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl
));
8484 MARK_VISITED (DECL_INITIAL (gnu_decl
));
8486 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
8487 else if (TREE_CODE (gnu_decl
) == TYPE_DECL
8488 && RECORD_OR_UNION_TYPE_P (type
)
8489 && !TYPE_FAT_POINTER_P (type
))
8490 MARK_VISITED (TYPE_ADA_SIZE (type
));
8493 add_stmt_with_node (gnu_stmt
, gnat_node
);
8495 /* If this is a variable and an initializer is attached to it, it must be
8496 valid for the context. Similar to init_const in create_var_decl. */
8497 if (TREE_CODE (gnu_decl
) == VAR_DECL
8498 && (gnu_init
= DECL_INITIAL (gnu_decl
))
8499 && (!gnat_types_compatible_p (type
, TREE_TYPE (gnu_init
))
8500 || (TREE_STATIC (gnu_decl
)
8501 && !initializer_constant_valid_p (gnu_init
,
8502 TREE_TYPE (gnu_init
)))))
8504 DECL_INITIAL (gnu_decl
) = NULL_TREE
;
8505 if (TREE_READONLY (gnu_decl
))
8507 TREE_READONLY (gnu_decl
) = 0;
8508 DECL_READONLY_ONCE_ELAB (gnu_decl
) = 1;
8511 /* Remove any padding so the assignment is done properly. */
8512 gnu_decl
= maybe_padded_object (gnu_decl
);
8514 gnu_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_decl
, gnu_init
);
8515 add_stmt_with_node (gnu_stmt
, gnat_node
);
8519 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
8522 mark_visited_r (tree
*tp
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
8526 if (TREE_VISITED (t
))
8529 /* Don't mark a dummy type as visited because we want to mark its sizes
8530 and fields once it's filled in. */
8531 else if (!TYPE_IS_DUMMY_P (t
))
8532 TREE_VISITED (t
) = 1;
8534 /* The test in gimplify_type_sizes is on the main variant. */
8536 TYPE_SIZES_GIMPLIFIED (TYPE_MAIN_VARIANT (t
)) = 1;
8541 /* Mark nodes rooted at T with TREE_VISITED and types as having their
8542 sized gimplified. We use this to indicate all variable sizes and
8543 positions in global types may not be shared by any subprogram. */
8546 mark_visited (tree t
)
8548 walk_tree (&t
, mark_visited_r
, NULL
, NULL
);
8551 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
8552 set its location to that of GNAT_NODE if present, but with column info
8553 cleared so that conditional branches generated as part of the cleanup
8554 code do not interfere with coverage analysis tools. */
8557 add_cleanup (tree gnu_cleanup
, Node_Id gnat_node
)
8559 if (Present (gnat_node
))
8560 set_expr_location_from_node (gnu_cleanup
, gnat_node
, true);
8562 /* An EH_ELSE_EXPR must be by itself, and that's all we need when we
8563 use it. The assert below makes sure that is so. Should we ever
8564 need more than that, we could combine EH_ELSE_EXPRs, and copy
8565 non-EH_ELSE_EXPR stmts into both cleanup paths of an
8567 if (TREE_CODE (gnu_cleanup
) == EH_ELSE_EXPR
)
8569 gcc_assert (!current_stmt_group
->cleanups
);
8570 current_stmt_group
->cleanups
= gnu_cleanup
;
8574 gcc_assert (!current_stmt_group
->cleanups
8575 || (TREE_CODE (current_stmt_group
->cleanups
)
8577 append_to_statement_list (gnu_cleanup
, ¤t_stmt_group
->cleanups
);
8581 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
8584 set_block_for_group (tree gnu_block
)
8586 gcc_assert (!current_stmt_group
->block
);
8587 current_stmt_group
->block
= gnu_block
;
8590 /* Return code corresponding to the current code group. It is normally
8591 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
8592 BLOCK or cleanups were set. */
8595 end_stmt_group (void)
8597 struct stmt_group
*group
= current_stmt_group
;
8598 tree gnu_retval
= group
->stmt_list
;
8600 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
8601 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
8602 make a BIND_EXPR. Note that we nest in that because the cleanup may
8603 reference variables in the block. */
8605 gnu_retval
= alloc_stmt_list ();
8607 if (group
->cleanups
)
8608 gnu_retval
= build2 (TRY_FINALLY_EXPR
, void_type_node
, gnu_retval
,
8611 if (current_stmt_group
->block
)
8612 gnu_retval
= build3 (BIND_EXPR
, void_type_node
, BLOCK_VARS (group
->block
),
8613 gnu_retval
, group
->block
);
8615 /* Remove this group from the stack and add it to the free list. */
8616 current_stmt_group
= group
->previous
;
8617 group
->previous
= stmt_group_free_list
;
8618 stmt_group_free_list
= group
;
8623 /* Return whether the current statement group may fall through. */
8626 stmt_group_may_fallthru (void)
8628 if (current_stmt_group
->stmt_list
)
8629 return block_may_fallthru (current_stmt_group
->stmt_list
);
8634 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
8638 add_stmt_list (List_Id gnat_list
)
8642 if (Present (gnat_list
))
8643 for (gnat_node
= First (gnat_list
); Present (gnat_node
);
8644 gnat_node
= Next (gnat_node
))
8645 add_stmt (gnat_to_gnu (gnat_node
));
8648 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
8649 If BINDING_P is true, push and pop a binding level around the list. */
8652 build_stmt_group (List_Id gnat_list
, bool binding_p
)
8654 start_stmt_group ();
8659 add_stmt_list (gnat_list
);
8664 return end_stmt_group ();
8667 /* Generate GIMPLE in place for the expression at *EXPR_P. */
8670 gnat_gimplify_expr (tree
*expr_p
, gimple_seq
*pre_p
,
8671 gimple_seq
*post_p ATTRIBUTE_UNUSED
)
8673 tree expr
= *expr_p
;
8674 tree type
= TREE_TYPE (expr
);
8677 if (IS_ADA_STMT (expr
))
8678 return gnat_gimplify_stmt (expr_p
);
8680 switch (TREE_CODE (expr
))
8683 /* If this is an aggregate type, build a null pointer of the appropriate
8684 type and dereference it. */
8685 if (AGGREGATE_TYPE_P (type
)
8686 || TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
8687 *expr_p
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
8688 convert (build_pointer_type (type
),
8689 integer_zero_node
));
8690 /* Otherwise, just make a VAR_DECL. */
8693 *expr_p
= create_tmp_var (type
, NULL
);
8694 TREE_NO_WARNING (*expr_p
) = 1;
8697 gimplify_and_add (TREE_OPERAND (expr
, 0), pre_p
);
8700 case UNCONSTRAINED_ARRAY_REF
:
8701 /* We should only do this if we are just elaborating for side-effects,
8702 but we can't know that yet. */
8703 *expr_p
= TREE_OPERAND (*expr_p
, 0);
8707 op
= TREE_OPERAND (expr
, 0);
8709 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
8710 is put into static memory. We know that it's going to be read-only
8711 given the semantics we have and it must be in static memory when the
8712 reference is in an elaboration procedure. */
8713 if (TREE_CODE (op
) == CONSTRUCTOR
&& TREE_CONSTANT (op
))
8715 tree addr
= build_fold_addr_expr (tree_output_constant_def (op
));
8716 *expr_p
= fold_convert (type
, addr
);
8720 /* Replace atomic loads with their first argument. That's necessary
8721 because the gimplifier would create a temporary otherwise. */
8722 if (TREE_SIDE_EFFECTS (op
))
8723 while (handled_component_p (op
) || CONVERT_EXPR_P (op
))
8725 tree inner
= TREE_OPERAND (op
, 0);
8726 if (TREE_CODE (inner
) == CALL_EXPR
&& call_is_atomic_load (inner
))
8728 tree t
= CALL_EXPR_ARG (inner
, 0);
8729 if (TREE_CODE (t
) == NOP_EXPR
)
8730 t
= TREE_OPERAND (t
, 0);
8731 if (TREE_CODE (t
) == ADDR_EXPR
)
8732 TREE_OPERAND (op
, 0) = TREE_OPERAND (t
, 0);
8734 TREE_OPERAND (op
, 0) = build_fold_indirect_ref (t
);
8740 return GS_UNHANDLED
;
8742 case VIEW_CONVERT_EXPR
:
8743 op
= TREE_OPERAND (expr
, 0);
8745 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
8746 type to a scalar one, explicitly create the local temporary. That's
8747 required if the type is passed by reference. */
8748 if ((TREE_CODE (op
) == CONSTRUCTOR
|| TREE_CODE (op
) == CALL_EXPR
)
8749 && AGGREGATE_TYPE_P (TREE_TYPE (op
))
8750 && !AGGREGATE_TYPE_P (type
))
8752 tree mod
, new_var
= create_tmp_var_raw (TREE_TYPE (op
), "C");
8753 gimple_add_tmp_var (new_var
);
8755 mod
= build2 (INIT_EXPR
, TREE_TYPE (new_var
), new_var
, op
);
8756 gimplify_and_add (mod
, pre_p
);
8758 TREE_OPERAND (expr
, 0) = new_var
;
8762 return GS_UNHANDLED
;
8765 op
= DECL_EXPR_DECL (expr
);
8767 /* The expressions for the RM bounds must be gimplified to ensure that
8768 they are properly elaborated. See gimplify_decl_expr. */
8769 if ((TREE_CODE (op
) == TYPE_DECL
|| TREE_CODE (op
) == VAR_DECL
)
8770 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op
)))
8771 switch (TREE_CODE (TREE_TYPE (op
)))
8778 tree type
= TYPE_MAIN_VARIANT (TREE_TYPE (op
)), t
, val
;
8780 val
= TYPE_RM_MIN_VALUE (type
);
8783 gimplify_one_sizepos (&val
, pre_p
);
8784 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
8785 SET_TYPE_RM_MIN_VALUE (t
, val
);
8788 val
= TYPE_RM_MAX_VALUE (type
);
8791 gimplify_one_sizepos (&val
, pre_p
);
8792 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
8793 SET_TYPE_RM_MAX_VALUE (t
, val
);
8803 /* ... fall through ... */
8806 return GS_UNHANDLED
;
8810 /* Generate GIMPLE in place for the statement at *STMT_P. */
8812 static enum gimplify_status
8813 gnat_gimplify_stmt (tree
*stmt_p
)
8815 tree stmt
= *stmt_p
;
8817 switch (TREE_CODE (stmt
))
8820 *stmt_p
= STMT_STMT_STMT (stmt
);
8825 tree gnu_start_label
= create_artificial_label (input_location
);
8826 tree gnu_cond
= LOOP_STMT_COND (stmt
);
8827 tree gnu_update
= LOOP_STMT_UPDATE (stmt
);
8828 tree gnu_end_label
= LOOP_STMT_LABEL (stmt
);
8830 /* Build the condition expression from the test, if any. */
8833 /* Deal with the optimization hints. */
8834 if (LOOP_STMT_IVDEP (stmt
))
8835 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8836 build_int_cst (integer_type_node
,
8837 annot_expr_ivdep_kind
),
8839 if (LOOP_STMT_NO_UNROLL (stmt
))
8840 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8841 build_int_cst (integer_type_node
,
8842 annot_expr_unroll_kind
),
8844 if (LOOP_STMT_UNROLL (stmt
))
8845 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8846 build_int_cst (integer_type_node
,
8847 annot_expr_unroll_kind
),
8848 build_int_cst (NULL_TREE
, USHRT_MAX
));
8849 if (LOOP_STMT_NO_VECTOR (stmt
))
8850 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8851 build_int_cst (integer_type_node
,
8852 annot_expr_no_vector_kind
),
8854 if (LOOP_STMT_VECTOR (stmt
))
8855 gnu_cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (gnu_cond
), gnu_cond
,
8856 build_int_cst (integer_type_node
,
8857 annot_expr_vector_kind
),
8861 = build3 (COND_EXPR
, void_type_node
, gnu_cond
, NULL_TREE
,
8862 build1 (GOTO_EXPR
, void_type_node
, gnu_end_label
));
8865 /* Set to emit the statements of the loop. */
8866 *stmt_p
= NULL_TREE
;
8868 /* We first emit the start label and then a conditional jump to the
8869 end label if there's a top condition, then the update if it's at
8870 the top, then the body of the loop, then a conditional jump to
8871 the end label if there's a bottom condition, then the update if
8872 it's at the bottom, and finally a jump to the start label and the
8873 definition of the end label. */
8874 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
8878 if (gnu_cond
&& !LOOP_STMT_BOTTOM_COND_P (stmt
))
8879 append_to_statement_list (gnu_cond
, stmt_p
);
8881 if (gnu_update
&& LOOP_STMT_TOP_UPDATE_P (stmt
))
8882 append_to_statement_list (gnu_update
, stmt_p
);
8884 append_to_statement_list (LOOP_STMT_BODY (stmt
), stmt_p
);
8886 if (gnu_cond
&& LOOP_STMT_BOTTOM_COND_P (stmt
))
8887 append_to_statement_list (gnu_cond
, stmt_p
);
8889 if (gnu_update
&& !LOOP_STMT_TOP_UPDATE_P (stmt
))
8890 append_to_statement_list (gnu_update
, stmt_p
);
8892 tree t
= build1 (GOTO_EXPR
, void_type_node
, gnu_start_label
);
8893 SET_EXPR_LOCATION (t
, DECL_SOURCE_LOCATION (gnu_end_label
));
8894 append_to_statement_list (t
, stmt_p
);
8896 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
8903 /* Build a statement to jump to the corresponding end label, then
8904 see if it needs to be conditional. */
8905 *stmt_p
= build1 (GOTO_EXPR
, void_type_node
, EXIT_STMT_LABEL (stmt
));
8906 if (EXIT_STMT_COND (stmt
))
8907 *stmt_p
= build3 (COND_EXPR
, void_type_node
,
8908 EXIT_STMT_COND (stmt
), *stmt_p
, alloc_stmt_list ());
8916 /* Force a reference to each of the entities in GNAT_PACKAGE recursively.
8918 This routine is exclusively called in type_annotate mode, to compute DDA
8919 information for types in withed units, for ASIS use. */
8922 elaborate_all_entities_for_package (Entity_Id gnat_package
)
8924 Entity_Id gnat_entity
;
8926 for (gnat_entity
= First_Entity (gnat_package
);
8927 Present (gnat_entity
);
8928 gnat_entity
= Next_Entity (gnat_entity
))
8930 const Entity_Kind kind
= Ekind (gnat_entity
);
8932 /* We are interested only in entities visible from the main unit. */
8933 if (!Is_Public (gnat_entity
))
8936 /* Skip stuff internal to the compiler. */
8937 if (Convention (gnat_entity
) == Convention_Intrinsic
)
8939 if (kind
== E_Operator
)
8941 if (IN (kind
, Subprogram_Kind
)
8942 && (Present (Alias (gnat_entity
))
8943 || Is_Intrinsic_Subprogram (gnat_entity
)))
8945 if (Is_Itype (gnat_entity
))
8948 /* Skip named numbers. */
8949 if (IN (kind
, Named_Kind
))
8952 /* Skip generic declarations. */
8953 if (IN (kind
, Generic_Unit_Kind
))
8956 /* Skip formal objects. */
8957 if (IN (kind
, Formal_Object_Kind
))
8960 /* Skip package bodies. */
8961 if (kind
== E_Package_Body
)
8964 /* Skip limited views that point back to the main unit. */
8965 if (IN (kind
, Incomplete_Kind
)
8966 && From_Limited_With (gnat_entity
)
8967 && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_entity
)))
8970 /* Skip types that aren't frozen. */
8971 if (IN (kind
, Type_Kind
) && !Is_Frozen (gnat_entity
))
8974 /* Recurse on real packages that aren't in the main unit. */
8975 if (kind
== E_Package
)
8977 if (No (Renamed_Entity (gnat_entity
))
8978 && !In_Extended_Main_Code_Unit (gnat_entity
))
8979 elaborate_all_entities_for_package (gnat_entity
);
8982 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
8986 /* Force a reference to each of the entities in packages withed by GNAT_NODE.
8987 Operate recursively but check that we aren't elaborating something more
8990 This routine is exclusively called in type_annotate mode, to compute DDA
8991 information for types in withed units, for ASIS use. */
8994 elaborate_all_entities (Node_Id gnat_node
)
8996 Entity_Id gnat_with_clause
;
8998 /* Process each unit only once. As we trace the context of all relevant
8999 units transitively, including generic bodies, we may encounter the
9000 same generic unit repeatedly. */
9001 if (!present_gnu_tree (gnat_node
))
9002 save_gnu_tree (gnat_node
, integer_zero_node
, true);
9004 /* Save entities in all context units. A body may have an implicit_with
9005 on its own spec, if the context includes a child unit, so don't save
9007 for (gnat_with_clause
= First (Context_Items (gnat_node
));
9008 Present (gnat_with_clause
);
9009 gnat_with_clause
= Next (gnat_with_clause
))
9010 if (Nkind (gnat_with_clause
) == N_With_Clause
9011 && !present_gnu_tree (Library_Unit (gnat_with_clause
))
9012 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
9014 Node_Id gnat_unit
= Library_Unit (gnat_with_clause
);
9015 Entity_Id gnat_entity
= Entity (Name (gnat_with_clause
));
9017 elaborate_all_entities (gnat_unit
);
9019 if (Ekind (gnat_entity
) == E_Package
9020 && No (Renamed_Entity (gnat_entity
)))
9021 elaborate_all_entities_for_package (gnat_entity
);
9023 else if (Ekind (gnat_entity
) == E_Generic_Package
)
9025 Node_Id gnat_body
= Corresponding_Body (Unit (gnat_unit
));
9027 /* Retrieve compilation unit node of generic body. */
9028 while (Present (gnat_body
)
9029 && Nkind (gnat_body
) != N_Compilation_Unit
)
9030 gnat_body
= Parent (gnat_body
);
9032 /* If body is available, elaborate its context. */
9033 if (Present (gnat_body
))
9034 elaborate_all_entities (gnat_body
);
9038 if (Nkind (Unit (gnat_node
)) == N_Package_Body
)
9039 elaborate_all_entities (Library_Unit (gnat_node
));
9042 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
9045 process_freeze_entity (Node_Id gnat_node
)
9047 const Entity_Id gnat_entity
= Entity (gnat_node
);
9048 const Entity_Kind kind
= Ekind (gnat_entity
);
9049 tree gnu_old
, gnu_new
;
9051 /* If this is a package, generate code for the package body, if any. */
9052 if (kind
== E_Package
)
9054 const Node_Id gnat_decl
= Parent (Declaration_Node (gnat_entity
));
9055 if (Present (Corresponding_Body (gnat_decl
)))
9056 insert_code_for (Parent (Corresponding_Body (gnat_decl
)));
9060 /* Don't do anything for class-wide types as they are always transformed
9061 into their root type. */
9062 if (kind
== E_Class_Wide_Type
)
9065 /* Check for an old definition if this isn't an object with address clause,
9066 since the saved GCC tree is the address expression in that case. */
9068 = present_gnu_tree (gnat_entity
) && No (Address_Clause (gnat_entity
))
9069 ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
9071 /* Don't do anything for subprograms that may have been elaborated before
9072 their freeze nodes. This can happen, for example, because of an inner
9073 call in an instance body or because of previous compilation of a spec
9074 for inlining purposes. */
9076 && ((TREE_CODE (gnu_old
) == FUNCTION_DECL
9077 && (kind
== E_Function
|| kind
== E_Procedure
))
9078 || (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_old
))
9079 && kind
== E_Subprogram_Type
)))
9082 /* If we have a non-dummy type old tree, we have nothing to do, except for
9083 aborting, since this node was never delayed as it should have been. We
9084 let this happen for concurrent types and their Corresponding_Record_Type,
9085 however, because each might legitimately be elaborated before its own
9086 freeze node, e.g. while processing the other. */
9088 && !(TREE_CODE (gnu_old
) == TYPE_DECL
9089 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
9091 gcc_assert (Is_Concurrent_Type (gnat_entity
)
9092 || (Is_Record_Type (gnat_entity
)
9093 && Is_Concurrent_Record_Type (gnat_entity
)));
9097 /* Reset the saved tree, if any, and elaborate the object or type for real.
9098 If there is a full view, elaborate it and use the result. And, if this
9099 is the root type of a class-wide type, reuse it for the latter. */
9102 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
9104 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9105 && Present (Full_View (gnat_entity
)))
9107 Entity_Id full_view
= Full_View (gnat_entity
);
9109 save_gnu_tree (full_view
, NULL_TREE
, false);
9111 if (Is_Private_Type (full_view
)
9112 && Present (Underlying_Full_View (full_view
)))
9114 full_view
= Underlying_Full_View (full_view
);
9115 save_gnu_tree (full_view
, NULL_TREE
, false);
9119 if (Is_Type (gnat_entity
)
9120 && Present (Class_Wide_Type (gnat_entity
))
9121 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
9122 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, false);
9125 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9126 && Present (Full_View (gnat_entity
)))
9128 Entity_Id full_view
= Full_View (gnat_entity
);
9130 if (Is_Private_Type (full_view
)
9131 && Present (Underlying_Full_View (full_view
)))
9132 full_view
= Underlying_Full_View (full_view
);
9134 gnu_new
= gnat_to_gnu_entity (full_view
, NULL_TREE
, true);
9136 /* Propagate back-annotations from full view to partial view. */
9137 if (Unknown_Alignment (gnat_entity
))
9138 Set_Alignment (gnat_entity
, Alignment (full_view
));
9140 if (Unknown_Esize (gnat_entity
))
9141 Set_Esize (gnat_entity
, Esize (full_view
));
9143 if (Unknown_RM_Size (gnat_entity
))
9144 Set_RM_Size (gnat_entity
, RM_Size (full_view
));
9146 /* The above call may have defined this entity (the simplest example
9147 of this is when we have a private enumeral type since the bounds
9148 will have the public view). */
9149 if (!present_gnu_tree (gnat_entity
))
9150 save_gnu_tree (gnat_entity
, gnu_new
, false);
9155 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
9156 && present_gnu_tree (Declaration_Node (gnat_entity
)))
9157 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
9159 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, true);
9162 if (Is_Type (gnat_entity
)
9163 && Present (Class_Wide_Type (gnat_entity
))
9164 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
9165 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, false);
9167 /* If we have an old type and we've made pointers to this type, update those
9168 pointers. If this is a Taft amendment type in the main unit, we need to
9169 mark the type as used since other units referencing it don't see the full
9170 declaration and, therefore, cannot mark it as used themselves. */
9173 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
9174 TREE_TYPE (gnu_new
));
9175 if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old
)))
9176 update_profiles_with (TREE_TYPE (gnu_old
));
9177 if (DECL_TAFT_TYPE_P (gnu_old
))
9178 used_types_insert (TREE_TYPE (gnu_new
));
9182 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
9183 We make two passes, one to elaborate anything other than bodies (but
9184 we declare a function if there was no spec). The second pass
9185 elaborates the bodies.
9187 GNAT_END_LIST gives the element in the list past the end. Normally,
9188 this is Empty, but can be First_Real_Statement for a
9189 Handled_Sequence_Of_Statements.
9191 We make a complete pass through both lists if PASS1P is true, then make
9192 the second pass over both lists if PASS2P is true. The lists usually
9193 correspond to the public and private parts of a package. */
9196 process_decls (List_Id gnat_decls
, List_Id gnat_decls2
,
9197 Node_Id gnat_end_list
, bool pass1p
, bool pass2p
)
9199 List_Id gnat_decl_array
[2];
9203 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
9206 for (i
= 0; i
<= 1; i
++)
9207 if (Present (gnat_decl_array
[i
]))
9208 for (gnat_decl
= First (gnat_decl_array
[i
]);
9209 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
9211 /* For package specs, we recurse inside the declarations,
9212 thus taking the two pass approach inside the boundary. */
9213 if (Nkind (gnat_decl
) == N_Package_Declaration
9214 && (Nkind (Specification (gnat_decl
)
9215 == N_Package_Specification
)))
9216 process_decls (Visible_Declarations (Specification (gnat_decl
)),
9217 Private_Declarations (Specification (gnat_decl
)),
9218 Empty
, true, false);
9220 /* Similarly for any declarations in the actions of a
9222 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
9224 process_freeze_entity (gnat_decl
);
9225 process_decls (Actions (gnat_decl
), Empty
, Empty
, true, false);
9228 /* Package bodies with freeze nodes get their elaboration deferred
9229 until the freeze node, but the code must be placed in the right
9230 place, so record the code position now. */
9231 else if (Nkind (gnat_decl
) == N_Package_Body
9232 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
9233 record_code_position (gnat_decl
);
9235 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
9236 && Present (Library_Unit (gnat_decl
))
9237 && Present (Freeze_Node
9240 (Library_Unit (gnat_decl
)))))))
9241 record_code_position
9242 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
9244 /* We defer most subprogram bodies to the second pass. */
9245 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
9247 if (Acts_As_Spec (gnat_decl
))
9249 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
9251 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
9252 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
9253 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, true);
9257 /* For bodies and stubs that act as their own specs, the entity
9258 itself must be elaborated in the first pass, because it may
9259 be used in other declarations. */
9260 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
9262 Node_Id gnat_subprog_id
9263 = Defining_Entity (Specification (gnat_decl
));
9265 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
9266 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
9267 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
9268 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, true);
9271 /* Concurrent stubs stand for the corresponding subprogram bodies,
9272 which are deferred like other bodies. */
9273 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
9274 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
9277 /* Renamed subprograms may not be elaborated yet at this point
9278 since renamings do not trigger freezing. Wait for the second
9279 pass to take care of them. */
9280 else if (Nkind (gnat_decl
) == N_Subprogram_Renaming_Declaration
)
9284 add_stmt (gnat_to_gnu (gnat_decl
));
9287 /* Here we elaborate everything we deferred above except for package bodies,
9288 which are elaborated at their freeze nodes. Note that we must also
9289 go inside things (package specs and freeze nodes) the first pass did. */
9291 for (i
= 0; i
<= 1; i
++)
9292 if (Present (gnat_decl_array
[i
]))
9293 for (gnat_decl
= First (gnat_decl_array
[i
]);
9294 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
9296 if (Nkind (gnat_decl
) == N_Subprogram_Body
9297 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
9298 || Nkind (gnat_decl
) == N_Task_Body_Stub
9299 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
9300 add_stmt (gnat_to_gnu (gnat_decl
));
9302 else if (Nkind (gnat_decl
) == N_Package_Declaration
9303 && (Nkind (Specification (gnat_decl
)
9304 == N_Package_Specification
)))
9305 process_decls (Visible_Declarations (Specification (gnat_decl
)),
9306 Private_Declarations (Specification (gnat_decl
)),
9307 Empty
, false, true);
9309 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
9310 process_decls (Actions (gnat_decl
), Empty
, Empty
, false, true);
9312 else if (Nkind (gnat_decl
) == N_Subprogram_Renaming_Declaration
)
9313 add_stmt (gnat_to_gnu (gnat_decl
));
9317 /* Make a unary operation of kind CODE using build_unary_op, but guard
9318 the operation by an overflow check. CODE can be one of NEGATE_EXPR
9319 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
9320 the operation is to be performed in that type. GNAT_NODE is the gnat
9321 node conveying the source location for which the error should be
9325 build_unary_op_trapv (enum tree_code code
, tree gnu_type
, tree operand
,
9328 gcc_assert (code
== NEGATE_EXPR
|| code
== ABS_EXPR
);
9330 operand
= gnat_protect_expr (operand
);
9332 return emit_check (build_binary_op (EQ_EXPR
, boolean_type_node
,
9333 operand
, TYPE_MIN_VALUE (gnu_type
)),
9334 build_unary_op (code
, gnu_type
, operand
),
9335 CE_Overflow_Check_Failed
, gnat_node
);
9338 /* Make a binary operation of kind CODE using build_binary_op, but guard
9339 the operation by an overflow check. CODE can be one of PLUS_EXPR,
9340 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
9341 Usually the operation is to be performed in that type. GNAT_NODE is
9342 the GNAT node conveying the source location for which the error should
9346 build_binary_op_trapv (enum tree_code code
, tree gnu_type
, tree left
,
9347 tree right
, Node_Id gnat_node
)
9349 const unsigned int precision
= TYPE_PRECISION (gnu_type
);
9350 tree lhs
= gnat_protect_expr (left
);
9351 tree rhs
= gnat_protect_expr (right
);
9352 tree type_max
= TYPE_MAX_VALUE (gnu_type
);
9353 tree type_min
= TYPE_MIN_VALUE (gnu_type
);
9354 tree gnu_expr
, check
;
9357 /* Assert that the precision is a power of 2. */
9358 gcc_assert ((precision
& (precision
- 1)) == 0);
9360 /* Prefer a constant on the RHS to simplify checks. */
9361 if (TREE_CODE (rhs
) != INTEGER_CST
9362 && TREE_CODE (lhs
) == INTEGER_CST
9363 && (code
== PLUS_EXPR
|| code
== MULT_EXPR
))
9370 gnu_expr
= build_binary_op (code
, gnu_type
, lhs
, rhs
);
9372 /* If we can fold the expression to a constant, just return it.
9373 The caller will deal with overflow, no need to generate a check. */
9374 if (TREE_CODE (gnu_expr
) == INTEGER_CST
)
9377 /* If no operand is a constant, we use the generic implementation. */
9378 if (TREE_CODE (lhs
) != INTEGER_CST
&& TREE_CODE (rhs
) != INTEGER_CST
)
9380 /* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
9381 if (code
== MULT_EXPR
&& precision
== 64 && BITS_PER_WORD
< 64)
9383 tree int64
= gnat_type_for_size (64, 0);
9384 return convert (gnu_type
, build_call_n_expr (mulv64_decl
, 2,
9385 convert (int64
, lhs
),
9386 convert (int64
, rhs
)));
9389 enum internal_fn icode
;
9394 icode
= IFN_ADD_OVERFLOW
;
9397 icode
= IFN_SUB_OVERFLOW
;
9400 icode
= IFN_MUL_OVERFLOW
;
9406 tree gnu_ctype
= build_complex_type (gnu_type
);
9408 = build_call_expr_internal_loc (UNKNOWN_LOCATION
, icode
, gnu_ctype
, 2,
9410 tree tgt
= save_expr (call
);
9411 gnu_expr
= build1 (REALPART_EXPR
, gnu_type
, tgt
);
9412 check
= fold_build2 (NE_EXPR
, boolean_type_node
,
9413 build1 (IMAGPART_EXPR
, gnu_type
, tgt
),
9414 build_int_cst (gnu_type
, 0));
9416 emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
9419 /* If one operand is a constant, we expose the overflow condition to enable
9420 a subsequent simplication or even elimination. */
9424 sgn
= tree_int_cst_sgn (rhs
);
9426 /* When rhs > 0, overflow when lhs > type_max - rhs. */
9427 check
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
9428 build_binary_op (MINUS_EXPR
, gnu_type
,
9431 /* When rhs < 0, overflow when lhs < type_min - rhs. */
9432 check
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
9433 build_binary_op (MINUS_EXPR
, gnu_type
,
9440 if (TREE_CODE (lhs
) == INTEGER_CST
)
9442 sgn
= tree_int_cst_sgn (lhs
);
9444 /* When lhs > 0, overflow when rhs < lhs - type_max. */
9445 check
= build_binary_op (LT_EXPR
, boolean_type_node
, rhs
,
9446 build_binary_op (MINUS_EXPR
, gnu_type
,
9449 /* When lhs < 0, overflow when rhs > lhs - type_min. */
9450 check
= build_binary_op (GT_EXPR
, boolean_type_node
, rhs
,
9451 build_binary_op (MINUS_EXPR
, gnu_type
,
9458 sgn
= tree_int_cst_sgn (rhs
);
9460 /* When rhs > 0, overflow when lhs < type_min + rhs. */
9461 check
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
9462 build_binary_op (PLUS_EXPR
, gnu_type
,
9465 /* When rhs < 0, overflow when lhs > type_max + rhs. */
9466 check
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
9467 build_binary_op (PLUS_EXPR
, gnu_type
,
9475 sgn
= tree_int_cst_sgn (rhs
);
9478 if (integer_onep (rhs
))
9481 tree lb
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
9482 tree ub
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
9484 /* When rhs > 1, overflow outside [type_min/rhs; type_max/rhs]. */
9486 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
9487 build_binary_op (LT_EXPR
, boolean_type_node
,
9489 build_binary_op (GT_EXPR
, boolean_type_node
,
9494 tree lb
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
9495 tree ub
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
9497 if (integer_minus_onep (rhs
))
9498 /* When rhs == -1, overflow if lhs == type_min. */
9500 = build_binary_op (EQ_EXPR
, boolean_type_node
, lhs
, type_min
);
9502 /* When rhs < -1, overflow outside [type_max/rhs; type_min/rhs]. */
9504 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
9505 build_binary_op (LT_EXPR
, boolean_type_node
,
9507 build_binary_op (GT_EXPR
, boolean_type_node
,
9518 return emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
9521 /* GNU_COND contains the condition corresponding to an index, overflow or
9522 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
9523 if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
9524 REASON is the code that says why the exception is raised. GNAT_NODE is
9525 the node conveying the source location for which the error should be
9528 We used to propagate TREE_SIDE_EFFECTS from GNU_EXPR to the COND_EXPR,
9529 overwriting the setting inherited from the call statement, on the ground
9530 that the expression need not be evaluated just for the check. However
9531 that's incorrect because, in the GCC type system, its value is presumed
9532 to be valid so its comparison against the type bounds always yields true
9533 and, therefore, could be done without evaluating it; given that it can
9534 be a computation that overflows the bounds, the language may require the
9535 check to fail and thus the expression to be evaluated in this case. */
9538 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
, Node_Id gnat_node
)
9541 = build_call_raise (reason
, gnat_node
, N_Raise_Constraint_Error
);
9543 fold_build3 (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
9544 build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_call
,
9545 SCALAR_FLOAT_TYPE_P (TREE_TYPE (gnu_expr
))
9546 ? build_real (TREE_TYPE (gnu_expr
), dconst0
)
9547 : build_int_cst (TREE_TYPE (gnu_expr
), 0)),
9551 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
9552 checks if OVERFLOW_P is true. If TRUNCATE_P is true, do a fp-to-integer
9553 conversion with truncation, otherwise round. GNAT_NODE is the GNAT node
9554 conveying the source location for which the error should be signaled. */
9557 convert_with_check (Entity_Id gnat_type
, tree gnu_expr
, bool overflow_p
,
9558 bool truncate_p
, Node_Id gnat_node
)
9560 tree gnu_type
= get_unpadded_type (gnat_type
);
9561 tree gnu_base_type
= get_base_type (gnu_type
);
9562 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
9563 tree gnu_in_base_type
= get_base_type (gnu_in_type
);
9564 tree gnu_result
= gnu_expr
;
9566 /* If we are not doing any checks, the output is an integral type and the
9567 input is not a floating-point type, just do the conversion. This is
9568 required for packed array types and is simpler in all cases anyway. */
9570 && INTEGRAL_TYPE_P (gnu_base_type
)
9571 && !FLOAT_TYPE_P (gnu_in_base_type
))
9572 return convert (gnu_type
, gnu_expr
);
9574 /* If the mode of the input base type is larger, then converting to it below
9575 may pessimize the final conversion step, for example generate a libcall
9576 instead of a simple instruction, so use a narrower type in this case. */
9577 if (TYPE_MODE (gnu_in_base_type
) != TYPE_MODE (gnu_in_type
)
9578 && !(TREE_CODE (gnu_in_type
) == INTEGER_TYPE
9579 && TYPE_BIASED_REPRESENTATION_P (gnu_in_type
)))
9580 gnu_in_base_type
= gnat_type_for_mode (TYPE_MODE (gnu_in_type
),
9581 TYPE_UNSIGNED (gnu_in_type
));
9583 /* First convert the expression to the base type. This will never generate
9584 code, but makes the tests below simpler. But don't do this if converting
9585 from an integer type to an unconstrained array type since then we need to
9586 get the bounds from the original (unpacked) type. */
9587 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
9588 gnu_result
= convert (gnu_in_base_type
, gnu_result
);
9590 /* If overflow checks are requested, we need to be sure the result will fit
9591 in the output base type. But don't do this if the input is integer and
9592 the output floating-point. */
9594 && !(FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_base_type
)))
9596 /* Ensure GNU_EXPR only gets evaluated once. */
9597 tree gnu_input
= gnat_protect_expr (gnu_result
);
9598 tree gnu_cond
= boolean_false_node
;
9599 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_base_type
);
9600 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_base_type
);
9601 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
9603 = (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
9604 && TYPE_MODULAR_P (gnu_base_type
))
9605 ? fold_build2 (MINUS_EXPR
, gnu_base_type
,
9606 TYPE_MODULUS (gnu_base_type
),
9607 build_int_cst (gnu_base_type
, 1))
9608 : TYPE_MAX_VALUE (gnu_base_type
);
9610 /* Convert the lower bounds to signed types, so we're sure we're
9611 comparing them properly. Likewise, convert the upper bounds
9612 to unsigned types. */
9613 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9614 && TYPE_UNSIGNED (gnu_in_base_type
))
9616 = convert (gnat_signed_type_for (gnu_in_base_type
), gnu_in_lb
);
9618 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9619 && !TYPE_UNSIGNED (gnu_in_base_type
))
9621 = convert (gnat_unsigned_type_for (gnu_in_base_type
), gnu_in_ub
);
9623 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
9625 = convert (gnat_signed_type_for (gnu_base_type
), gnu_out_lb
);
9627 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
9629 = convert (gnat_unsigned_type_for (gnu_base_type
), gnu_out_ub
);
9631 /* Check each bound separately and only if the result bound
9632 is tighter than the bound on the input type. Note that all the
9633 types are base types, so the bounds must be constant. Also,
9634 the comparison is done in the base type of the input, which
9635 always has the proper signedness. First check for input
9636 integer (which means output integer), output float (which means
9637 both float), or mixed, in which case we always compare.
9638 Note that we have to do the comparison which would *fail* in the
9639 case of an error since if it's an FP comparison and one of the
9640 values is a NaN or Inf, the comparison will fail. */
9641 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9642 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
9643 : (FLOAT_TYPE_P (gnu_base_type
)
9644 ? real_less (&TREE_REAL_CST (gnu_in_lb
),
9645 &TREE_REAL_CST (gnu_out_lb
))
9649 (build_binary_op (GE_EXPR
, boolean_type_node
,
9650 gnu_input
, convert (gnu_in_base_type
,
9653 if (INTEGRAL_TYPE_P (gnu_in_base_type
)
9654 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
9655 : (FLOAT_TYPE_P (gnu_base_type
)
9656 ? real_less (&TREE_REAL_CST (gnu_out_ub
),
9657 &TREE_REAL_CST (gnu_in_ub
))
9660 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, gnu_cond
,
9662 (build_binary_op (LE_EXPR
, boolean_type_node
,
9664 convert (gnu_in_base_type
,
9667 if (!integer_zerop (gnu_cond
))
9668 gnu_result
= emit_check (gnu_cond
, gnu_input
,
9669 CE_Overflow_Check_Failed
, gnat_node
);
9672 /* Now convert to the result base type. If this is a non-truncating
9673 float-to-integer conversion, round. */
9674 if (INTEGRAL_TYPE_P (gnu_base_type
)
9675 && FLOAT_TYPE_P (gnu_in_base_type
)
9678 REAL_VALUE_TYPE half_minus_pred_half
, pred_half
;
9679 tree gnu_conv
, gnu_zero
, gnu_comp
, calc_type
;
9680 tree gnu_pred_half
, gnu_add_pred_half
, gnu_subtract_pred_half
;
9681 const struct real_format
*fmt
;
9683 /* The following calculations depend on proper rounding to even
9684 of each arithmetic operation. In order to prevent excess
9685 precision from spoiling this property, use the widest hardware
9686 floating-point type if FP_ARITH_MAY_WIDEN is true. */
9688 = fp_arith_may_widen
? longest_float_type_node
: gnu_in_base_type
;
9690 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
9691 fmt
= REAL_MODE_FORMAT (TYPE_MODE (calc_type
));
9692 real_2expN (&half_minus_pred_half
, -(fmt
->p
) - 1, TYPE_MODE (calc_type
));
9693 real_arithmetic (&pred_half
, MINUS_EXPR
, &dconsthalf
,
9694 &half_minus_pred_half
);
9695 gnu_pred_half
= build_real (calc_type
, pred_half
);
9697 /* If the input is strictly negative, subtract this value
9698 and otherwise add it from the input. For 0.5, the result
9699 is exactly between 1.0 and the machine number preceding 1.0
9700 (for calc_type). Since the last bit of 1.0 is even, this 0.5
9701 will round to 1.0, while all other number with an absolute
9702 value less than 0.5 round to 0.0. For larger numbers exactly
9703 halfway between integers, rounding will always be correct as
9704 the true mathematical result will be closer to the higher
9705 integer compared to the lower one. So, this constant works
9706 for all floating-point numbers.
9708 The reason to use the same constant with subtract/add instead
9709 of a positive and negative constant is to allow the comparison
9710 to be scheduled in parallel with retrieval of the constant and
9711 conversion of the input to the calc_type (if necessary). */
9713 gnu_zero
= build_real (gnu_in_base_type
, dconst0
);
9714 gnu_result
= gnat_protect_expr (gnu_result
);
9715 gnu_conv
= convert (calc_type
, gnu_result
);
9717 = fold_build2 (GE_EXPR
, boolean_type_node
, gnu_result
, gnu_zero
);
9719 = fold_build2 (PLUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
9720 gnu_subtract_pred_half
9721 = fold_build2 (MINUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
9722 gnu_result
= fold_build3 (COND_EXPR
, calc_type
, gnu_comp
,
9723 gnu_add_pred_half
, gnu_subtract_pred_half
);
9726 if (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
9727 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type
)
9728 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
9729 gnu_result
= unchecked_convert (gnu_base_type
, gnu_result
, false);
9731 gnu_result
= convert (gnu_base_type
, gnu_result
);
9733 return convert (gnu_type
, gnu_result
);
9736 /* Return true if GNU_EXPR can be directly addressed. This is the case
9737 unless it is an expression involving computation or if it involves a
9738 reference to a bitfield or to an object not sufficiently aligned for
9739 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
9740 be directly addressed as an object of this type.
9742 *** Notes on addressability issues in the Ada compiler ***
9744 This predicate is necessary in order to bridge the gap between Gigi
9745 and the middle-end about addressability of GENERIC trees. A tree
9746 is said to be addressable if it can be directly addressed, i.e. if
9747 its address can be taken, is a multiple of the type's alignment on
9748 strict-alignment architectures and returns the first storage unit
9749 assigned to the object represented by the tree.
9751 In the C family of languages, everything is in practice addressable
9752 at the language level, except for bit-fields. This means that these
9753 compilers will take the address of any tree that doesn't represent
9754 a bit-field reference and expect the result to be the first storage
9755 unit assigned to the object. Even in cases where this will result
9756 in unaligned accesses at run time, nothing is supposed to be done
9757 and the program is considered as erroneous instead (see PR c/18287).
9759 The implicit assumptions made in the middle-end are in keeping with
9760 the C viewpoint described above:
9761 - the address of a bit-field reference is supposed to be never
9762 taken; the compiler (generally) will stop on such a construct,
9763 - any other tree is addressable if it is formally addressable,
9764 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
9766 In Ada, the viewpoint is the opposite one: nothing is addressable
9767 at the language level unless explicitly declared so. This means
9768 that the compiler will both make sure that the trees representing
9769 references to addressable ("aliased" in Ada parlance) objects are
9770 addressable and make no real attempts at ensuring that the trees
9771 representing references to non-addressable objects are addressable.
9773 In the first case, Ada is effectively equivalent to C and handing
9774 down the direct result of applying ADDR_EXPR to these trees to the
9775 middle-end works flawlessly. In the second case, Ada cannot afford
9776 to consider the program as erroneous if the address of trees that
9777 are not addressable is requested for technical reasons, unlike C;
9778 as a consequence, the Ada compiler must arrange for either making
9779 sure that this address is not requested in the middle-end or for
9780 compensating by inserting temporaries if it is requested in Gigi.
9782 The first goal can be achieved because the middle-end should not
9783 request the address of non-addressable trees on its own; the only
9784 exception is for the invocation of low-level block operations like
9785 memcpy, for which the addressability requirements are lower since
9786 the type's alignment can be disregarded. In practice, this means
9787 that Gigi must make sure that such operations cannot be applied to
9788 non-BLKmode bit-fields.
9790 The second goal is achieved by means of the addressable_p predicate,
9791 which computes whether a temporary must be inserted by Gigi when the
9792 address of a tree is requested; if so, the address of the temporary
9793 will be used in lieu of that of the original tree and some glue code
9794 generated to connect everything together. */
9797 addressable_p (tree gnu_expr
, tree gnu_type
)
9799 /* For an integral type, the size of the actual type of the object may not
9800 be greater than that of the expected type, otherwise an indirect access
9801 in the latter type wouldn't correctly set all the bits of the object. */
9803 && INTEGRAL_TYPE_P (gnu_type
)
9804 && smaller_form_type_p (gnu_type
, TREE_TYPE (gnu_expr
)))
9807 /* The size of the actual type of the object may not be smaller than that
9808 of the expected type, otherwise an indirect access in the latter type
9809 would be larger than the object. But only record types need to be
9810 considered in practice for this case. */
9812 && TREE_CODE (gnu_type
) == RECORD_TYPE
9813 && smaller_form_type_p (TREE_TYPE (gnu_expr
), gnu_type
))
9816 switch (TREE_CODE (gnu_expr
))
9822 /* All DECLs are addressable: if they are in a register, we can force
9826 case UNCONSTRAINED_ARRAY_REF
:
9828 /* Taking the address of a dereference yields the original pointer. */
9834 /* Taking the address yields a pointer to the constant pool. */
9838 /* Taking the address of a static constructor yields a pointer to the
9839 tree constant pool. */
9840 return TREE_STATIC (gnu_expr
) ? true : false;
9852 /* All rvalues are deemed addressable since taking their address will
9853 force a temporary to be created by the middle-end. */
9857 /* The address of a compound expression is that of its 2nd operand. */
9858 return addressable_p (TREE_OPERAND (gnu_expr
, 1), gnu_type
);
9861 /* We accept &COND_EXPR as soon as both operands are addressable and
9862 expect the outcome to be the address of the selected operand. */
9863 return (addressable_p (TREE_OPERAND (gnu_expr
, 1), NULL_TREE
)
9864 && addressable_p (TREE_OPERAND (gnu_expr
, 2), NULL_TREE
));
9867 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
9868 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
9869 the field is sufficiently aligned, in case it is subject
9870 to a pragma Component_Alignment. But we don't need to
9871 check the alignment of the containing record, as it is
9872 guaranteed to be not smaller than that of its most
9873 aligned field that is not a bit-field. */
9874 && (!STRICT_ALIGNMENT
9875 || DECL_ALIGN (TREE_OPERAND (gnu_expr
, 1))
9876 >= TYPE_ALIGN (TREE_TYPE (gnu_expr
))))
9877 /* The field of a padding record is always addressable. */
9878 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
9879 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
9881 case ARRAY_REF
: case ARRAY_RANGE_REF
:
9882 case REALPART_EXPR
: case IMAGPART_EXPR
:
9884 return addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
);
9887 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
9888 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
9890 case VIEW_CONVERT_EXPR
:
9892 /* This is addressable if we can avoid a copy. */
9893 tree type
= TREE_TYPE (gnu_expr
);
9894 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
9895 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
9896 && (!STRICT_ALIGNMENT
9897 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
9898 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
9899 || ((TYPE_MODE (type
) == BLKmode
9900 || TYPE_MODE (inner_type
) == BLKmode
)
9901 && (!STRICT_ALIGNMENT
9902 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
9903 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
9904 || TYPE_ALIGN_OK (type
)
9905 || TYPE_ALIGN_OK (inner_type
))))
9906 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
9914 /* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
9915 If a Freeze node exists for the entity, delay the bulk of the processing.
9916 Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
9919 process_type (Entity_Id gnat_entity
)
9922 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
9924 /* If we are to delay elaboration of this type, just do any elaboration
9925 needed for expressions within the declaration and make a dummy node
9926 for it and its Full_View (if any), in case something points to it.
9927 Do not do this if it has already been done (the only way that can
9928 happen is if the private completion is also delayed). */
9929 if (Present (Freeze_Node (gnat_entity
)))
9931 elaborate_entity (gnat_entity
);
9935 tree gnu_decl
= TYPE_STUB_DECL (make_dummy_type (gnat_entity
));
9936 save_gnu_tree (gnat_entity
, gnu_decl
, false);
9937 if (Is_Incomplete_Or_Private_Type (gnat_entity
)
9938 && Present (Full_View (gnat_entity
)))
9940 if (Has_Completion_In_Body (gnat_entity
))
9941 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
9942 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, false);
9949 /* If we saved away a dummy type for this node, it means that this made the
9950 type that corresponds to the full type of an incomplete type. Clear that
9951 type for now and then update the type in the pointers below. But, if the
9952 saved type is not dummy, it very likely means that we have a use before
9953 declaration for the type in the tree, what we really cannot handle. */
9956 gcc_assert (TREE_CODE (gnu_old
) == TYPE_DECL
9957 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)));
9959 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
9962 /* Now fully elaborate the type. */
9963 tree gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, true);
9964 gcc_assert (TREE_CODE (gnu_new
) == TYPE_DECL
);
9966 /* If we have an old type and we've made pointers to this type, update those
9967 pointers. If this is a Taft amendment type in the main unit, we need to
9968 mark the type as used since other units referencing it don't see the full
9969 declaration and, therefore, cannot mark it as used themselves. */
9972 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
9973 TREE_TYPE (gnu_new
));
9974 if (DECL_TAFT_TYPE_P (gnu_old
))
9975 used_types_insert (TREE_TYPE (gnu_new
));
9978 /* If this is a record type corresponding to a task or protected type
9979 that is a completion of an incomplete type, perform a similar update
9980 on the type. ??? Including protected types here is a guess. */
9981 if (Is_Record_Type (gnat_entity
)
9982 && Is_Concurrent_Record_Type (gnat_entity
)
9983 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
9986 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
9988 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
9990 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
9993 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
9994 TREE_TYPE (gnu_new
));
9998 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
9999 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
10000 associations that are from RECORD_TYPE. If we see an internal record, make
10001 a recursive call to fill it in as well. */
10004 extract_values (tree values
, tree record_type
)
10006 vec
<constructor_elt
, va_gc
> *v
= NULL
;
10009 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
10011 tree tem
, value
= NULL_TREE
;
10013 /* _Parent is an internal field, but may have values in the aggregate,
10014 so check for values first. */
10015 if ((tem
= purpose_member (field
, values
)))
10017 value
= TREE_VALUE (tem
);
10018 TREE_ADDRESSABLE (tem
) = 1;
10021 else if (DECL_INTERNAL_P (field
))
10023 value
= extract_values (values
, TREE_TYPE (field
));
10024 if (TREE_CODE (value
) == CONSTRUCTOR
10025 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value
)))
10029 /* If we have a record subtype, the names will match, but not the
10030 actual FIELD_DECLs. */
10031 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
10032 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
10034 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
10035 TREE_ADDRESSABLE (tem
) = 1;
10041 CONSTRUCTOR_APPEND_ELT (v
, field
, value
);
10044 return gnat_build_constructor (record_type
, v
);
10047 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
10048 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
10049 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
10052 assoc_to_constructor (Entity_Id gnat_entity
, Node_Id gnat_assoc
, tree gnu_type
)
10054 tree gnu_list
= NULL_TREE
, gnu_result
;
10056 /* We test for GNU_FIELD being empty in the case where a variant
10057 was the last thing since we don't take things off GNAT_ASSOC in
10058 that case. We check GNAT_ASSOC in case we have a variant, but it
10061 for (; Present (gnat_assoc
); gnat_assoc
= Next (gnat_assoc
))
10063 const Node_Id gnat_field
= First (Choices (gnat_assoc
));
10064 const Node_Id gnat_expr
= Expression (gnat_assoc
);
10065 tree gnu_field
= gnat_to_gnu_field_decl (Entity (gnat_field
));
10066 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
10068 /* The expander is supposed to put a single component selector name
10069 in every record component association. */
10070 gcc_assert (No (Next (gnat_field
)));
10072 /* Ignore discriminants that have Corresponding_Discriminants in tagged
10073 types since we'll be setting those fields in the parent subtype. */
10074 if (Ekind (Entity (gnat_field
)) == E_Discriminant
10075 && Present (Corresponding_Discriminant (Entity (gnat_field
)))
10076 && Is_Tagged_Type (Scope (Entity (gnat_field
))))
10079 /* Also ignore discriminants of Unchecked_Unions. */
10080 if (Ekind (Entity (gnat_field
)) == E_Discriminant
10081 && Is_Unchecked_Union (gnat_entity
))
10084 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
10086 /* Convert to the type of the field. */
10087 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
10089 /* Add the field and expression to the list. */
10090 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
10093 gnu_result
= extract_values (gnu_list
, gnu_type
);
10097 /* Verify that every entry in GNU_LIST was used. */
10098 for (; gnu_list
; gnu_list
= TREE_CHAIN (gnu_list
))
10099 gcc_assert (TREE_ADDRESSABLE (gnu_list
));
10105 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
10106 the first element of an array aggregate. It may itself be an aggregate.
10107 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate. */
10110 pos_to_constructor (Node_Id gnat_expr
, tree gnu_array_type
)
10112 tree gnu_index
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type
));
10113 vec
<constructor_elt
, va_gc
> *gnu_expr_vec
= NULL
;
10115 for (; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
10119 /* If the expression is itself an array aggregate then first build the
10120 innermost constructor if it is part of our array (multi-dimensional
10122 if (Nkind (gnat_expr
) == N_Aggregate
10123 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
10124 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
10125 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
10126 TREE_TYPE (gnu_array_type
));
10129 /* If the expression is a conversion to an unconstrained array type,
10130 skip it to avoid spilling to memory. */
10131 if (Nkind (gnat_expr
) == N_Type_Conversion
10132 && Is_Array_Type (Etype (gnat_expr
))
10133 && !Is_Constrained (Etype (gnat_expr
)))
10134 gnu_expr
= gnat_to_gnu (Expression (gnat_expr
));
10136 gnu_expr
= gnat_to_gnu (gnat_expr
);
10138 gigi_checking_assert (!Do_Range_Check (gnat_expr
));
10141 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec
, gnu_index
,
10142 convert (TREE_TYPE (gnu_array_type
), gnu_expr
));
10144 gnu_index
= int_const_binop (PLUS_EXPR
, gnu_index
,
10145 convert (TREE_TYPE (gnu_index
),
10146 integer_one_node
));
10149 return gnat_build_constructor (gnu_array_type
, gnu_expr_vec
);
10152 /* Process a N_Validate_Unchecked_Conversion node. */
10155 validate_unchecked_conversion (Node_Id gnat_node
)
10157 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
10158 tree gnu_target_type
= gnat_to_gnu_type (Target_Type (gnat_node
));
10160 /* If the target is a pointer type, see if we are either converting from a
10161 non-pointer or from a pointer to a type with a different alias set and
10162 warn if so, unless the pointer has been marked to alias everything. */
10163 if (POINTER_TYPE_P (gnu_target_type
)
10164 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type
))
10166 tree gnu_source_desig_type
= POINTER_TYPE_P (gnu_source_type
)
10167 ? TREE_TYPE (gnu_source_type
)
10169 tree gnu_target_desig_type
= TREE_TYPE (gnu_target_type
);
10170 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
10172 if (target_alias_set
!= 0
10173 && (!POINTER_TYPE_P (gnu_source_type
)
10174 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
10175 target_alias_set
)))
10177 post_error_ne ("?possible aliasing problem for type&",
10178 gnat_node
, Target_Type (gnat_node
));
10179 post_error ("\\?use -fno-strict-aliasing switch for references",
10181 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
10182 gnat_node
, Target_Type (gnat_node
));
10186 /* Likewise if the target is a fat pointer type, but we have no mechanism to
10187 mitigate the problem in this case, so we unconditionally warn. */
10188 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type
))
10190 tree gnu_source_desig_type
10191 = TYPE_IS_FAT_POINTER_P (gnu_source_type
)
10192 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type
)))
10194 tree gnu_target_desig_type
10195 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type
)));
10196 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
10198 if (target_alias_set
!= 0
10199 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type
)
10200 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
10201 target_alias_set
)))
10203 post_error_ne ("?possible aliasing problem for type&",
10204 gnat_node
, Target_Type (gnat_node
));
10205 post_error ("\\?use -fno-strict-aliasing switch for references",
10211 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a
10212 source code location and false if it doesn't. If CLEAR_COLUMN is
10213 true, set the column information to 0. If DECL is given and SLOC
10214 refers to a File with an instance, map DECL to that instance. */
10217 Sloc_to_locus (Source_Ptr Sloc
, location_t
*locus
, bool clear_column
,
10220 if (Sloc
== No_Location
)
10223 if (Sloc
<= Standard_Location
)
10225 *locus
= BUILTINS_LOCATION
;
10229 Source_File_Index file
= Get_Source_File_Index (Sloc
);
10230 Line_Number_Type line
= Get_Logical_Line_Number (Sloc
);
10231 Column_Number_Type column
= (clear_column
? 0 : Get_Column_Number (Sloc
));
10232 line_map_ordinary
*map
= LINEMAPS_ORDINARY_MAP_AT (line_table
, file
- 1);
10234 /* We can have zero if pragma Source_Reference is in effect. */
10238 /* Translate the location. */
10240 = linemap_position_for_line_and_column (line_table
, map
, line
, column
);
10242 if (file_map
&& file_map
[file
- 1].Instance
)
10243 decl_to_instance_map
->put (decl
, file_map
[file
- 1].Instance
);
10248 /* Return whether GNAT_NODE is a defining identifier for a renaming that comes
10249 from the parameter association for the instantiation of a generic. We do
10250 not want to emit source location for them: the code generated for their
10251 initialization is likely to disturb debugging. */
10254 renaming_from_instantiation_p (Node_Id gnat_node
)
10256 if (Nkind (gnat_node
) != N_Defining_Identifier
10257 || !Is_Object (gnat_node
)
10258 || Comes_From_Source (gnat_node
)
10259 || !Present (Renamed_Object (gnat_node
)))
10262 /* Get the object declaration of the renamed object, if any and if the
10263 renamed object is a mere identifier. */
10264 gnat_node
= Renamed_Object (gnat_node
);
10265 if (Nkind (gnat_node
) != N_Identifier
)
10268 gnat_node
= Parent (Entity (gnat_node
));
10269 return (Present (gnat_node
)
10270 && Nkind (gnat_node
) == N_Object_Declaration
10271 && Present (Corresponding_Generic_Association (gnat_node
)));
10274 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
10275 don't do anything if it doesn't correspond to a source location. And,
10276 if CLEAR_COLUMN is true, set the column information to 0. */
10279 set_expr_location_from_node (tree node
, Node_Id gnat_node
, bool clear_column
)
10283 /* Do not set a location for constructs likely to disturb debugging. */
10284 if (Nkind (gnat_node
) == N_Defining_Identifier
)
10286 if (Is_Type (gnat_node
) && Is_Actual_Subtype (gnat_node
))
10289 if (renaming_from_instantiation_p (gnat_node
))
10293 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
, clear_column
))
10296 SET_EXPR_LOCATION (node
, locus
);
10299 /* More elaborate version of set_expr_location_from_node to be used in more
10300 general contexts, for example the result of the translation of a generic
10304 set_gnu_expr_location_from_node (tree node
, Node_Id gnat_node
)
10306 /* Set the location information on the node if it is a real expression.
10307 References can be reused for multiple GNAT nodes and they would get
10308 the location information of their last use. Also make sure not to
10309 overwrite an existing location as it is probably more precise. */
10311 switch (TREE_CODE (node
))
10314 case NON_LVALUE_EXPR
:
10318 case COMPOUND_EXPR
:
10319 if (EXPR_P (TREE_OPERAND (node
, 1)))
10320 set_gnu_expr_location_from_node (TREE_OPERAND (node
, 1), gnat_node
);
10322 /* ... fall through ... */
10325 if (!REFERENCE_CLASS_P (node
) && !EXPR_HAS_LOCATION (node
))
10327 set_expr_location_from_node (node
, gnat_node
);
10328 set_end_locus_from_node (node
, gnat_node
);
10334 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
10335 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
10336 most sense. Return true if a sensible assignment was performed. */
10339 set_end_locus_from_node (tree gnu_node
, Node_Id gnat_node
)
10341 Node_Id gnat_end_label
;
10342 location_t end_locus
;
10344 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
10345 end_locus when there is one. We consider only GNAT nodes with a possible
10346 End_Label attached. If the End_Label actually was unassigned, fallback
10347 on the original node. We'd better assign an explicit sloc associated with
10348 the outer construct in any case. */
10350 switch (Nkind (gnat_node
))
10352 case N_Package_Body
:
10353 case N_Subprogram_Body
:
10354 case N_Block_Statement
:
10355 gnat_end_label
= End_Label (Handled_Statement_Sequence (gnat_node
));
10358 case N_Package_Declaration
:
10359 gnat_end_label
= End_Label (Specification (gnat_node
));
10366 if (Present (gnat_end_label
))
10367 gnat_node
= gnat_end_label
;
10369 /* Some expanded subprograms have neither an End_Label nor a Sloc
10370 attached. Notify that to callers. For a block statement with no
10371 End_Label, clear column information, so that the tree for a
10372 transient block does not receive the sloc of a source condition. */
10373 if (!Sloc_to_locus (Sloc (gnat_node
), &end_locus
,
10374 No (gnat_end_label
)
10375 && (Nkind (gnat_node
) == N_Block_Statement
)))
10378 switch (TREE_CODE (gnu_node
))
10381 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node
)) = end_locus
;
10384 case FUNCTION_DECL
:
10385 DECL_STRUCT_FUNCTION (gnu_node
)->function_end_locus
= end_locus
;
10393 /* Return a colon-separated list of encodings contained in encoded Ada
10396 static const char *
10397 extract_encoding (const char *name
)
10399 char *encoding
= (char *) ggc_alloc_atomic (strlen (name
));
10400 get_encoding (name
, encoding
);
10404 /* Extract the Ada name from an encoded name. */
10406 static const char *
10407 decode_name (const char *name
)
10409 char *decoded
= (char *) ggc_alloc_atomic (strlen (name
) * 2 + 60);
10410 __gnat_decode (name
, decoded
, 0);
10414 /* Post an error message. MSG is the error message, properly annotated.
10415 NODE is the node at which to post the error and the node to use for the
10416 '&' substitution. */
10419 post_error (const char *msg
, Node_Id node
)
10421 String_Template temp
;
10427 temp
.Low_Bound
= 1;
10428 temp
.High_Bound
= strlen (msg
);
10431 Error_Msg_N (sp
, node
);
10434 /* Similar to post_error, but NODE is the node at which to post the error and
10435 ENT is the node to use for the '&' substitution. */
10438 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
10440 String_Template temp
;
10446 temp
.Low_Bound
= 1;
10447 temp
.High_Bound
= strlen (msg
);
10450 Error_Msg_NE (sp
, node
, ent
);
10453 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
10456 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int num
)
10458 Error_Msg_Uint_1
= UI_From_Int (num
);
10459 post_error_ne (msg
, node
, ent
);
10462 /* Similar to post_error_ne, but T is a GCC tree representing the number to
10463 write. If T represents a constant, the text inside curly brackets in
10464 MSG will be output (presumably including a '^'). Otherwise it will not
10465 be output and the text inside square brackets will be output instead. */
10468 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
10470 char *new_msg
= XALLOCAVEC (char, strlen (msg
) + 1);
10471 char start_yes
, end_yes
, start_no
, end_no
;
10475 if (TREE_CODE (t
) == INTEGER_CST
)
10477 Error_Msg_Uint_1
= UI_From_gnu (t
);
10478 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
10481 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
10483 for (p
= msg
, q
= new_msg
; *p
; p
++)
10485 if (*p
== start_yes
)
10486 for (p
++; *p
!= end_yes
; p
++)
10488 else if (*p
== start_no
)
10489 for (p
++; *p
!= end_no
; p
++)
10497 post_error_ne (new_msg
, node
, ent
);
10500 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
10503 post_error_ne_tree_2 (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
,
10506 Error_Msg_Uint_2
= UI_From_Int (num
);
10507 post_error_ne_tree (msg
, node
, ent
, t
);
10510 /* Return a label to branch to for the exception type in KIND or Empty
10514 get_exception_label (char kind
)
10518 case N_Raise_Constraint_Error
:
10519 return gnu_constraint_error_label_stack
.last ();
10521 case N_Raise_Storage_Error
:
10522 return gnu_storage_error_label_stack
.last ();
10524 case N_Raise_Program_Error
:
10525 return gnu_program_error_label_stack
.last ();
10531 gcc_unreachable ();
10534 /* Return the decl for the current elaboration procedure. */
10537 get_elaboration_procedure (void)
10539 return gnu_elab_proc_stack
->last ();
10542 /* Return the controlling type of a dispatching subprogram. */
10545 get_controlling_type (Entity_Id subprog
)
10547 /* This is modeled on Expand_Interface_Thunk. */
10548 Entity_Id controlling_type
= Etype (First_Formal (subprog
));
10549 if (Is_Access_Type (controlling_type
))
10550 controlling_type
= Directly_Designated_Type (controlling_type
);
10551 controlling_type
= Underlying_Type (controlling_type
);
10552 if (Is_Concurrent_Type (controlling_type
))
10553 controlling_type
= Corresponding_Record_Type (controlling_type
);
10554 controlling_type
= Base_Type (controlling_type
);
10555 return controlling_type
;
10558 /* Return whether we should use an alias for the TARGET of a thunk
10559 in order to make the call generated in the thunk local. */
10562 use_alias_for_thunk_p (tree target
)
10564 /* We cannot generate a local call in this case. */
10565 if (DECL_EXTERNAL (target
))
10568 /* The call is already local in this case. */
10569 if (TREE_CODE (DECL_CONTEXT (target
)) == FUNCTION_DECL
)
10572 return TARGET_USE_LOCAL_THUNK_ALIAS_P (target
);
10575 static GTY(()) unsigned long thunk_labelno
= 0;
10577 /* Create an alias for TARGET to be used as the target of a thunk. */
10580 make_alias_for_thunk (tree target
)
10583 targetm
.asm_out
.generate_internal_label (buf
, "LTHUNK", thunk_labelno
++);
10585 tree alias
= build_decl (DECL_SOURCE_LOCATION (target
), TREE_CODE (target
),
10586 get_identifier (buf
), TREE_TYPE (target
));
10588 DECL_LANG_SPECIFIC (alias
) = DECL_LANG_SPECIFIC (target
);
10589 DECL_CONTEXT (alias
) = DECL_CONTEXT (target
);
10590 TREE_READONLY (alias
) = TREE_READONLY (target
);
10591 TREE_THIS_VOLATILE (alias
) = TREE_THIS_VOLATILE (target
);
10592 DECL_ARTIFICIAL (alias
) = 1;
10593 DECL_INITIAL (alias
) = error_mark_node
;
10594 DECL_ARGUMENTS (alias
) = copy_list (DECL_ARGUMENTS (target
));
10595 TREE_ADDRESSABLE (alias
) = 1;
10596 SET_DECL_ASSEMBLER_NAME (alias
, DECL_NAME (alias
));
10598 cgraph_node
*n
= cgraph_node::create_same_body_alias (alias
, target
);
10604 /* Create the covariant part of the {GNAT,GNU}_THUNK. */
10607 make_covariant_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
)
10609 tree gnu_name
= create_concat_name (gnat_thunk
, "CV");
10611 = build_decl (DECL_SOURCE_LOCATION (gnu_thunk
), TREE_CODE (gnu_thunk
),
10612 gnu_name
, TREE_TYPE (gnu_thunk
));
10614 DECL_ARGUMENTS (gnu_cv_thunk
) = copy_list (DECL_ARGUMENTS (gnu_thunk
));
10615 DECL_RESULT (gnu_cv_thunk
) = copy_node (DECL_RESULT (gnu_thunk
));
10616 DECL_CONTEXT (DECL_RESULT (gnu_cv_thunk
)) = gnu_cv_thunk
;
10618 DECL_LANG_SPECIFIC (gnu_cv_thunk
) = DECL_LANG_SPECIFIC (gnu_thunk
);
10619 DECL_CONTEXT (gnu_cv_thunk
) = DECL_CONTEXT (gnu_thunk
);
10620 TREE_READONLY (gnu_cv_thunk
) = TREE_READONLY (gnu_thunk
);
10621 TREE_THIS_VOLATILE (gnu_cv_thunk
) = TREE_THIS_VOLATILE (gnu_thunk
);
10622 TREE_PUBLIC (gnu_cv_thunk
) = TREE_PUBLIC (gnu_thunk
);
10623 DECL_ARTIFICIAL (gnu_cv_thunk
) = 1;
10625 return gnu_cv_thunk
;
10628 /* Try to create a GNU thunk for {GNAT,GNU}_THUNK and return true on success.
10630 GNU thunks are more efficient than GNAT thunks because they don't call into
10631 the runtime to retrieve the offset used in the displacement operation, but
10632 they are tailored to C++ and thus too limited to support the full range of
10633 thunks generated in Ada. Here's the complete list of limitations:
10635 1. Multi-controlling thunks, i.e thunks with more than one controlling
10636 parameter, are simply not supported.
10638 2. Covariant thunks, i.e. thunks for which the result is also controlling,
10639 are split into a pair of (this, covariant-only) thunks.
10641 3. Variable-offset thunks, i.e. thunks for which the offset depends on the
10642 object and not only on its type, are supported as 2nd class citizens.
10644 4. External thunks, i.e. thunks for which the target is not declared in
10645 the same unit as the thunk, are supported as 2nd class citizens.
10647 5. Local thunks, i.e. thunks generated for a local type, are supported as
10648 2nd class citizens. */
10651 maybe_make_gnu_thunk (Entity_Id gnat_thunk
, tree gnu_thunk
)
10653 const Entity_Id gnat_target
= Thunk_Entity (gnat_thunk
);
10655 /* Check that the first formal of the target is the only controlling one. */
10656 Entity_Id gnat_formal
= First_Formal (gnat_target
);
10657 if (!Is_Controlling_Formal (gnat_formal
))
10659 for (gnat_formal
= Next_Formal (gnat_formal
);
10660 Present (gnat_formal
);
10661 gnat_formal
= Next_Formal (gnat_formal
))
10662 if (Is_Controlling_Formal (gnat_formal
))
10665 /* Look for the types that control the target and the thunk. */
10666 const Entity_Id gnat_controlling_type
= get_controlling_type (gnat_target
);
10667 const Entity_Id gnat_interface_type
= get_controlling_type (gnat_thunk
);
10669 /* We must have an interface type at this point. */
10670 gcc_assert (Is_Interface (gnat_interface_type
));
10672 /* Now compute whether the former covers the latter. */
10673 const Entity_Id gnat_interface_tag
10674 = Find_Interface_Tag (gnat_controlling_type
, gnat_interface_type
);
10675 tree gnu_interface_tag
10676 = Present (gnat_interface_tag
)
10677 ? gnat_to_gnu_field_decl (gnat_interface_tag
)
10679 tree gnu_interface_offset
10680 = gnu_interface_tag
? byte_position (gnu_interface_tag
) : NULL_TREE
;
10682 /* There are three ways to retrieve the offset between the interface view
10683 and the base object. Either the controlling type covers the interface
10684 type and the offset of the corresponding tag is fixed, in which case it
10685 can be statically encoded in the thunk (see FIXED_OFFSET below). Or the
10686 controlling type doesn't cover the interface type but is of fixed size,
10687 in which case the offset is stored in the dispatch table, two pointers
10688 above the dispatch table address (see VIRTUAL_VALUE below). Otherwise,
10689 the offset is variable and is stored right after the tag in every object
10690 (see INDIRECT_OFFSET below). See also a-tags.ads for more details. */
10691 HOST_WIDE_INT fixed_offset
, virtual_value
, indirect_offset
;
10692 tree virtual_offset
;
10694 if (gnu_interface_offset
&& TREE_CODE (gnu_interface_offset
) == INTEGER_CST
)
10696 fixed_offset
= - tree_to_shwi (gnu_interface_offset
);
10698 virtual_offset
= NULL_TREE
;
10699 indirect_offset
= 0;
10701 else if (!gnu_interface_offset
10702 && !Is_Variable_Size_Record (gnat_controlling_type
))
10705 virtual_value
= - 2 * (HOST_WIDE_INT
) (POINTER_SIZE
/ BITS_PER_UNIT
);
10706 virtual_offset
= build_int_cst (integer_type_node
, virtual_value
);
10707 indirect_offset
= 0;
10711 /* Covariant thunks with variable offset are not supported. */
10712 if (Has_Controlling_Result (gnat_target
))
10717 virtual_offset
= NULL_TREE
;
10718 indirect_offset
= (HOST_WIDE_INT
) (POINTER_SIZE
/ BITS_PER_UNIT
);
10721 tree gnu_target
= gnat_to_gnu_entity (gnat_target
, NULL_TREE
, false);
10723 /* Thunk and target must have the same nesting level, if any. */
10724 gcc_assert (DECL_CONTEXT (gnu_thunk
) == DECL_CONTEXT (gnu_target
));
10726 /* If the target returns by invisible reference and is external, apply the
10727 same transformation as Subprogram_Body_to_gnu here. */
10728 if (TREE_ADDRESSABLE (TREE_TYPE (gnu_target
))
10729 && DECL_EXTERNAL (gnu_target
)
10730 && !POINTER_TYPE_P (TREE_TYPE (DECL_RESULT (gnu_target
))))
10732 TREE_TYPE (DECL_RESULT (gnu_target
))
10733 = build_reference_type (TREE_TYPE (DECL_RESULT (gnu_target
)));
10734 relayout_decl (DECL_RESULT (gnu_target
));
10737 /* The thunk expander requires the return types of thunk and target to be
10738 compatible, which is not fully the case with the CICO mechanism. */
10739 if (TYPE_CI_CO_LIST (TREE_TYPE (gnu_thunk
)))
10741 tree gnu_target_type
= TREE_TYPE (gnu_target
);
10742 gcc_assert (TYPE_CI_CO_LIST (gnu_target_type
));
10743 TYPE_CANONICAL (TREE_TYPE (TREE_TYPE (gnu_thunk
)))
10744 = TYPE_CANONICAL (TREE_TYPE (gnu_target_type
));
10747 cgraph_node
*target_node
= cgraph_node::get_create (gnu_target
);
10749 /* If the return type of the target is a controlling type, then we need
10750 both an usual this thunk and a covariant thunk in this order:
10752 this thunk --> covariant thunk --> target
10754 For covariant thunks, we can only handle a fixed offset. */
10755 if (Has_Controlling_Result (gnat_target
))
10757 gcc_assert (fixed_offset
< 0);
10758 tree gnu_cv_thunk
= make_covariant_thunk (gnat_thunk
, gnu_thunk
);
10759 target_node
->create_thunk (gnu_cv_thunk
, gnu_target
, false,
10760 - fixed_offset
, 0, 0,
10761 NULL_TREE
, gnu_target
);
10763 gnu_target
= gnu_cv_thunk
;
10766 /* We may also need to create an alias for the target in order to make
10767 the call local, depending on the linkage of the target. */
10768 tree gnu_alias
= use_alias_for_thunk_p (gnu_target
)
10769 ? make_alias_for_thunk (gnu_target
)
10772 target_node
->create_thunk (gnu_thunk
, gnu_target
, true,
10773 fixed_offset
, virtual_value
, indirect_offset
,
10774 virtual_offset
, gnu_alias
);
10779 /* Initialize the table that maps GNAT codes to GCC codes for simple
10780 binary and unary operations. */
10783 init_code_table (void)
10785 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
10786 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
10787 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
10788 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
10789 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
10790 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
10791 gnu_codes
[N_Op_Le
] = LE_EXPR
;
10792 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
10793 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
10794 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
10795 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
10796 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
10797 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
10798 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
10799 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
10800 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
10801 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
10802 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
10803 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
10804 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
10805 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
10806 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
10807 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
10808 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
10811 #include "gt-ada-trans.h"