1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2013, 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"
34 #include "libfuncs.h" /* For set_stack_check_libfunc. */
35 #include "tree-iterator.h"
39 #include "diagnostic.h"
42 #include "common/common-target.h"
45 #include "adadecode.h"
62 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
63 for fear of running out of stack space. If we need more, we use xmalloc
65 #define ALLOCA_THRESHOLD 1000
67 /* Let code below know whether we are targetting VMS without need of
68 intrusive preprocessor directives. */
69 #ifndef TARGET_ABI_OPEN_VMS
70 #define TARGET_ABI_OPEN_VMS 0
73 /* In configurations where blocks have no end_locus attached, just
74 sink assignments into a dummy global. */
75 #ifndef BLOCK_SOURCE_END_LOCATION
76 static location_t block_end_locus_sink
;
77 #define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink
80 /* For efficient float-to-int rounding, it is necessary to know whether
81 floating-point arithmetic may use wider intermediate results. When
82 FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
83 that arithmetic does not widen if double precision is emulated. */
84 #ifndef FP_ARITH_MAY_WIDEN
85 #if defined(HAVE_extendsfdf2)
86 #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
88 #define FP_ARITH_MAY_WIDEN 0
92 /* Pointers to front-end tables accessed through macros. */
93 struct Node
*Nodes_Ptr
;
94 Node_Id
*Next_Node_Ptr
;
95 Node_Id
*Prev_Node_Ptr
;
96 struct Elist_Header
*Elists_Ptr
;
97 struct Elmt_Item
*Elmts_Ptr
;
98 struct String_Entry
*Strings_Ptr
;
99 Char_Code
*String_Chars_Ptr
;
100 struct List_Header
*List_Headers_Ptr
;
102 /* Highest number in the front-end node table. */
105 /* Current node being treated, in case abort called. */
106 Node_Id error_gnat_node
;
108 /* True when gigi is being called on an analyzed but unexpanded
109 tree, and the only purpose of the call is to properly annotate
110 types with representation information. */
111 bool type_annotate_only
;
113 /* Current filename without path. */
114 const char *ref_filename
;
117 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
118 static vec
<Node_Id
> gnat_validate_uc_list
;
120 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
121 of unconstrained array IN parameters to avoid emitting a great deal of
122 redundant instructions to recompute them each time. */
123 struct GTY (()) parm_attr_d
{
124 int id
; /* GTY doesn't like Entity_Id. */
131 typedef struct parm_attr_d
*parm_attr
;
134 struct GTY(()) language_function
{
135 vec
<parm_attr
, va_gc
> *parm_attr_cache
;
136 bitmap named_ret_val
;
137 vec
<tree
, va_gc
> *other_ret_val
;
141 #define f_parm_attr_cache \
142 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
144 #define f_named_ret_val \
145 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
147 #define f_other_ret_val \
148 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
151 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
153 /* A structure used to gather together information about a statement group.
154 We use this to gather related statements, for example the "then" part
155 of a IF. In the case where it represents a lexical scope, we may also
156 have a BLOCK node corresponding to it and/or cleanups. */
158 struct GTY((chain_next ("%h.previous"))) stmt_group
{
159 struct stmt_group
*previous
; /* Previous code group. */
160 tree stmt_list
; /* List of statements for this code group. */
161 tree block
; /* BLOCK for this code group, if any. */
162 tree cleanups
; /* Cleanups for this code group, if any. */
165 static GTY(()) struct stmt_group
*current_stmt_group
;
167 /* List of unused struct stmt_group nodes. */
168 static GTY((deletable
)) struct stmt_group
*stmt_group_free_list
;
170 /* A structure used to record information on elaboration procedures
171 we've made and need to process.
173 ??? gnat_node should be Node_Id, but gengtype gets confused. */
175 struct GTY((chain_next ("%h.next"))) elab_info
{
176 struct elab_info
*next
; /* Pointer to next in chain. */
177 tree elab_proc
; /* Elaboration procedure. */
178 int gnat_node
; /* The N_Compilation_Unit. */
181 static GTY(()) struct elab_info
*elab_info_list
;
183 /* Stack of exception pointer variables. Each entry is the VAR_DECL
184 that stores the address of the raised exception. Nonzero means we
185 are in an exception handler. Not used in the zero-cost case. */
186 static GTY(()) vec
<tree
, va_gc
> *gnu_except_ptr_stack
;
188 /* In ZCX case, current exception pointer. Used to re-raise it. */
189 static GTY(()) tree gnu_incoming_exc_ptr
;
191 /* Stack for storing the current elaboration procedure decl. */
192 static GTY(()) vec
<tree
, va_gc
> *gnu_elab_proc_stack
;
194 /* Stack of labels to be used as a goto target instead of a return in
195 some functions. See processing for N_Subprogram_Body. */
196 static GTY(()) vec
<tree
, va_gc
> *gnu_return_label_stack
;
198 /* Stack of variable for the return value of a function with copy-in/copy-out
199 parameters. See processing for N_Subprogram_Body. */
200 static GTY(()) vec
<tree
, va_gc
> *gnu_return_var_stack
;
202 /* Structure used to record information for a range check. */
203 struct GTY(()) range_check_info_d
{
210 typedef struct range_check_info_d
*range_check_info
;
213 /* Structure used to record information for a loop. */
214 struct GTY(()) loop_info_d
{
217 vec
<range_check_info
, va_gc
> *checks
;
220 typedef struct loop_info_d
*loop_info
;
223 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
224 static GTY(()) vec
<loop_info
, va_gc
> *gnu_loop_stack
;
226 /* The stacks for N_{Push,Pop}_*_Label. */
227 static GTY(()) vec
<tree
, va_gc
> *gnu_constraint_error_label_stack
;
228 static GTY(()) vec
<tree
, va_gc
> *gnu_storage_error_label_stack
;
229 static GTY(()) vec
<tree
, va_gc
> *gnu_program_error_label_stack
;
231 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
232 static enum tree_code gnu_codes
[Number_Node_Kinds
];
234 static void init_code_table (void);
235 static void Compilation_Unit_to_gnu (Node_Id
);
236 static void record_code_position (Node_Id
);
237 static void insert_code_for (Node_Id
);
238 static void add_cleanup (tree
, Node_Id
);
239 static void add_stmt_list (List_Id
);
240 static void push_exception_label_stack (vec
<tree
, va_gc
> **, Entity_Id
);
241 static tree
build_stmt_group (List_Id
, bool);
242 static inline bool stmt_group_may_fallthru (void);
243 static enum gimplify_status
gnat_gimplify_stmt (tree
*);
244 static void elaborate_all_entities (Node_Id
);
245 static void process_freeze_entity (Node_Id
);
246 static void process_decls (List_Id
, List_Id
, Node_Id
, bool, bool);
247 static tree
emit_range_check (tree
, Node_Id
, Node_Id
);
248 static tree
emit_index_check (tree
, tree
, tree
, tree
, Node_Id
);
249 static tree
emit_check (tree
, tree
, int, Node_Id
);
250 static tree
build_unary_op_trapv (enum tree_code
, tree
, tree
, Node_Id
);
251 static tree
build_binary_op_trapv (enum tree_code
, tree
, tree
, tree
, Node_Id
);
252 static tree
convert_with_check (Entity_Id
, tree
, bool, bool, bool, Node_Id
);
253 static bool addressable_p (tree
, tree
);
254 static tree
assoc_to_constructor (Entity_Id
, Node_Id
, tree
);
255 static tree
extract_values (tree
, tree
);
256 static tree
pos_to_constructor (Node_Id
, tree
, Entity_Id
);
257 static void validate_unchecked_conversion (Node_Id
);
258 static tree
maybe_implicit_deref (tree
);
259 static void set_expr_location_from_node (tree
, Node_Id
);
260 static bool set_end_locus_from_node (tree
, Node_Id
);
261 static void set_gnu_expr_location_from_node (tree
, Node_Id
);
262 static int lvalue_required_p (Node_Id
, tree
, bool, bool, bool);
263 static tree
build_raise_check (int, enum exception_info_kind
);
264 static tree
create_init_temporary (const char *, tree
, tree
*, Node_Id
);
266 /* Hooks for debug info back-ends, only supported and used in a restricted set
267 of configurations. */
268 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED
;
269 static const char *decode_name (const char *) ATTRIBUTE_UNUSED
;
271 /* This is the main program of the back-end. It sets up all the table
272 structures and then generates code. */
275 gigi (Node_Id gnat_root
, int max_gnat_node
, int number_name ATTRIBUTE_UNUSED
,
276 struct Node
*nodes_ptr
, Node_Id
*next_node_ptr
, Node_Id
*prev_node_ptr
,
277 struct Elist_Header
*elists_ptr
, struct Elmt_Item
*elmts_ptr
,
278 struct String_Entry
*strings_ptr
, Char_Code
*string_chars_ptr
,
279 struct List_Header
*list_headers_ptr
, Nat number_file
,
280 struct File_Info_Type
*file_info_ptr
,
281 Entity_Id standard_boolean
, Entity_Id standard_integer
,
282 Entity_Id standard_character
, Entity_Id standard_long_long_float
,
283 Entity_Id standard_exception_type
, Int gigi_operating_mode
)
286 Entity_Id gnat_literal
;
287 tree long_long_float_type
, exception_type
, t
, ftype
;
288 tree int64_type
= gnat_type_for_size (64, 0);
289 struct elab_info
*info
;
291 #ifdef ORDINARY_MAP_INSTANCE
292 struct line_map
*map
;
295 max_gnat_nodes
= max_gnat_node
;
297 Nodes_Ptr
= nodes_ptr
;
298 Next_Node_Ptr
= next_node_ptr
;
299 Prev_Node_Ptr
= prev_node_ptr
;
300 Elists_Ptr
= elists_ptr
;
301 Elmts_Ptr
= elmts_ptr
;
302 Strings_Ptr
= strings_ptr
;
303 String_Chars_Ptr
= string_chars_ptr
;
304 List_Headers_Ptr
= list_headers_ptr
;
306 type_annotate_only
= (gigi_operating_mode
== 1);
308 /* ??? Disable the generation of the SCO instance table until after the
309 back-end supports instance based debug info discriminators. */
310 Generate_SCO_Instance_Table
= False
;
312 for (i
= 0; i
< number_file
; i
++)
314 /* Use the identifier table to make a permanent copy of the filename as
315 the name table gets reallocated after Gigi returns but before all the
316 debugging information is output. The __gnat_to_canonical_file_spec
317 call translates filenames from pragmas Source_Reference that contain
318 host style syntax not understood by gdb. */
322 (__gnat_to_canonical_file_spec
323 (Get_Name_String (file_info_ptr
[i
].File_Name
))));
325 /* We rely on the order isomorphism between files and line maps. */
326 gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table
) == i
);
328 /* We create the line map for a source file at once, with a fixed number
329 of columns chosen to avoid jumping over the next power of 2. */
330 linemap_add (line_table
, LC_ENTER
, 0, filename
, 1);
331 #ifdef ORDINARY_MAP_INSTANCE
332 map
= LINEMAPS_ORDINARY_MAP_AT (line_table
, i
);
333 if (flag_debug_instances
)
334 ORDINARY_MAP_INSTANCE (map
) = file_info_ptr
[i
].Instance
;
336 linemap_line_start (line_table
, file_info_ptr
[i
].Num_Source_Lines
, 252);
337 linemap_position_for_column (line_table
, 252 - 1);
338 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
341 gcc_assert (Nkind (gnat_root
) == N_Compilation_Unit
);
343 /* Declare the name of the compilation unit as the first global
344 name in order to make the middle-end fully deterministic. */
345 t
= create_concat_name (Defining_Entity (Unit (gnat_root
)), NULL
);
346 first_global_object_name
= ggc_strdup (IDENTIFIER_POINTER (t
));
348 /* Initialize ourselves. */
352 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
354 if (type_annotate_only
)
356 TYPE_SIZE (void_type_node
) = bitsize_zero_node
;
357 TYPE_SIZE_UNIT (void_type_node
) = size_zero_node
;
360 /* Enable GNAT stack checking method if needed */
361 if (!Stack_Check_Probes_On_Target
)
362 set_stack_check_libfunc ("_gnat_stack_check");
364 /* Retrieve alignment settings. */
365 double_float_alignment
= get_target_double_float_alignment ();
366 double_scalar_alignment
= get_target_double_scalar_alignment ();
368 /* Record the builtin types. Define `integer' and `character' first so that
369 dbx will output them first. */
370 record_builtin_type ("integer", integer_type_node
, false);
371 record_builtin_type ("character", unsigned_char_type_node
, false);
372 record_builtin_type ("boolean", boolean_type_node
, false);
373 record_builtin_type ("void", void_type_node
, false);
375 /* Save the type we made for integer as the type for Standard.Integer. */
376 save_gnu_tree (Base_Type (standard_integer
),
377 TYPE_NAME (integer_type_node
),
380 /* Likewise for character as the type for Standard.Character. */
381 save_gnu_tree (Base_Type (standard_character
),
382 TYPE_NAME (unsigned_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,
395 DECL_IGNORED_P (t
) = 1;
396 save_gnu_tree (gnat_literal
, t
, false);
397 gnat_literal
= Next_Literal (gnat_literal
);
398 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
399 gcc_assert (t
== boolean_true_node
);
400 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
401 boolean_type_node
, t
, true, false, false, false,
403 DECL_IGNORED_P (t
) = 1;
404 save_gnu_tree (gnat_literal
, t
, false);
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. */
410 ftype
= build_function_type_list (ptr_void_type_node
, sizetype
, NULL_TREE
);
412 /* malloc is a function declaration tree for a function to allocate
415 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE
,
416 ftype
, NULL_TREE
, is_disabled
, true, true, true,
418 DECL_IS_MALLOC (malloc_decl
) = 1;
420 /* malloc32 is a function declaration tree for a function to allocate
421 32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */
423 = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE
,
424 ftype
, NULL_TREE
, is_disabled
, true, true, true,
426 DECL_IS_MALLOC (malloc32_decl
) = 1;
428 /* free is a function declaration tree for a function to free memory. */
430 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
431 build_function_type_list (void_type_node
,
434 NULL_TREE
, is_disabled
, true, true, true, NULL
,
437 /* This is used for 64-bit multiplication with overflow checking. */
439 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE
,
440 build_function_type_list (int64_type
, int64_type
,
441 int64_type
, NULL_TREE
),
442 NULL_TREE
, is_disabled
, true, true, true, NULL
,
445 /* Name of the _Parent field in tagged record types. */
446 parent_name_id
= get_identifier (Get_Name_String (Name_uParent
));
448 /* Name of the Exception_Data type defined in System.Standard_Library. */
449 exception_data_name_id
450 = get_identifier ("system__standard_library__exception_data");
452 /* Make the types and functions used for exception processing. */
454 = build_array_type (gnat_type_for_mode (Pmode
, 0),
455 build_index_type (size_int (5)));
456 record_builtin_type ("JMPBUF_T", jmpbuf_type
, true);
457 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
459 /* Functions to get and set the jumpbuf pointer for the current thread. */
461 = create_subprog_decl
462 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
463 NULL_TREE
, build_function_type_list (jmpbuf_ptr_type
, NULL_TREE
),
464 NULL_TREE
, is_disabled
, true, true, true, NULL
, Empty
);
465 DECL_IGNORED_P (get_jmpbuf_decl
) = 1;
468 = create_subprog_decl
469 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
470 NULL_TREE
, build_function_type_list (void_type_node
, jmpbuf_ptr_type
,
472 NULL_TREE
, is_disabled
, true, true, true, NULL
, Empty
);
473 DECL_IGNORED_P (set_jmpbuf_decl
) = 1;
475 /* setjmp returns an integer and has one operand, which is a pointer to
478 = create_subprog_decl
479 (get_identifier ("__builtin_setjmp"), NULL_TREE
,
480 build_function_type_list (integer_type_node
, jmpbuf_ptr_type
,
482 NULL_TREE
, is_disabled
, true, true, true, NULL
, Empty
);
483 DECL_BUILT_IN_CLASS (setjmp_decl
) = BUILT_IN_NORMAL
;
484 DECL_FUNCTION_CODE (setjmp_decl
) = BUILT_IN_SETJMP
;
486 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
488 update_setjmp_buf_decl
489 = create_subprog_decl
490 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE
,
491 build_function_type_list (void_type_node
, jmpbuf_ptr_type
, NULL_TREE
),
492 NULL_TREE
, is_disabled
, true, true, true, NULL
, Empty
);
493 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl
) = BUILT_IN_NORMAL
;
494 DECL_FUNCTION_CODE (update_setjmp_buf_decl
) = BUILT_IN_UPDATE_SETJMP_BUF
;
496 /* Hooks to call when entering/leaving an exception handler. */
498 = build_function_type_list (void_type_node
, ptr_void_type_node
, NULL_TREE
);
501 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE
,
502 ftype
, NULL_TREE
, is_disabled
, true, true, true,
504 DECL_IGNORED_P (begin_handler_decl
) = 1;
507 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE
,
508 ftype
, NULL_TREE
, is_disabled
, true, true, true,
510 DECL_IGNORED_P (end_handler_decl
) = 1;
512 unhandled_except_decl
513 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
515 ftype
, NULL_TREE
, is_disabled
, true, true, true,
517 DECL_IGNORED_P (unhandled_except_decl
) = 1;
520 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE
,
521 ftype
, NULL_TREE
, is_disabled
, true, true, true,
523 /* Indicate that these never return. */
524 DECL_IGNORED_P (reraise_zcx_decl
) = 1;
525 TREE_THIS_VOLATILE (reraise_zcx_decl
) = 1;
526 TREE_SIDE_EFFECTS (reraise_zcx_decl
) = 1;
527 TREE_TYPE (reraise_zcx_decl
)
528 = build_qualified_type (TREE_TYPE (reraise_zcx_decl
), TYPE_QUAL_VOLATILE
);
530 /* If in no exception handlers mode, all raise statements are redirected to
531 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
532 this procedure will never be called in this mode. */
533 if (No_Exception_Handlers_Set ())
536 = create_subprog_decl
537 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
,
538 build_function_type_list (void_type_node
,
540 (unsigned_char_type_node
),
541 integer_type_node
, NULL_TREE
),
542 NULL_TREE
, is_disabled
, true, true, true, NULL
, Empty
);
543 TREE_THIS_VOLATILE (decl
) = 1;
544 TREE_SIDE_EFFECTS (decl
) = 1;
546 = build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
547 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
548 gnat_raise_decls
[i
] = decl
;
552 /* Otherwise, make one decl for each exception reason. */
553 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
554 gnat_raise_decls
[i
] = build_raise_check (i
, exception_simple
);
555 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls_ext
); i
++)
556 gnat_raise_decls_ext
[i
]
557 = build_raise_check (i
,
558 i
== CE_Index_Check_Failed
559 || i
== CE_Range_Check_Failed
560 || i
== CE_Invalid_Data
561 ? exception_range
: exception_column
);
564 /* Set the types that GCC and Gigi use from the front end. */
566 = gnat_to_gnu_entity (Base_Type (standard_exception_type
), NULL_TREE
, 0);
567 except_type_node
= TREE_TYPE (exception_type
);
569 /* Make other functions used for exception processing. */
571 = create_subprog_decl
572 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE
,
573 build_function_type_list (build_pointer_type (except_type_node
),
575 NULL_TREE
, is_disabled
, true, true, true, NULL
, Empty
);
576 DECL_IGNORED_P (get_excptr_decl
) = 1;
579 = create_subprog_decl
580 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
,
581 build_function_type_list (void_type_node
,
582 build_pointer_type (except_type_node
),
584 NULL_TREE
, is_disabled
, true, true, true, NULL
, Empty
);
586 /* Indicate that it never returns. */
587 TREE_THIS_VOLATILE (raise_nodefer_decl
) = 1;
588 TREE_SIDE_EFFECTS (raise_nodefer_decl
) = 1;
589 TREE_TYPE (raise_nodefer_decl
)
590 = build_qualified_type (TREE_TYPE (raise_nodefer_decl
),
593 /* Build the special descriptor type and its null node if needed. */
594 if (TARGET_VTABLE_USES_DESCRIPTORS
)
596 tree null_node
= fold_convert (ptr_void_ftype
, null_pointer_node
);
597 tree field_list
= NULL_TREE
;
599 vec
<constructor_elt
, va_gc
> *null_vec
= NULL
;
600 constructor_elt
*elt
;
602 fdesc_type_node
= make_node (RECORD_TYPE
);
603 vec_safe_grow (null_vec
, TARGET_VTABLE_USES_DESCRIPTORS
);
604 elt
= (null_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
606 for (j
= 0; j
< TARGET_VTABLE_USES_DESCRIPTORS
; j
++)
609 = create_field_decl (NULL_TREE
, ptr_void_ftype
, fdesc_type_node
,
610 NULL_TREE
, NULL_TREE
, 0, 1);
611 DECL_CHAIN (field
) = field_list
;
614 elt
->value
= null_node
;
618 finish_record_type (fdesc_type_node
, nreverse (field_list
), 0, false);
619 record_builtin_type ("descriptor", fdesc_type_node
, true);
620 null_fdesc_node
= gnat_build_constructor (fdesc_type_node
, null_vec
);
624 = gnat_to_gnu_entity (Base_Type (standard_long_long_float
), NULL_TREE
, 0);
626 if (TREE_CODE (TREE_TYPE (long_long_float_type
)) == INTEGER_TYPE
)
628 /* In this case, the builtin floating point types are VAX float,
629 so make up a type for use. */
630 longest_float_type_node
= make_node (REAL_TYPE
);
631 TYPE_PRECISION (longest_float_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
632 layout_type (longest_float_type_node
);
633 record_builtin_type ("longest float type", longest_float_type_node
,
637 longest_float_type_node
= TREE_TYPE (long_long_float_type
);
639 /* Dummy objects to materialize "others" and "all others" in the exception
640 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
643 = create_var_decl (get_identifier ("OTHERS"),
644 get_identifier ("__gnat_others_value"),
645 integer_type_node
, NULL_TREE
, true, false, true, false,
649 = create_var_decl (get_identifier ("ALL_OTHERS"),
650 get_identifier ("__gnat_all_others_value"),
651 integer_type_node
, NULL_TREE
, true, false, true, false,
654 unhandled_others_decl
655 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
656 get_identifier ("__gnat_unhandled_others_value"),
657 integer_type_node
, NULL_TREE
, true, false, true, false,
660 main_identifier_node
= get_identifier ("main");
662 /* Install the builtins we might need, either internally or as
663 user available facilities for Intrinsic imports. */
664 gnat_install_builtins ();
666 vec_safe_push (gnu_except_ptr_stack
, NULL_TREE
);
667 vec_safe_push (gnu_constraint_error_label_stack
, NULL_TREE
);
668 vec_safe_push (gnu_storage_error_label_stack
, NULL_TREE
);
669 vec_safe_push (gnu_program_error_label_stack
, NULL_TREE
);
671 /* Process any Pragma Ident for the main unit. */
672 if (Present (Ident_String (Main_Unit
)))
673 targetm
.asm_out
.output_ident
674 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
676 /* If we are using the GCC exception mechanism, let GCC know. */
677 if (Exception_Mechanism
== Back_End_Exceptions
)
680 /* Initialize the GCC support for FP operations. */
683 /* Now translate the compilation unit proper. */
684 Compilation_Unit_to_gnu (gnat_root
);
686 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
687 the very end to avoid having to second-guess the front-end when we run
688 into dummy nodes during the regular processing. */
689 for (i
= 0; gnat_validate_uc_list
.iterate (i
, &gnat_iter
); i
++)
690 validate_unchecked_conversion (gnat_iter
);
691 gnat_validate_uc_list
.release ();
693 /* Finally see if we have any elaboration procedures to deal with. */
694 for (info
= elab_info_list
; info
; info
= info
->next
)
696 tree gnu_body
= DECL_SAVED_TREE (info
->elab_proc
), gnu_stmts
;
698 /* We should have a BIND_EXPR but it may not have any statements in it.
699 If it doesn't have any, we have nothing to do except for setting the
700 flag on the GNAT node. Otherwise, process the function as others. */
701 gnu_stmts
= gnu_body
;
702 if (TREE_CODE (gnu_stmts
) == BIND_EXPR
)
703 gnu_stmts
= BIND_EXPR_BODY (gnu_stmts
);
704 if (!gnu_stmts
|| !STATEMENT_LIST_HEAD (gnu_stmts
))
705 Set_Has_No_Elaboration_Code (info
->gnat_node
, 1);
708 begin_subprog_body (info
->elab_proc
);
709 end_subprog_body (gnu_body
);
710 rest_of_subprog_body_compilation (info
->elab_proc
);
714 /* Destroy ourselves. */
715 destroy_gnat_utils ();
717 /* We cannot track the location of errors past this point. */
718 error_gnat_node
= Empty
;
721 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
722 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
725 build_raise_check (int check
, enum exception_info_kind kind
)
728 const char pfx
[] = "__gnat_rcheck_";
730 strcpy (Name_Buffer
, pfx
);
731 Name_Len
= sizeof (pfx
) - 1;
732 Get_RT_Exception_Name (check
);
734 if (kind
== exception_simple
)
736 Name_Buffer
[Name_Len
] = 0;
738 = build_function_type_list (void_type_node
,
740 (unsigned_char_type_node
),
741 integer_type_node
, NULL_TREE
);
745 tree t
= (kind
== exception_column
? NULL_TREE
: integer_type_node
);
747 strcpy (Name_Buffer
+ Name_Len
, "_ext");
748 Name_Buffer
[Name_Len
+ 4] = 0;
750 = build_function_type_list (void_type_node
,
752 (unsigned_char_type_node
),
753 integer_type_node
, integer_type_node
,
758 = create_subprog_decl (get_identifier (Name_Buffer
),
759 NULL_TREE
, ftype
, NULL_TREE
,
760 is_disabled
, true, true, true, NULL
, Empty
);
762 /* Indicate that it never returns. */
763 TREE_THIS_VOLATILE (result
) = 1;
764 TREE_SIDE_EFFECTS (result
) = 1;
766 = build_qualified_type (TREE_TYPE (result
), TYPE_QUAL_VOLATILE
);
771 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
772 an N_Attribute_Reference. */
775 lvalue_required_for_attribute_p (Node_Id gnat_node
)
777 switch (Get_Attribute_Id (Attribute_Name (gnat_node
)))
785 case Attr_Range_Length
:
787 case Attr_Object_Size
:
788 case Attr_Value_Size
:
789 case Attr_Component_Size
:
790 case Attr_Max_Size_In_Storage_Elements
:
793 case Attr_Null_Parameter
:
794 case Attr_Passed_By_Reference
:
795 case Attr_Mechanism_Code
:
800 case Attr_Unchecked_Access
:
801 case Attr_Unrestricted_Access
:
802 case Attr_Code_Address
:
803 case Attr_Pool_Address
:
806 case Attr_Bit_Position
:
812 case Attr_Asm_Output
:
818 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
819 is the type that will be used for GNAT_NODE in the translated GNU tree.
820 CONSTANT indicates whether the underlying object represented by GNAT_NODE
821 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
822 whether its value is the address of a constant and ALIASED whether it is
823 aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
825 The function climbs up the GNAT tree starting from the node and returns 1
826 upon encountering a node that effectively requires an lvalue downstream.
827 It returns int instead of bool to facilitate usage in non-purely binary
831 lvalue_required_p (Node_Id gnat_node
, tree gnu_type
, bool constant
,
832 bool address_of_constant
, bool aliased
)
834 Node_Id gnat_parent
= Parent (gnat_node
), gnat_temp
;
836 switch (Nkind (gnat_parent
))
841 case N_Attribute_Reference
:
842 return lvalue_required_for_attribute_p (gnat_parent
);
844 case N_Parameter_Association
:
845 case N_Function_Call
:
846 case N_Procedure_Call_Statement
:
847 /* If the parameter is by reference, an lvalue is required. */
849 || must_pass_by_ref (gnu_type
)
850 || default_pass_by_ref (gnu_type
));
852 case N_Indexed_Component
:
853 /* Only the array expression can require an lvalue. */
854 if (Prefix (gnat_parent
) != gnat_node
)
857 /* ??? Consider that referencing an indexed component with a
858 non-constant index forces the whole aggregate to memory.
859 Note that N_Integer_Literal is conservative, any static
860 expression in the RM sense could probably be accepted. */
861 for (gnat_temp
= First (Expressions (gnat_parent
));
863 gnat_temp
= Next (gnat_temp
))
864 if (Nkind (gnat_temp
) != N_Integer_Literal
)
867 /* ... fall through ... */
870 /* Only the array expression can require an lvalue. */
871 if (Prefix (gnat_parent
) != gnat_node
)
874 aliased
|= Has_Aliased_Components (Etype (gnat_node
));
875 return lvalue_required_p (gnat_parent
, gnu_type
, constant
,
876 address_of_constant
, aliased
);
878 case N_Selected_Component
:
879 aliased
|= Is_Aliased (Entity (Selector_Name (gnat_parent
)));
880 return lvalue_required_p (gnat_parent
, gnu_type
, constant
,
881 address_of_constant
, aliased
);
883 case N_Object_Renaming_Declaration
:
884 /* We need to make a real renaming only if the constant object is
885 aliased or if we may use a renaming pointer; otherwise we can
886 optimize and return the rvalue. We make an exception if the object
887 is an identifier since in this case the rvalue can be propagated
888 attached to the CONST_DECL. */
891 /* This should match the constant case of the renaming code. */
893 (Underlying_Type (Etype (Name (gnat_parent
))))
894 || Nkind (Name (gnat_parent
)) == N_Identifier
);
896 case N_Object_Declaration
:
897 /* We cannot use a constructor if this is an atomic object because
898 the actual assignment might end up being done component-wise. */
900 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
901 && Is_Atomic (Defining_Entity (gnat_parent
)))
902 /* We don't use a constructor if this is a class-wide object
903 because the effective type of the object is the equivalent
904 type of the class-wide subtype and it smashes most of the
905 data into an array of bytes to which we cannot convert. */
906 || Ekind ((Etype (Defining_Entity (gnat_parent
))))
907 == E_Class_Wide_Subtype
);
909 case N_Assignment_Statement
:
910 /* We cannot use a constructor if the LHS is an atomic object because
911 the actual assignment might end up being done component-wise. */
913 || Name (gnat_parent
) == gnat_node
914 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
915 && Is_Atomic (Entity (Name (gnat_parent
)))));
917 case N_Unchecked_Type_Conversion
:
921 /* ... fall through ... */
923 case N_Type_Conversion
:
924 case N_Qualified_Expression
:
925 /* We must look through all conversions because we may need to bypass
926 an intermediate conversion that is meant to be purely formal. */
927 return lvalue_required_p (gnat_parent
,
928 get_unpadded_type (Etype (gnat_parent
)),
929 constant
, address_of_constant
, aliased
);
932 /* We should only reach here through the N_Qualified_Expression case.
933 Force an lvalue for composite types since a block-copy to the newly
934 allocated area of memory is made. */
935 return Is_Composite_Type (Underlying_Type (Etype (gnat_node
)));
937 case N_Explicit_Dereference
:
938 /* We look through dereferences for address of constant because we need
939 to handle the special cases listed above. */
940 if (constant
&& address_of_constant
)
941 return lvalue_required_p (gnat_parent
,
942 get_unpadded_type (Etype (gnat_parent
)),
945 /* ... fall through ... */
954 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
955 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
956 to where we should place the result type. */
959 Identifier_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
961 Node_Id gnat_temp
, gnat_temp_type
;
962 tree gnu_result
, gnu_result_type
;
964 /* Whether we should require an lvalue for GNAT_NODE. Needed in
965 specific circumstances only, so evaluated lazily. < 0 means
966 unknown, > 0 means known true, 0 means known false. */
967 int require_lvalue
= -1;
969 /* If GNAT_NODE is a constant, whether we should use the initialization
970 value instead of the constant entity, typically for scalars with an
971 address clause when the parent doesn't require an lvalue. */
972 bool use_constant_initializer
= false;
974 /* If the Etype of this node does not equal the Etype of the Entity,
975 something is wrong with the entity map, probably in generic
976 instantiation. However, this does not apply to types. Since we sometime
977 have strange Ekind's, just do this test for objects. Also, if the Etype of
978 the Entity is private, the Etype of the N_Identifier is allowed to be the
979 full type and also we consider a packed array type to be the same as the
980 original type. Similarly, a class-wide type is equivalent to a subtype of
981 itself. Finally, if the types are Itypes, one may be a copy of the other,
982 which is also legal. */
983 gnat_temp
= (Nkind (gnat_node
) == N_Defining_Identifier
984 ? gnat_node
: Entity (gnat_node
));
985 gnat_temp_type
= Etype (gnat_temp
);
987 gcc_assert (Etype (gnat_node
) == gnat_temp_type
988 || (Is_Packed (gnat_temp_type
)
989 && Etype (gnat_node
) == Packed_Array_Type (gnat_temp_type
))
990 || (Is_Class_Wide_Type (Etype (gnat_node
)))
991 || (IN (Ekind (gnat_temp_type
), Private_Kind
)
992 && Present (Full_View (gnat_temp_type
))
993 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
994 || (Is_Packed (Full_View (gnat_temp_type
))
995 && (Etype (gnat_node
)
996 == Packed_Array_Type (Full_View
997 (gnat_temp_type
))))))
998 || (Is_Itype (Etype (gnat_node
)) && Is_Itype (gnat_temp_type
))
999 || !(Ekind (gnat_temp
) == E_Variable
1000 || Ekind (gnat_temp
) == E_Component
1001 || Ekind (gnat_temp
) == E_Constant
1002 || Ekind (gnat_temp
) == E_Loop_Parameter
1003 || IN (Ekind (gnat_temp
), Formal_Kind
)));
1005 /* If this is a reference to a deferred constant whose partial view is an
1006 unconstrained private type, the proper type is on the full view of the
1007 constant, not on the full view of the type, which may be unconstrained.
1009 This may be a reference to a type, for example in the prefix of the
1010 attribute Position, generated for dispatching code (see Make_DT in
1011 exp_disp,adb). In that case we need the type itself, not is parent,
1012 in particular if it is a derived type */
1013 if (Ekind (gnat_temp
) == E_Constant
1014 && Is_Private_Type (gnat_temp_type
)
1015 && (Has_Unknown_Discriminants (gnat_temp_type
)
1016 || (Present (Full_View (gnat_temp_type
))
1017 && Has_Discriminants (Full_View (gnat_temp_type
))))
1018 && Present (Full_View (gnat_temp
)))
1020 gnat_temp
= Full_View (gnat_temp
);
1021 gnat_temp_type
= Etype (gnat_temp
);
1025 /* We want to use the Actual_Subtype if it has already been elaborated,
1026 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
1028 if ((Ekind (gnat_temp
) == E_Constant
1029 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
1030 && !(Is_Array_Type (Etype (gnat_temp
))
1031 && Present (Packed_Array_Type (Etype (gnat_temp
))))
1032 && Present (Actual_Subtype (gnat_temp
))
1033 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
1034 gnat_temp_type
= Actual_Subtype (gnat_temp
);
1036 gnat_temp_type
= Etype (gnat_node
);
1039 /* Expand the type of this identifier first, in case it is an enumeral
1040 literal, which only get made when the type is expanded. There is no
1041 order-of-elaboration issue here. */
1042 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
1044 /* If this is a non-imported elementary constant with an address clause,
1045 retrieve the value instead of a pointer to be dereferenced unless
1046 an lvalue is required. This is generally more efficient and actually
1047 required if this is a static expression because it might be used
1048 in a context where a dereference is inappropriate, such as a case
1049 statement alternative or a record discriminant. There is no possible
1050 volatile-ness short-circuit here since Volatile constants must be
1051 imported per C.6. */
1052 if (Ekind (gnat_temp
) == E_Constant
1053 && Is_Elementary_Type (gnat_temp_type
)
1054 && !Is_Imported (gnat_temp
)
1055 && Present (Address_Clause (gnat_temp
)))
1057 require_lvalue
= lvalue_required_p (gnat_node
, gnu_result_type
, true,
1058 false, Is_Aliased (gnat_temp
));
1059 use_constant_initializer
= !require_lvalue
;
1062 if (use_constant_initializer
)
1064 /* If this is a deferred constant, the initializer is attached to
1066 if (Present (Full_View (gnat_temp
)))
1067 gnat_temp
= Full_View (gnat_temp
);
1069 gnu_result
= gnat_to_gnu (Expression (Declaration_Node (gnat_temp
)));
1072 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0);
1074 /* Some objects (such as parameters passed by reference, globals of
1075 variable size, and renamed objects) actually represent the address
1076 of the object. In that case, we must do the dereference. Likewise,
1077 deal with parameters to foreign convention subprograms. */
1078 if (DECL_P (gnu_result
)
1079 && (DECL_BY_REF_P (gnu_result
)
1080 || (TREE_CODE (gnu_result
) == PARM_DECL
1081 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
1083 const bool read_only
= DECL_POINTS_TO_READONLY_P (gnu_result
);
1085 /* First do the first dereference if needed. */
1086 if (TREE_CODE (gnu_result
) == PARM_DECL
1087 && DECL_BY_DOUBLE_REF_P (gnu_result
))
1089 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
1090 if (TREE_CODE (gnu_result
) == INDIRECT_REF
)
1091 TREE_THIS_NOTRAP (gnu_result
) = 1;
1093 /* The first reference, in case of a double reference, always points
1094 to read-only, see gnat_to_gnu_param for the rationale. */
1095 TREE_READONLY (gnu_result
) = 1;
1098 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1099 if (TREE_CODE (gnu_result
) == PARM_DECL
1100 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
1102 = convert (build_pointer_type (gnu_result_type
), gnu_result
);
1104 /* If it's a CONST_DECL, return the underlying constant like below. */
1105 else if (TREE_CODE (gnu_result
) == CONST_DECL
1106 && !(DECL_CONST_ADDRESS_P (gnu_result
)
1107 && lvalue_required_p (gnat_node
, gnu_result_type
, true,
1109 gnu_result
= DECL_INITIAL (gnu_result
);
1111 /* If it's a renaming pointer and we are at the right binding level,
1112 we can reference the renamed object directly, since the renamed
1113 expression has been protected against multiple evaluations. */
1114 if (TREE_CODE (gnu_result
) == VAR_DECL
1115 && !DECL_LOOP_PARM_P (gnu_result
)
1116 && DECL_RENAMED_OBJECT (gnu_result
)
1117 && (!DECL_RENAMING_GLOBAL_P (gnu_result
) || global_bindings_p ()))
1118 gnu_result
= DECL_RENAMED_OBJECT (gnu_result
);
1120 /* Otherwise, do the final dereference. */
1123 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
1125 if ((TREE_CODE (gnu_result
) == INDIRECT_REF
1126 || TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
1127 && No (Address_Clause (gnat_temp
)))
1128 TREE_THIS_NOTRAP (gnu_result
) = 1;
1131 TREE_READONLY (gnu_result
) = 1;
1135 /* If we have a constant declaration and its initializer, try to return the
1136 latter to avoid the need to call fold in lots of places and the need for
1137 elaboration code if this identifier is used as an initializer itself.
1138 Don't do it for aggregate types that contain a placeholder since their
1139 initializers cannot be manipulated easily. */
1140 if (TREE_CONSTANT (gnu_result
)
1141 && DECL_P (gnu_result
)
1142 && DECL_INITIAL (gnu_result
)
1143 && !(AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))
1144 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_result
))
1145 && type_contains_placeholder_p (TREE_TYPE (gnu_result
))))
1147 bool constant_only
= (TREE_CODE (gnu_result
) == CONST_DECL
1148 && !DECL_CONST_CORRESPONDING_VAR (gnu_result
));
1149 bool address_of_constant
= (TREE_CODE (gnu_result
) == CONST_DECL
1150 && DECL_CONST_ADDRESS_P (gnu_result
));
1152 /* If there is a (corresponding) variable or this is the address of a
1153 constant, we only want to return the initializer if an lvalue isn't
1154 required. Evaluate this now if we have not already done so. */
1155 if ((!constant_only
|| address_of_constant
) && require_lvalue
< 0)
1157 = lvalue_required_p (gnat_node
, gnu_result_type
, true,
1158 address_of_constant
, Is_Aliased (gnat_temp
));
1160 /* Finally retrieve the initializer if this is deemed valid. */
1161 if ((constant_only
&& !address_of_constant
) || !require_lvalue
)
1162 gnu_result
= DECL_INITIAL (gnu_result
);
1165 /* The GNAT tree has the type of a function set to its result type, so we
1166 adjust here. Also use the type of the result if the Etype is a subtype
1167 that is nominally unconstrained. Likewise if this is a deferred constant
1168 of a discriminated type whose full view can be elaborated statically, to
1169 avoid problematic conversions to the nominal subtype. But remove any
1170 padding from the resulting type. */
1171 if (TREE_CODE (TREE_TYPE (gnu_result
)) == FUNCTION_TYPE
1172 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
)
1173 || (Ekind (gnat_temp
) == E_Constant
1174 && Present (Full_View (gnat_temp
))
1175 && Has_Discriminants (gnat_temp_type
)
1176 && TREE_CODE (gnu_result
) == CONSTRUCTOR
))
1178 gnu_result_type
= TREE_TYPE (gnu_result
);
1179 if (TYPE_IS_PADDING_P (gnu_result_type
))
1180 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
1183 *gnu_result_type_p
= gnu_result_type
;
1188 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1189 any statements we generate. */
1192 Pragma_to_gnu (Node_Id gnat_node
)
1194 tree gnu_result
= alloc_stmt_list ();
1197 /* Do nothing if we are just annotating types and check for (and ignore)
1198 unrecognized pragmas. */
1199 if (type_annotate_only
1200 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node
))))
1203 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
))))
1205 case Pragma_Inspection_Point
:
1206 /* Do nothing at top level: all such variables are already viewable. */
1207 if (global_bindings_p ())
1210 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1211 Present (gnat_temp
);
1212 gnat_temp
= Next (gnat_temp
))
1214 Node_Id gnat_expr
= Expression (gnat_temp
);
1215 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1217 enum machine_mode mode
;
1218 tree asm_constraint
= NULL_TREE
;
1219 #ifdef ASM_COMMENT_START
1223 if (TREE_CODE (gnu_expr
) == UNCONSTRAINED_ARRAY_REF
)
1224 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1226 /* Use the value only if it fits into a normal register,
1227 otherwise use the address. */
1228 mode
= TYPE_MODE (TREE_TYPE (gnu_expr
));
1229 use_address
= ((GET_MODE_CLASS (mode
) != MODE_INT
1230 && GET_MODE_CLASS (mode
) != MODE_PARTIAL_INT
)
1231 || GET_MODE_SIZE (mode
) > UNITS_PER_WORD
);
1234 gnu_expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
1236 #ifdef ASM_COMMENT_START
1237 comment
= concat (ASM_COMMENT_START
,
1238 " inspection point: ",
1239 Get_Name_String (Chars (gnat_expr
)),
1240 use_address
? " address" : "",
1243 asm_constraint
= build_string (strlen (comment
), comment
);
1246 gnu_expr
= build5 (ASM_EXPR
, void_type_node
,
1250 (build_tree_list (NULL_TREE
,
1251 build_string (1, "g")),
1252 gnu_expr
, NULL_TREE
),
1253 NULL_TREE
, NULL_TREE
);
1254 ASM_VOLATILE_P (gnu_expr
) = 1;
1255 set_expr_location_from_node (gnu_expr
, gnat_node
);
1256 append_to_statement_list (gnu_expr
, &gnu_result
);
1260 case Pragma_Loop_Optimize
:
1261 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1262 Present (gnat_temp
);
1263 gnat_temp
= Next (gnat_temp
))
1265 tree gnu_loop_stmt
= gnu_loop_stack
->last ()->stmt
;
1267 switch (Chars (Expression (gnat_temp
)))
1269 case Name_No_Unroll
:
1270 LOOP_STMT_NO_UNROLL (gnu_loop_stmt
) = 1;
1274 LOOP_STMT_UNROLL (gnu_loop_stmt
) = 1;
1277 case Name_No_Vector
:
1278 LOOP_STMT_NO_VECTOR (gnu_loop_stmt
) = 1;
1282 LOOP_STMT_VECTOR (gnu_loop_stmt
) = 1;
1291 case Pragma_Optimize
:
1292 switch (Chars (Expression
1293 (First (Pragma_Argument_Associations (gnat_node
)))))
1297 post_error ("must specify -O0?", gnat_node
);
1302 post_error ("must specify -Os?", gnat_node
);
1307 post_error ("insufficient -O value?", gnat_node
);
1315 case Pragma_Reviewable
:
1316 if (write_symbols
== NO_DEBUG
)
1317 post_error ("must specify -g?", gnat_node
);
1320 case Pragma_Warnings
:
1323 /* Preserve the location of the pragma. */
1324 const location_t location
= input_location
;
1325 struct cl_option_handlers handlers
;
1326 unsigned int option_index
;
1330 gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1332 /* This is the String form: pragma Warnings (String). */
1333 if (Nkind (Expression (gnat_temp
)) == N_String_Literal
)
1336 gnat_expr
= Expression (gnat_temp
);
1340 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1341 else if (Nkind (Expression (gnat_temp
)) == N_Identifier
)
1343 switch (Chars (Expression (gnat_temp
)))
1357 if (Present (Next (gnat_temp
)))
1359 /* pragma Warnings (On | Off, Name) is handled differently. */
1360 if (Nkind (Expression (Next (gnat_temp
))) != N_String_Literal
)
1363 gnat_expr
= Expression (Next (gnat_temp
));
1374 /* This is the same implementation as in the C family of compilers. */
1375 if (Present (gnat_expr
))
1377 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1378 const char *opt_string
= TREE_STRING_POINTER (gnu_expr
);
1379 const int len
= TREE_STRING_LENGTH (gnu_expr
);
1380 if (len
< 3 || opt_string
[0] != '-' || opt_string
[1] != 'W')
1382 for (option_index
= 0;
1383 option_index
< cl_options_count
;
1385 if (strcmp (cl_options
[option_index
].opt_text
, opt_string
) == 0)
1387 if (option_index
== cl_options_count
)
1389 post_error ("unknown -W switch", gnat_node
);
1396 set_default_handlers (&handlers
);
1397 control_warning_option (option_index
, (int) kind
, imply
, location
,
1398 CL_Ada
, &handlers
, &global_options
,
1399 &global_options_set
, global_dc
);
1410 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1411 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1412 where we should place the result type. ATTRIBUTE is the attribute ID. */
1415 Attribute_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, int attribute
)
1417 tree gnu_prefix
, gnu_type
, gnu_expr
;
1418 tree gnu_result_type
, gnu_result
= error_mark_node
;
1419 bool prefix_unused
= false;
1421 /* ??? If this is an access attribute for a public subprogram to be used in
1422 a dispatch table, do not translate its type as it's useless there and the
1423 parameter types might be incomplete types coming from a limited with. */
1424 if (Ekind (Etype (gnat_node
)) == E_Access_Subprogram_Type
1425 && Is_Dispatch_Table_Entity (Etype (gnat_node
))
1426 && Nkind (Prefix (gnat_node
)) == N_Identifier
1427 && Is_Subprogram (Entity (Prefix (gnat_node
)))
1428 && Is_Public (Entity (Prefix (gnat_node
)))
1429 && !present_gnu_tree (Entity (Prefix (gnat_node
))))
1430 gnu_prefix
= get_minimal_subprog_decl (Entity (Prefix (gnat_node
)));
1432 gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1433 gnu_type
= TREE_TYPE (gnu_prefix
);
1435 /* If the input is a NULL_EXPR, make a new one. */
1436 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1438 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1439 *gnu_result_type_p
= gnu_result_type
;
1440 return build1 (NULL_EXPR
, gnu_result_type
, TREE_OPERAND (gnu_prefix
, 0));
1447 /* These are just conversions since representation clauses for
1448 enumeration types are handled in the front-end. */
1450 bool checkp
= Do_Range_Check (First (Expressions (gnat_node
)));
1451 gnu_result
= gnat_to_gnu (First (Expressions (gnat_node
)));
1452 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1453 gnu_result
= convert_with_check (Etype (gnat_node
), gnu_result
,
1454 checkp
, checkp
, true, gnat_node
);
1460 /* These just add or subtract the constant 1 since representation
1461 clauses for enumeration types are handled in the front-end. */
1462 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1463 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1465 if (Do_Range_Check (First (Expressions (gnat_node
))))
1467 gnu_expr
= gnat_protect_expr (gnu_expr
);
1470 (build_binary_op (EQ_EXPR
, boolean_type_node
,
1472 attribute
== Attr_Pred
1473 ? TYPE_MIN_VALUE (gnu_result_type
)
1474 : TYPE_MAX_VALUE (gnu_result_type
)),
1475 gnu_expr
, CE_Range_Check_Failed
, gnat_node
);
1479 = build_binary_op (attribute
== Attr_Pred
? MINUS_EXPR
: PLUS_EXPR
,
1480 gnu_result_type
, gnu_expr
,
1481 convert (gnu_result_type
, integer_one_node
));
1485 case Attr_Unrestricted_Access
:
1486 /* Conversions don't change addresses but can cause us to miss the
1487 COMPONENT_REF case below, so strip them off. */
1488 gnu_prefix
= remove_conversions (gnu_prefix
,
1489 !Must_Be_Byte_Aligned (gnat_node
));
1491 /* If we are taking 'Address of an unconstrained object, this is the
1492 pointer to the underlying array. */
1493 if (attribute
== Attr_Address
)
1494 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1496 /* If we are building a static dispatch table, we have to honor
1497 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1498 with the C++ ABI. We do it in the non-static case as well,
1499 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1500 else if (TARGET_VTABLE_USES_DESCRIPTORS
1501 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
1504 /* Descriptors can only be built here for top-level functions. */
1505 bool build_descriptor
= (global_bindings_p () != 0);
1507 vec
<constructor_elt
, va_gc
> *gnu_vec
= NULL
;
1508 constructor_elt
*elt
;
1510 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1512 /* If we're not going to build the descriptor, we have to retrieve
1513 the one which will be built by the linker (or by the compiler
1514 later if a static chain is requested). */
1515 if (!build_descriptor
)
1517 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_prefix
);
1518 gnu_result
= fold_convert (build_pointer_type (gnu_result_type
),
1520 gnu_result
= build1 (INDIRECT_REF
, gnu_result_type
, gnu_result
);
1523 vec_safe_grow (gnu_vec
, TARGET_VTABLE_USES_DESCRIPTORS
);
1524 elt
= (gnu_vec
->address () + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
1525 for (gnu_field
= TYPE_FIELDS (gnu_result_type
), i
= 0;
1526 i
< TARGET_VTABLE_USES_DESCRIPTORS
;
1527 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
1529 if (build_descriptor
)
1531 t
= build2 (FDESC_EXPR
, TREE_TYPE (gnu_field
), gnu_prefix
,
1532 build_int_cst (NULL_TREE
, i
));
1533 TREE_CONSTANT (t
) = 1;
1536 t
= build3 (COMPONENT_REF
, ptr_void_ftype
, gnu_result
,
1537 gnu_field
, NULL_TREE
);
1539 elt
->index
= gnu_field
;
1544 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
1548 /* ... fall through ... */
1551 case Attr_Unchecked_Access
:
1552 case Attr_Code_Address
:
1553 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1555 = build_unary_op (((attribute
== Attr_Address
1556 || attribute
== Attr_Unrestricted_Access
)
1557 && !Must_Be_Byte_Aligned (gnat_node
))
1558 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1559 gnu_result_type
, gnu_prefix
);
1561 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1562 don't try to build a trampoline. */
1563 if (attribute
== Attr_Code_Address
)
1565 gnu_expr
= remove_conversions (gnu_result
, false);
1567 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1568 TREE_NO_TRAMPOLINE (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1571 /* For 'Access, issue an error message if the prefix is a C++ method
1572 since it can use a special calling convention on some platforms,
1573 which cannot be propagated to the access type. */
1574 else if (attribute
== Attr_Access
1575 && Nkind (Prefix (gnat_node
)) == N_Identifier
1576 && is_cplusplus_method (Entity (Prefix (gnat_node
))))
1577 post_error ("access to C++ constructor or member function not allowed",
1580 /* For other address attributes applied to a nested function,
1581 find an inner ADDR_EXPR and annotate it so that we can issue
1582 a useful warning with -Wtrampolines. */
1583 else if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == FUNCTION_TYPE
)
1585 gnu_expr
= remove_conversions (gnu_result
, false);
1587 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
1588 && decl_function_context (TREE_OPERAND (gnu_expr
, 0)))
1590 set_expr_location_from_node (gnu_expr
, gnat_node
);
1592 /* Check that we're not violating the No_Implicit_Dynamic_Code
1593 restriction. Be conservative if we don't know anything
1594 about the trampoline strategy for the target. */
1595 Check_Implicit_Dynamic_Code_Allowed (gnat_node
);
1600 case Attr_Pool_Address
:
1602 tree gnu_ptr
= gnu_prefix
;
1605 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1607 /* If this is fat pointer, the object must have been allocated with the
1608 template in front of the array. So compute the template address; do
1609 it by converting to a thin pointer. */
1610 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
1612 = convert (build_pointer_type
1613 (TYPE_OBJECT_RECORD_TYPE
1614 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
1617 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
1619 /* If this is a thin pointer, the object must have been allocated with
1620 the template in front of the array. So compute the template address
1622 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
1624 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
1626 fold_build1 (NEGATE_EXPR
, sizetype
,
1629 TYPE_FIELDS ((gnu_obj_type
)))));
1631 gnu_result
= convert (gnu_result_type
, gnu_ptr
);
1636 case Attr_Object_Size
:
1637 case Attr_Value_Size
:
1638 case Attr_Max_Size_In_Storage_Elements
:
1639 gnu_expr
= gnu_prefix
;
1641 /* Remove NOPs and conversions between original and packable version
1642 from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
1643 to see if a COMPONENT_REF was involved. */
1644 while (TREE_CODE (gnu_expr
) == NOP_EXPR
1645 || (TREE_CODE (gnu_expr
) == VIEW_CONVERT_EXPR
1646 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
1647 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
1649 && TYPE_NAME (TREE_TYPE (gnu_expr
))
1650 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))))
1651 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1653 gnu_prefix
= remove_conversions (gnu_prefix
, true);
1654 prefix_unused
= true;
1655 gnu_type
= TREE_TYPE (gnu_prefix
);
1657 /* Replace an unconstrained array type with the type of the underlying
1658 array. We can't do this with a call to maybe_unconstrained_array
1659 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
1660 use the record type that will be used to allocate the object and its
1662 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1664 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1665 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1666 gnu_type
= TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
1669 /* If we're looking for the size of a field, return the field size. */
1670 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1671 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1673 /* Otherwise, if the prefix is an object, or if we are looking for
1674 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1675 GCC size of the type. We make an exception for padded objects,
1676 as we do not take into account alignment promotions for the size.
1677 This is in keeping with the object case of gnat_to_gnu_entity. */
1678 else if ((TREE_CODE (gnu_prefix
) != TYPE_DECL
1679 && !(TYPE_IS_PADDING_P (gnu_type
)
1680 && TREE_CODE (gnu_expr
) == COMPONENT_REF
))
1681 || attribute
== Attr_Object_Size
1682 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1684 /* If this is a dereference and we have a special dynamic constrained
1685 subtype on the prefix, use it to compute the size; otherwise, use
1686 the designated subtype. */
1687 if (Nkind (Prefix (gnat_node
)) == N_Explicit_Dereference
)
1689 Node_Id gnat_deref
= Prefix (gnat_node
);
1690 Node_Id gnat_actual_subtype
1691 = Actual_Designated_Subtype (gnat_deref
);
1693 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref
)));
1695 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
)
1696 && Present (gnat_actual_subtype
))
1698 tree gnu_actual_obj_type
1699 = gnat_to_gnu_type (gnat_actual_subtype
);
1701 = build_unc_object_type_from_ptr (gnu_ptr_type
,
1702 gnu_actual_obj_type
,
1703 get_identifier ("SIZE"),
1708 gnu_result
= TYPE_SIZE (gnu_type
);
1711 /* Otherwise, the result is the RM size of the type. */
1713 gnu_result
= rm_size (gnu_type
);
1715 /* Deal with a self-referential size by returning the maximum size for
1716 a type and by qualifying the size with the object otherwise. */
1717 if (CONTAINS_PLACEHOLDER_P (gnu_result
))
1719 if (TREE_CODE (gnu_prefix
) == TYPE_DECL
)
1720 gnu_result
= max_size (gnu_result
, true);
1722 gnu_result
= substitute_placeholder_in_expr (gnu_result
, gnu_expr
);
1725 /* If the type contains a template, subtract its size. */
1726 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1727 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1728 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1729 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1731 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
1732 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1733 gnu_result
= size_binop (CEIL_DIV_EXPR
, gnu_result
, bitsize_unit_node
);
1735 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1738 case Attr_Alignment
:
1742 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1743 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
1744 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1746 gnu_type
= TREE_TYPE (gnu_prefix
);
1747 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1748 prefix_unused
= true;
1750 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1751 align
= DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)) / BITS_PER_UNIT
;
1754 Node_Id gnat_prefix
= Prefix (gnat_node
);
1755 Entity_Id gnat_type
= Etype (gnat_prefix
);
1756 unsigned int double_align
;
1757 bool is_capped_double
, align_clause
;
1759 /* If the default alignment of "double" or larger scalar types is
1760 specifically capped and there is an alignment clause neither
1761 on the type nor on the prefix itself, return the cap. */
1762 if ((double_align
= double_float_alignment
) > 0)
1764 = is_double_float_or_array (gnat_type
, &align_clause
);
1765 else if ((double_align
= double_scalar_alignment
) > 0)
1767 = is_double_scalar_or_array (gnat_type
, &align_clause
);
1769 is_capped_double
= align_clause
= false;
1771 if (is_capped_double
1772 && Nkind (gnat_prefix
) == N_Identifier
1773 && Present (Alignment_Clause (Entity (gnat_prefix
))))
1774 align_clause
= true;
1776 if (is_capped_double
&& !align_clause
)
1777 align
= double_align
;
1779 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
1782 gnu_result
= size_int (align
);
1788 case Attr_Range_Length
:
1789 prefix_unused
= true;
1791 if (INTEGRAL_TYPE_P (gnu_type
) || TREE_CODE (gnu_type
) == REAL_TYPE
)
1793 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1795 if (attribute
== Attr_First
)
1796 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
1797 else if (attribute
== Attr_Last
)
1798 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
1802 (MAX_EXPR
, get_base_type (gnu_result_type
),
1804 (PLUS_EXPR
, get_base_type (gnu_result_type
),
1805 build_binary_op (MINUS_EXPR
,
1806 get_base_type (gnu_result_type
),
1807 convert (gnu_result_type
,
1808 TYPE_MAX_VALUE (gnu_type
)),
1809 convert (gnu_result_type
,
1810 TYPE_MIN_VALUE (gnu_type
))),
1811 convert (gnu_result_type
, integer_one_node
)),
1812 convert (gnu_result_type
, integer_zero_node
));
1817 /* ... fall through ... */
1821 int Dimension
= (Present (Expressions (gnat_node
))
1822 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
1824 struct parm_attr_d
*pa
= NULL
;
1825 Entity_Id gnat_param
= Empty
;
1827 /* Make sure any implicit dereference gets done. */
1828 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1829 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1831 /* We treat unconstrained array In parameters specially. */
1832 if (!Is_Constrained (Etype (Prefix (gnat_node
))))
1834 Node_Id gnat_prefix
= Prefix (gnat_node
);
1836 /* This is the direct case. */
1837 if (Nkind (gnat_prefix
) == N_Identifier
1838 && Ekind (Entity (gnat_prefix
)) == E_In_Parameter
)
1839 gnat_param
= Entity (gnat_prefix
);
1841 /* This is the indirect case. Note that we need to be sure that
1842 the access value cannot be null as we'll hoist the load. */
1843 if (Nkind (gnat_prefix
) == N_Explicit_Dereference
1844 && Nkind (Prefix (gnat_prefix
)) == N_Identifier
1845 && Ekind (Entity (Prefix (gnat_prefix
))) == E_In_Parameter
1846 && Can_Never_Be_Null (Entity (Prefix (gnat_prefix
))))
1847 gnat_param
= Entity (Prefix (gnat_prefix
));
1850 /* If the prefix is the view conversion of a constrained array to an
1851 unconstrained form, we retrieve the constrained array because we
1852 might not be able to substitute the PLACEHOLDER_EXPR coming from
1853 the conversion. This can occur with the 'Old attribute applied
1854 to a parameter with an unconstrained type, which gets rewritten
1855 into a constrained local variable very late in the game. */
1856 if (TREE_CODE (gnu_prefix
) == VIEW_CONVERT_EXPR
1857 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix
)))
1858 && !CONTAINS_PLACEHOLDER_P
1859 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1860 gnu_type
= TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0));
1862 gnu_type
= TREE_TYPE (gnu_prefix
);
1864 prefix_unused
= true;
1865 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1867 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
1872 for (ndim
= 1, gnu_type_temp
= gnu_type
;
1873 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
1874 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
1875 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
1878 Dimension
= ndim
+ 1 - Dimension
;
1881 for (i
= 1; i
< Dimension
; i
++)
1882 gnu_type
= TREE_TYPE (gnu_type
);
1884 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
1886 /* When not optimizing, look up the slot associated with the parameter
1887 and the dimension in the cache and create a new one on failure. */
1888 if (!optimize
&& Present (gnat_param
))
1890 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache
, i
, pa
)
1891 if (pa
->id
== gnat_param
&& pa
->dim
== Dimension
)
1896 pa
= ggc_alloc_cleared_parm_attr_d ();
1897 pa
->id
= gnat_param
;
1898 pa
->dim
= Dimension
;
1899 vec_safe_push (f_parm_attr_cache
, pa
);
1903 /* Return the cached expression or build a new one. */
1904 if (attribute
== Attr_First
)
1906 if (pa
&& pa
->first
)
1908 gnu_result
= pa
->first
;
1913 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1916 else if (attribute
== Attr_Last
)
1920 gnu_result
= pa
->last
;
1925 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1928 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
1930 if (pa
&& pa
->length
)
1932 gnu_result
= pa
->length
;
1937 /* We used to compute the length as max (hb - lb + 1, 0),
1938 which could overflow for some cases of empty arrays, e.g.
1939 when lb == index_type'first. We now compute the length as
1940 (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1941 much rarer cases, for extremely large arrays we expect
1942 never to encounter in practice. In addition, the former
1943 computation required the use of potentially constraining
1944 signed arithmetic while the latter doesn't. Note that
1945 the comparison must be done in the original index type,
1946 to avoid any overflow during the conversion. */
1947 tree comp_type
= get_base_type (gnu_result_type
);
1948 tree index_type
= TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
));
1949 tree lb
= TYPE_MIN_VALUE (index_type
);
1950 tree hb
= TYPE_MAX_VALUE (index_type
);
1952 = build_binary_op (PLUS_EXPR
, comp_type
,
1953 build_binary_op (MINUS_EXPR
,
1955 convert (comp_type
, hb
),
1956 convert (comp_type
, lb
)),
1957 convert (comp_type
, integer_one_node
));
1959 = build_cond_expr (comp_type
,
1960 build_binary_op (GE_EXPR
,
1964 convert (comp_type
, integer_zero_node
));
1968 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1969 handling. Note that these attributes could not have been used on
1970 an unconstrained array type. */
1971 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
1973 /* Cache the expression we have just computed. Since we want to do it
1974 at run time, we force the use of a SAVE_EXPR and let the gimplifier
1975 create the temporary in the outermost binding level. We will make
1976 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
1977 paths by forcing its evaluation on entry of the function. */
1981 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
1982 if (attribute
== Attr_First
)
1983 pa
->first
= gnu_result
;
1984 else if (attribute
== Attr_Last
)
1985 pa
->last
= gnu_result
;
1987 pa
->length
= gnu_result
;
1990 /* Set the source location onto the predicate of the condition in the
1991 'Length case but do not do it if the expression is cached to avoid
1992 messing up the debug info. */
1993 else if ((attribute
== Attr_Range_Length
|| attribute
== Attr_Length
)
1994 && TREE_CODE (gnu_result
) == COND_EXPR
1995 && EXPR_P (TREE_OPERAND (gnu_result
, 0)))
1996 set_expr_location_from_node (TREE_OPERAND (gnu_result
, 0),
2002 case Attr_Bit_Position
:
2004 case Attr_First_Bit
:
2008 HOST_WIDE_INT bitsize
;
2009 HOST_WIDE_INT bitpos
;
2011 tree gnu_field_bitpos
;
2012 tree gnu_field_offset
;
2014 enum machine_mode mode
;
2015 int unsignedp
, volatilep
;
2017 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2018 gnu_prefix
= remove_conversions (gnu_prefix
, true);
2019 prefix_unused
= true;
2021 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2022 the result is 0. Don't allow 'Bit on a bare component, though. */
2023 if (attribute
== Attr_Bit
2024 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
2025 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
2027 gnu_result
= integer_zero_node
;
2032 gcc_assert (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2033 || (attribute
== Attr_Bit_Position
2034 && TREE_CODE (gnu_prefix
) == FIELD_DECL
));
2036 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
2037 &mode
, &unsignedp
, &volatilep
, false);
2039 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
2041 gnu_field_bitpos
= bit_position (TREE_OPERAND (gnu_prefix
, 1));
2042 gnu_field_offset
= byte_position (TREE_OPERAND (gnu_prefix
, 1));
2044 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
2045 TREE_CODE (gnu_inner
) == COMPONENT_REF
2046 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
2047 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
2050 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
2051 bit_position (TREE_OPERAND (gnu_inner
, 1)));
2053 = size_binop (PLUS_EXPR
, gnu_field_offset
,
2054 byte_position (TREE_OPERAND (gnu_inner
, 1)));
2057 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
2059 gnu_field_bitpos
= bit_position (gnu_prefix
);
2060 gnu_field_offset
= byte_position (gnu_prefix
);
2064 gnu_field_bitpos
= bitsize_zero_node
;
2065 gnu_field_offset
= size_zero_node
;
2071 gnu_result
= gnu_field_offset
;
2074 case Attr_First_Bit
:
2076 gnu_result
= size_int (bitpos
% BITS_PER_UNIT
);
2080 gnu_result
= bitsize_int (bitpos
% BITS_PER_UNIT
);
2081 gnu_result
= size_binop (PLUS_EXPR
, gnu_result
,
2082 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
2083 /* ??? Avoid a large unsigned result that will overflow when
2084 converted to the signed universal_integer. */
2085 if (integer_zerop (gnu_result
))
2086 gnu_result
= integer_minus_one_node
;
2089 = size_binop (MINUS_EXPR
, gnu_result
, bitsize_one_node
);
2092 case Attr_Bit_Position
:
2093 gnu_result
= gnu_field_bitpos
;
2097 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2099 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
2106 tree gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
2107 tree gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
2109 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2110 gnu_result
= build_binary_op (attribute
== Attr_Min
2111 ? MIN_EXPR
: MAX_EXPR
,
2112 gnu_result_type
, gnu_lhs
, gnu_rhs
);
2116 case Attr_Passed_By_Reference
:
2117 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
2118 || must_pass_by_ref (gnu_type
));
2119 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2122 case Attr_Component_Size
:
2123 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
2124 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
2125 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
2127 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
2128 gnu_type
= TREE_TYPE (gnu_prefix
);
2130 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
2131 gnu_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
2133 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
2134 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
2135 gnu_type
= TREE_TYPE (gnu_type
);
2137 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
2139 /* Note this size cannot be self-referential. */
2140 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
2141 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2142 prefix_unused
= true;
2145 case Attr_Descriptor_Size
:
2146 gnu_type
= TREE_TYPE (gnu_prefix
);
2147 gcc_assert (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
);
2149 /* What we want is the offset of the ARRAY field in the record
2150 that the thin pointer designates. */
2151 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
2152 gnu_result
= bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
2153 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2154 prefix_unused
= true;
2157 case Attr_Null_Parameter
:
2158 /* This is just a zero cast to the pointer type for our prefix and
2160 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2162 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
2163 convert (build_pointer_type (gnu_result_type
),
2164 integer_zero_node
));
2165 TREE_PRIVATE (gnu_result
) = 1;
2168 case Attr_Mechanism_Code
:
2171 Entity_Id gnat_obj
= Entity (Prefix (gnat_node
));
2173 prefix_unused
= true;
2174 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2175 if (Present (Expressions (gnat_node
)))
2177 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
2179 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
2180 i
--, gnat_obj
= Next_Formal (gnat_obj
))
2184 code
= Mechanism (gnat_obj
);
2185 if (code
== Default
)
2186 code
= ((present_gnu_tree (gnat_obj
)
2187 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
2188 || ((TREE_CODE (get_gnu_tree (gnat_obj
))
2190 && (DECL_BY_COMPONENT_PTR_P
2191 (get_gnu_tree (gnat_obj
))))))
2192 ? By_Reference
: By_Copy
);
2193 gnu_result
= convert (gnu_result_type
, size_int (- code
));
2198 /* This abort means that we have an unimplemented attribute. */
2202 /* If this is an attribute where the prefix was unused, force a use of it if
2203 it has a side-effect. But don't do it if the prefix is just an entity
2204 name. However, if an access check is needed, we must do it. See second
2205 example in AARM 11.6(5.e). */
2206 if (prefix_unused
&& TREE_SIDE_EFFECTS (gnu_prefix
)
2207 && !Is_Entity_Name (Prefix (gnat_node
)))
2208 gnu_result
= build_compound_expr (TREE_TYPE (gnu_result
), gnu_prefix
,
2211 *gnu_result_type_p
= gnu_result_type
;
2215 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2216 to a GCC tree, which is returned. */
2219 Case_Statement_to_gnu (Node_Id gnat_node
)
2221 tree gnu_result
, gnu_expr
, gnu_label
;
2223 location_t end_locus
;
2224 bool may_fallthru
= false;
2226 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2227 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2229 /* The range of values in a case statement is determined by the rules in
2230 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
2231 of the expression. One exception arises in the case of a simple name that
2232 is parenthesized. This still has the Etype of the name, but since it is
2233 not a name, para 7 does not apply, and we need to go to the base type.
2234 This is the only case where parenthesization affects the dynamic
2235 semantics (i.e. the range of possible values at run time that is covered
2236 by the others alternative).
2238 Another exception is if the subtype of the expression is non-static. In
2239 that case, we also have to use the base type. */
2240 if (Paren_Count (Expression (gnat_node
)) != 0
2241 || !Is_OK_Static_Subtype (Underlying_Type
2242 (Etype (Expression (gnat_node
)))))
2243 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2245 /* We build a SWITCH_EXPR that contains the code with interspersed
2246 CASE_LABEL_EXPRs for each label. */
2247 if (!Sloc_to_locus (Sloc (gnat_node
) + UI_To_Int (End_Span (gnat_node
)),
2249 end_locus
= input_location
;
2250 gnu_label
= create_artificial_label (end_locus
);
2251 start_stmt_group ();
2253 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2254 Present (gnat_when
);
2255 gnat_when
= Next_Non_Pragma (gnat_when
))
2257 bool choices_added_p
= false;
2258 Node_Id gnat_choice
;
2260 /* First compile all the different case choices for the current WHEN
2262 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2263 Present (gnat_choice
); gnat_choice
= Next (gnat_choice
))
2265 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2267 switch (Nkind (gnat_choice
))
2270 gnu_low
= gnat_to_gnu (Low_Bound (gnat_choice
));
2271 gnu_high
= gnat_to_gnu (High_Bound (gnat_choice
));
2274 case N_Subtype_Indication
:
2275 gnu_low
= gnat_to_gnu (Low_Bound (Range_Expression
2276 (Constraint (gnat_choice
))));
2277 gnu_high
= gnat_to_gnu (High_Bound (Range_Expression
2278 (Constraint (gnat_choice
))));
2282 case N_Expanded_Name
:
2283 /* This represents either a subtype range or a static value of
2284 some kind; Ekind says which. */
2285 if (IN (Ekind (Entity (gnat_choice
)), Type_Kind
))
2287 tree gnu_type
= get_unpadded_type (Entity (gnat_choice
));
2289 gnu_low
= fold (TYPE_MIN_VALUE (gnu_type
));
2290 gnu_high
= fold (TYPE_MAX_VALUE (gnu_type
));
2294 /* ... fall through ... */
2296 case N_Character_Literal
:
2297 case N_Integer_Literal
:
2298 gnu_low
= gnat_to_gnu (gnat_choice
);
2301 case N_Others_Choice
:
2308 /* If the case value is a subtype that raises Constraint_Error at
2309 run time because of a wrong bound, then gnu_low or gnu_high is
2310 not translated into an INTEGER_CST. In such a case, we need
2311 to ensure that the when statement is not added in the tree,
2312 otherwise it will crash the gimplifier. */
2313 if ((!gnu_low
|| TREE_CODE (gnu_low
) == INTEGER_CST
)
2314 && (!gnu_high
|| TREE_CODE (gnu_high
) == INTEGER_CST
))
2316 add_stmt_with_node (build_case_label
2318 create_artificial_label (input_location
)),
2320 choices_added_p
= true;
2324 /* Push a binding level here in case variables are declared as we want
2325 them to be local to this set of statements instead of to the block
2326 containing the Case statement. */
2327 if (choices_added_p
)
2329 tree group
= build_stmt_group (Statements (gnat_when
), true);
2330 bool group_may_fallthru
= block_may_fallthru (group
);
2332 if (group_may_fallthru
)
2334 tree stmt
= build1 (GOTO_EXPR
, void_type_node
, gnu_label
);
2335 SET_EXPR_LOCATION (stmt
, end_locus
);
2337 may_fallthru
= true;
2342 /* Now emit a definition of the label the cases branch to, if any. */
2344 add_stmt (build1 (LABEL_EXPR
, void_type_node
, gnu_label
));
2345 gnu_result
= build3 (SWITCH_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
,
2346 end_stmt_group (), NULL_TREE
);
2351 /* Find out whether VAR is an iteration variable of an enclosing loop in the
2352 current function. If so, push a range_check_info structure onto the stack
2353 of this enclosing loop and return it. Otherwise, return NULL. */
2355 static struct range_check_info_d
*
2356 push_range_check_info (tree var
)
2358 struct loop_info_d
*iter
= NULL
;
2361 if (vec_safe_is_empty (gnu_loop_stack
))
2364 var
= remove_conversions (var
, false);
2366 if (TREE_CODE (var
) != VAR_DECL
)
2369 if (decl_function_context (var
) != current_function_decl
)
2372 for (i
= vec_safe_length (gnu_loop_stack
) - 1;
2373 vec_safe_iterate (gnu_loop_stack
, i
, &iter
);
2375 if (var
== iter
->loop_var
)
2380 struct range_check_info_d
*rci
= ggc_alloc_range_check_info_d ();
2381 vec_safe_push (iter
->checks
, rci
);
2388 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2389 false, or the maximum value if MAX is true, of TYPE. */
2392 can_equal_min_or_max_val_p (tree val
, tree type
, bool max
)
2394 tree min_or_max_val
= (max
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
));
2396 if (TREE_CODE (min_or_max_val
) != INTEGER_CST
)
2399 if (TREE_CODE (val
) == NOP_EXPR
)
2401 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0)))
2402 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0))));
2404 if (TREE_CODE (val
) != INTEGER_CST
)
2407 return tree_int_cst_equal (val
, min_or_max_val
) == 1;
2410 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2411 If REVERSE is true, minimum value is taken as maximum value. */
2414 can_equal_min_val_p (tree val
, tree type
, bool reverse
)
2416 return can_equal_min_or_max_val_p (val
, type
, reverse
);
2419 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2420 If REVERSE is true, maximum value is taken as minimum value. */
2423 can_equal_max_val_p (tree val
, tree type
, bool reverse
)
2425 return can_equal_min_or_max_val_p (val
, type
, !reverse
);
2428 /* Return true if VAL1 can be lower than VAL2. */
2431 can_be_lower_p (tree val1
, tree val2
)
2433 if (TREE_CODE (val1
) == NOP_EXPR
)
2434 val1
= TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1
, 0)));
2436 if (TREE_CODE (val1
) != INTEGER_CST
)
2439 if (TREE_CODE (val2
) == NOP_EXPR
)
2440 val2
= TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2
, 0)));
2442 if (TREE_CODE (val2
) != INTEGER_CST
)
2445 return tree_int_cst_lt (val1
, val2
);
2448 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2449 to a GCC tree, which is returned. */
2452 Loop_Statement_to_gnu (Node_Id gnat_node
)
2454 const Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2455 struct loop_info_d
*gnu_loop_info
= ggc_alloc_cleared_loop_info_d ();
2456 tree gnu_loop_stmt
= build4 (LOOP_STMT
, void_type_node
, NULL_TREE
,
2457 NULL_TREE
, NULL_TREE
, NULL_TREE
);
2458 tree gnu_loop_label
= create_artificial_label (input_location
);
2459 tree gnu_cond_expr
= NULL_TREE
, gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2462 /* Push the loop_info structure associated with the LOOP_STMT. */
2463 vec_safe_push (gnu_loop_stack
, gnu_loop_info
);
2465 /* Set location information for statement and end label. */
2466 set_expr_location_from_node (gnu_loop_stmt
, gnat_node
);
2467 Sloc_to_locus (Sloc (End_Label (gnat_node
)),
2468 &DECL_SOURCE_LOCATION (gnu_loop_label
));
2469 LOOP_STMT_LABEL (gnu_loop_stmt
) = gnu_loop_label
;
2471 /* Save the statement for later reuse. */
2472 gnu_loop_info
->stmt
= gnu_loop_stmt
;
2474 /* Set the condition under which the loop must keep going.
2475 For the case "LOOP .... END LOOP;" the condition is always true. */
2476 if (No (gnat_iter_scheme
))
2479 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2480 else if (Present (Condition (gnat_iter_scheme
)))
2481 LOOP_STMT_COND (gnu_loop_stmt
)
2482 = gnat_to_gnu (Condition (gnat_iter_scheme
));
2484 /* Otherwise we have an iteration scheme and the condition is given by the
2485 bounds of the subtype of the iteration variable. */
2488 Node_Id gnat_loop_spec
= Loop_Parameter_Specification (gnat_iter_scheme
);
2489 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2490 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2491 tree gnu_type
= get_unpadded_type (gnat_type
);
2492 tree gnu_base_type
= get_base_type (gnu_type
);
2493 tree gnu_one_node
= convert (gnu_base_type
, integer_one_node
);
2494 tree gnu_loop_var
, gnu_loop_iv
, gnu_first
, gnu_last
, gnu_stmt
;
2495 enum tree_code update_code
, test_code
, shift_code
;
2496 bool reverse
= Reverse_Present (gnat_loop_spec
), use_iv
= false;
2498 gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2499 gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2501 /* We must disable modulo reduction for the iteration variable, if any,
2502 in order for the loop comparison to be effective. */
2505 gnu_first
= gnu_high
;
2507 update_code
= MINUS_NOMOD_EXPR
;
2508 test_code
= GE_EXPR
;
2509 shift_code
= PLUS_NOMOD_EXPR
;
2513 gnu_first
= gnu_low
;
2514 gnu_last
= gnu_high
;
2515 update_code
= PLUS_NOMOD_EXPR
;
2516 test_code
= LE_EXPR
;
2517 shift_code
= MINUS_NOMOD_EXPR
;
2520 /* We use two different strategies to translate the loop, depending on
2521 whether optimization is enabled.
2523 If it is, we generate the canonical loop form expected by the loop
2524 optimizer and the loop vectorizer, which is the do-while form:
2533 This avoids an implicit dependency on loop header copying and makes
2534 it possible to turn BOTTOM_COND into an inequality test.
2536 If optimization is disabled, loop header copying doesn't come into
2537 play and we try to generate the loop form with the fewer conditional
2538 branches. First, the default form, which is:
2546 It should catch most loops with constant ending point. Then, if we
2547 cannot, we try to generate the shifted form:
2555 which should catch loops with constant starting point. Otherwise, if
2556 we cannot, we generate the fallback form:
2565 which works in all cases. */
2569 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
2571 if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
))
2574 /* Otherwise, use the do-while form with the help of a special
2575 induction variable in the unsigned version of the base type
2576 or the unsigned version of the size type, whichever is the
2577 largest, in order to have wrap-around arithmetics for it. */
2580 if (TYPE_PRECISION (gnu_base_type
)
2581 > TYPE_PRECISION (size_type_node
))
2583 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type
), 1);
2585 gnu_base_type
= size_type_node
;
2587 gnu_first
= convert (gnu_base_type
, gnu_first
);
2588 gnu_last
= convert (gnu_base_type
, gnu_last
);
2589 gnu_one_node
= convert (gnu_base_type
, integer_one_node
);
2594 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
2596 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
2597 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
2601 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
2602 if (!can_equal_max_val_p (gnu_last
, gnu_base_type
, reverse
))
2605 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2607 else if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
)
2608 && !can_equal_min_val_p (gnu_last
, gnu_base_type
, reverse
))
2611 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
2614 = build_binary_op (shift_code
, gnu_base_type
, gnu_last
,
2616 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
2619 /* Otherwise, use the fallback form. */
2621 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
2624 /* If we use the BOTTOM_COND, we can turn the test into an inequality
2625 test but we may have to add ENTRY_COND to protect the empty loop. */
2626 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
))
2628 test_code
= NE_EXPR
;
2629 if (can_be_lower_p (gnu_high
, gnu_low
))
2632 = build3 (COND_EXPR
, void_type_node
,
2633 build_binary_op (LE_EXPR
, boolean_type_node
,
2635 NULL_TREE
, alloc_stmt_list ());
2636 set_expr_location_from_node (gnu_cond_expr
, gnat_loop_spec
);
2640 /* Open a new nesting level that will surround the loop to declare the
2641 iteration variable. */
2642 start_stmt_group ();
2645 /* If we use the special induction variable, create it and set it to
2646 its initial value. Morever, the regular iteration variable cannot
2647 itself be initialized, lest the initial value wrapped around. */
2651 = create_init_temporary ("I", gnu_first
, &gnu_stmt
, gnat_loop_var
);
2652 add_stmt (gnu_stmt
);
2653 gnu_first
= NULL_TREE
;
2656 gnu_loop_iv
= NULL_TREE
;
2658 /* Declare the iteration variable and set it to its initial value. */
2659 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, 1);
2660 if (DECL_BY_REF_P (gnu_loop_var
))
2661 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_loop_var
);
2664 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var
));
2665 SET_DECL_INDUCTION_VAR (gnu_loop_var
, gnu_loop_iv
);
2667 gnu_loop_info
->loop_var
= gnu_loop_var
;
2669 /* Do all the arithmetics in the base type. */
2670 gnu_loop_var
= convert (gnu_base_type
, gnu_loop_var
);
2672 /* Set either the top or bottom exit condition. */
2674 LOOP_STMT_COND (gnu_loop_stmt
)
2675 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_iv
,
2678 LOOP_STMT_COND (gnu_loop_stmt
)
2679 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_var
,
2682 /* Set either the top or bottom update statement and give it the source
2683 location of the iteration for better coverage info. */
2687 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_iv
,
2688 build_binary_op (update_code
, gnu_base_type
,
2689 gnu_loop_iv
, gnu_one_node
));
2690 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
2691 append_to_statement_list (gnu_stmt
,
2692 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
2694 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
2696 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
2697 append_to_statement_list (gnu_stmt
,
2698 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
2703 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
2704 build_binary_op (update_code
, gnu_base_type
,
2705 gnu_loop_var
, gnu_one_node
));
2706 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
2707 LOOP_STMT_UPDATE (gnu_loop_stmt
) = gnu_stmt
;
2711 /* If the loop was named, have the name point to this loop. In this case,
2712 the association is not a DECL node, but the end label of the loop. */
2713 if (Present (Identifier (gnat_node
)))
2714 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_label
, true);
2716 /* Make the loop body into its own block, so any allocated storage will be
2717 released every iteration. This is needed for stack allocation. */
2718 LOOP_STMT_BODY (gnu_loop_stmt
)
2719 = build_stmt_group (Statements (gnat_node
), true);
2720 TREE_SIDE_EFFECTS (gnu_loop_stmt
) = 1;
2722 /* If we have an iteration scheme, then we are in a statement group. Add
2723 the LOOP_STMT to it, finish it and make it the "loop". */
2724 if (Present (gnat_iter_scheme
) && No (Condition (gnat_iter_scheme
)))
2726 struct range_check_info_d
*rci
;
2727 unsigned n_checks
= vec_safe_length (gnu_loop_info
->checks
);
2730 /* First, if we have computed a small number of invariant conditions for
2731 range checks applied to the iteration variable, then initialize these
2732 conditions in front of the loop. Otherwise, leave them set to True.
2734 ??? The heuristics need to be improved, by taking into account the
2735 following datapoints:
2736 - loop unswitching is disabled for big loops. The cap is the
2737 parameter PARAM_MAX_UNSWITCH_INSNS (50).
2738 - loop unswitching can only be applied a small number of times
2739 to a given loop. The cap is PARAM_MAX_UNSWITCH_LEVEL (3).
2740 - the front-end quickly generates useless or redundant checks
2741 that can be entirely optimized away in the end. */
2742 if (1 <= n_checks
&& n_checks
<= 4)
2744 vec_safe_iterate (gnu_loop_info
->checks
, i
, &rci
);
2749 ? build_binary_op (GE_EXPR
, boolean_type_node
,
2750 convert (rci
->type
, gnu_low
),
2752 : boolean_true_node
;
2756 ? build_binary_op (LE_EXPR
, boolean_type_node
,
2757 convert (rci
->type
, gnu_high
),
2759 : boolean_true_node
;
2762 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
2765 TREE_OPERAND (rci
->invariant_cond
, 0)
2766 = build_unary_op (TRUTH_NOT_EXPR
, boolean_type_node
, range_ok
);
2768 add_stmt_with_node_force (rci
->invariant_cond
, gnat_node
);
2771 add_stmt (gnu_loop_stmt
);
2773 gnu_loop_stmt
= end_stmt_group ();
2776 /* If we have an outer COND_EXPR, that's our result and this loop is its
2777 "true" statement. Otherwise, the result is the LOOP_STMT. */
2780 COND_EXPR_THEN (gnu_cond_expr
) = gnu_loop_stmt
;
2781 gnu_result
= gnu_cond_expr
;
2782 recalculate_side_effects (gnu_cond_expr
);
2785 gnu_result
= gnu_loop_stmt
;
2787 gnu_loop_stack
->pop ();
2792 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2793 handler for the current function. */
2795 /* This is implemented by issuing a call to the appropriate VMS specific
2796 builtin. To avoid having VMS specific sections in the global gigi decls
2797 array, we maintain the decls of interest here. We can't declare them
2798 inside the function because we must mark them never to be GC'd, which we
2799 can only do at the global level. */
2801 static GTY(()) tree vms_builtin_establish_handler_decl
= NULL_TREE
;
2802 static GTY(()) tree gnat_vms_condition_handler_decl
= NULL_TREE
;
2805 establish_gnat_vms_condition_handler (void)
2807 tree establish_stmt
;
2809 /* Elaborate the required decls on the first call. Check on the decl for
2810 the gnat condition handler to decide, as this is one we create so we are
2811 sure that it will be non null on subsequent calls. The builtin decl is
2812 looked up so remains null on targets where it is not implemented yet. */
2813 if (gnat_vms_condition_handler_decl
== NULL_TREE
)
2815 vms_builtin_establish_handler_decl
2817 (get_identifier ("__builtin_establish_vms_condition_handler"));
2819 gnat_vms_condition_handler_decl
2820 = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2822 build_function_type_list (boolean_type_node
,
2826 NULL_TREE
, is_disabled
, true, true, true, NULL
,
2829 /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */
2830 DECL_CONTEXT (gnat_vms_condition_handler_decl
) = NULL_TREE
;
2833 /* Do nothing if the establish builtin is not available, which might happen
2834 on targets where the facility is not implemented. */
2835 if (vms_builtin_establish_handler_decl
== NULL_TREE
)
2839 = build_call_n_expr (vms_builtin_establish_handler_decl
, 1,
2841 (ADDR_EXPR
, NULL_TREE
,
2842 gnat_vms_condition_handler_decl
));
2844 add_stmt (establish_stmt
);
2847 /* This page implements a form of Named Return Value optimization modelled
2848 on the C++ optimization of the same name. The main difference is that
2849 we disregard any semantical considerations when applying it here, the
2850 counterpart being that we don't try to apply it to semantically loaded
2851 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
2853 We consider a function body of the following GENERIC form:
2857 RETURN_EXPR [<retval> = ...]
2859 RETURN_EXPR [<retval> = R1]
2863 RETURN_EXPR [<retval> = ...]
2865 RETURN_EXPR [<retval> = Ri]
2868 and we try to fulfill a simple criterion that would make it possible to
2869 replace one or several Ri variables with the RESULT_DECL of the function.
2871 The first observation is that RETURN_EXPRs that don't directly reference
2872 any of the Ri variables on the RHS of their assignment are transparent wrt
2873 the optimization. This is because the Ri variables aren't addressable so
2874 any transformation applied to them doesn't affect the RHS; moreover, the
2875 assignment writes the full <retval> object so existing values are entirely
2878 This property can be extended to some forms of RETURN_EXPRs that reference
2879 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
2880 case, in particular when function calls are involved.
2882 Therefore the algorithm is as follows:
2884 1. Collect the list of candidates for a Named Return Value (Ri variables
2885 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
2886 other expressions on the RHS of such assignments.
2888 2. Prune the members of the first list (candidates) that are referenced
2889 by a member of the second list (expressions).
2891 3. Extract a set of candidates with non-overlapping live ranges from the
2892 first list. These are the Named Return Values.
2894 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
2895 Named Return Values in the function with the RESULT_DECL.
2897 If the function returns an unconstrained type, things are a bit different
2898 because the anonymous return object is allocated on the secondary stack
2899 and RESULT_DECL is only a pointer to it. Each return object can be of a
2900 different size and is allocated separately so we need not care about the
2901 aforementioned overlapping issues. Therefore, we don't collect the other
2902 expressions and skip step #2 in the algorithm. */
2909 struct pointer_set_t
*visited
;
2912 /* Return true if T is a Named Return Value. */
2915 is_nrv_p (bitmap nrv
, tree t
)
2917 return TREE_CODE (t
) == VAR_DECL
&& bitmap_bit_p (nrv
, DECL_UID (t
));
2920 /* Helper function for walk_tree, used by finalize_nrv below. */
2923 prune_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
2925 struct nrv_data
*dp
= (struct nrv_data
*)data
;
2928 /* No need to walk into types or decls. */
2929 if (IS_TYPE_OR_DECL_P (t
))
2932 if (is_nrv_p (dp
->nrv
, t
))
2933 bitmap_clear_bit (dp
->nrv
, DECL_UID (t
));
2938 /* Prune Named Return Values in BLOCK and return true if there is still a
2939 Named Return Value in BLOCK or one of its sub-blocks. */
2942 prune_nrv_in_block (bitmap nrv
, tree block
)
2944 bool has_nrv
= false;
2947 /* First recurse on the sub-blocks. */
2948 for (t
= BLOCK_SUBBLOCKS (block
); t
; t
= BLOCK_CHAIN (t
))
2949 has_nrv
|= prune_nrv_in_block (nrv
, t
);
2951 /* Then make sure to keep at most one NRV per block. */
2952 for (t
= BLOCK_VARS (block
); t
; t
= DECL_CHAIN (t
))
2953 if (is_nrv_p (nrv
, t
))
2956 bitmap_clear_bit (nrv
, DECL_UID (t
));
2964 /* Helper function for walk_tree, used by finalize_nrv below. */
2967 finalize_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
2969 struct nrv_data
*dp
= (struct nrv_data
*)data
;
2972 /* No need to walk into types. */
2976 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
2977 nop, but differs from using NULL_TREE in that it indicates that we care
2978 about the value of the RESULT_DECL. */
2979 else if (TREE_CODE (t
) == RETURN_EXPR
2980 && TREE_CODE (TREE_OPERAND (t
, 0)) == MODIFY_EXPR
)
2982 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1), init_expr
;
2984 /* If this is the temporary created for a return value with variable
2985 size in Call_to_gnu, we replace the RHS with the init expression. */
2986 if (TREE_CODE (ret_val
) == COMPOUND_EXPR
2987 && TREE_CODE (TREE_OPERAND (ret_val
, 0)) == INIT_EXPR
2988 && TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 0)
2989 == TREE_OPERAND (ret_val
, 1))
2991 init_expr
= TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 1);
2992 ret_val
= TREE_OPERAND (ret_val
, 1);
2995 init_expr
= NULL_TREE
;
2997 /* Strip useless conversions around the return value. */
2998 if (gnat_useless_type_conversion (ret_val
))
2999 ret_val
= TREE_OPERAND (ret_val
, 0);
3001 if (is_nrv_p (dp
->nrv
, ret_val
))
3004 TREE_OPERAND (TREE_OPERAND (t
, 0), 1) = init_expr
;
3006 TREE_OPERAND (t
, 0) = dp
->result
;
3010 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3012 else if (TREE_CODE (t
) == DECL_EXPR
3013 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
3015 tree var
= DECL_EXPR_DECL (t
), init
;
3017 if (DECL_INITIAL (var
))
3019 init
= build_binary_op (INIT_EXPR
, NULL_TREE
, dp
->result
,
3020 DECL_INITIAL (var
));
3021 SET_EXPR_LOCATION (init
, EXPR_LOCATION (t
));
3022 DECL_INITIAL (var
) = NULL_TREE
;
3025 init
= build_empty_stmt (EXPR_LOCATION (t
));
3028 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3029 SET_DECL_VALUE_EXPR (var
, dp
->result
);
3030 DECL_HAS_VALUE_EXPR_P (var
) = 1;
3031 /* ??? Kludge to avoid an assertion failure during inlining. */
3032 DECL_SIZE (var
) = bitsize_unit_node
;
3033 DECL_SIZE_UNIT (var
) = size_one_node
;
3036 /* And replace all uses of NRVs with the RESULT_DECL. */
3037 else if (is_nrv_p (dp
->nrv
, t
))
3038 *tp
= convert (TREE_TYPE (t
), dp
->result
);
3040 /* Avoid walking into the same tree more than once. Unfortunately, we
3041 can't just use walk_tree_without_duplicates because it would only
3042 call us for the first occurrence of NRVs in the function body. */
3043 if (pointer_set_insert (dp
->visited
, *tp
))
3049 /* Likewise, but used when the function returns an unconstrained type. */
3052 finalize_nrv_unc_r (tree
*tp
, int *walk_subtrees
, void *data
)
3054 struct nrv_data
*dp
= (struct nrv_data
*)data
;
3057 /* No need to walk into types. */
3061 /* We need to see the DECL_EXPR of NRVs before any other references so we
3062 walk the body of BIND_EXPR before walking its variables. */
3063 else if (TREE_CODE (t
) == BIND_EXPR
)
3064 walk_tree (&BIND_EXPR_BODY (t
), finalize_nrv_unc_r
, data
, NULL
);
3066 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3067 return value built by the allocator instead of the whole construct. */
3068 else if (TREE_CODE (t
) == RETURN_EXPR
3069 && TREE_CODE (TREE_OPERAND (t
, 0)) == MODIFY_EXPR
)
3071 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1);
3073 /* This is the construct returned by the allocator. */
3074 if (TREE_CODE (ret_val
) == COMPOUND_EXPR
3075 && TREE_CODE (TREE_OPERAND (ret_val
, 0)) == INIT_EXPR
)
3077 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val
)))
3079 = (*CONSTRUCTOR_ELTS (TREE_OPERAND (TREE_OPERAND (ret_val
, 0),
3082 ret_val
= TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 1);
3085 /* Strip useless conversions around the return value. */
3086 if (gnat_useless_type_conversion (ret_val
)
3087 || TREE_CODE (ret_val
) == VIEW_CONVERT_EXPR
)
3088 ret_val
= TREE_OPERAND (ret_val
, 0);
3090 /* Strip unpadding around the return value. */
3091 if (TREE_CODE (ret_val
) == COMPONENT_REF
3092 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
3093 ret_val
= TREE_OPERAND (ret_val
, 0);
3095 /* Assign the new return value to the RESULT_DECL. */
3096 if (is_nrv_p (dp
->nrv
, ret_val
))
3097 TREE_OPERAND (TREE_OPERAND (t
, 0), 1)
3098 = TREE_OPERAND (DECL_INITIAL (ret_val
), 0);
3101 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3102 into a new variable. */
3103 else if (TREE_CODE (t
) == DECL_EXPR
3104 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
3106 tree saved_current_function_decl
= current_function_decl
;
3107 tree var
= DECL_EXPR_DECL (t
);
3108 tree alloc
, p_array
, new_var
, new_ret
;
3109 vec
<constructor_elt
, va_gc
> *v
;
3112 /* Create an artificial context to build the allocation. */
3113 current_function_decl
= decl_function_context (var
);
3114 start_stmt_group ();
3117 /* This will return a COMPOUND_EXPR with the allocation in the first
3118 arm and the final return value in the second arm. */
3119 alloc
= build_allocator (TREE_TYPE (var
), DECL_INITIAL (var
),
3120 TREE_TYPE (dp
->result
),
3121 Procedure_To_Call (dp
->gnat_ret
),
3122 Storage_Pool (dp
->gnat_ret
),
3125 /* The new variable is built as a reference to the allocated space. */
3127 = build_decl (DECL_SOURCE_LOCATION (var
), VAR_DECL
, DECL_NAME (var
),
3128 build_reference_type (TREE_TYPE (var
)));
3129 DECL_BY_REFERENCE (new_var
) = 1;
3131 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc
)))
3133 /* The new initial value is a COMPOUND_EXPR with the allocation in
3134 the first arm and the value of P_ARRAY in the second arm. */
3135 DECL_INITIAL (new_var
)
3136 = build2 (COMPOUND_EXPR
, TREE_TYPE (new_var
),
3137 TREE_OPERAND (alloc
, 0),
3138 (*CONSTRUCTOR_ELTS (TREE_OPERAND (alloc
, 1)))[0].value
);
3140 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3141 p_array
= TYPE_FIELDS (TREE_TYPE (alloc
));
3142 CONSTRUCTOR_APPEND_ELT (v
, p_array
,
3143 fold_convert (TREE_TYPE (p_array
), new_var
));
3144 CONSTRUCTOR_APPEND_ELT (v
, DECL_CHAIN (p_array
),
3145 (*CONSTRUCTOR_ELTS (
3146 TREE_OPERAND (alloc
, 1)))[1].value
);
3147 new_ret
= build_constructor (TREE_TYPE (alloc
), v
);
3151 /* The new initial value is just the allocation. */
3152 DECL_INITIAL (new_var
) = alloc
;
3153 new_ret
= fold_convert (TREE_TYPE (alloc
), new_var
);
3156 gnat_pushdecl (new_var
, Empty
);
3158 /* Destroy the artificial context and insert the new statements. */
3160 *tp
= end_stmt_group ();
3161 current_function_decl
= saved_current_function_decl
;
3163 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3164 DECL_CHAIN (new_var
) = DECL_CHAIN (var
);
3165 DECL_CHAIN (var
) = new_var
;
3166 DECL_IGNORED_P (var
) = 1;
3168 /* Save the new return value and the dereference of NEW_VAR. */
3170 = build2 (COMPOUND_EXPR
, TREE_TYPE (var
), new_ret
,
3171 build1 (INDIRECT_REF
, TREE_TYPE (var
), new_var
));
3172 /* ??? Kludge to avoid messing up during inlining. */
3173 DECL_CONTEXT (var
) = NULL_TREE
;
3176 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3177 else if (is_nrv_p (dp
->nrv
, t
))
3178 *tp
= TREE_OPERAND (DECL_INITIAL (t
), 1);
3180 /* Avoid walking into the same tree more than once. Unfortunately, we
3181 can't just use walk_tree_without_duplicates because it would only
3182 call us for the first occurrence of NRVs in the function body. */
3183 if (pointer_set_insert (dp
->visited
, *tp
))
3189 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3190 contains the candidates for Named Return Value and OTHER is a list of
3191 the other return values. GNAT_RET is a representative return node. */
3194 finalize_nrv (tree fndecl
, bitmap nrv
, vec
<tree
, va_gc
> *other
, Node_Id gnat_ret
)
3196 struct cgraph_node
*node
;
3197 struct nrv_data data
;
3202 /* We shouldn't be applying the optimization to return types that we aren't
3203 allowed to manipulate freely. */
3204 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl
))));
3206 /* Prune the candidates that are referenced by other return values. */
3208 data
.result
= NULL_TREE
;
3209 data
.visited
= NULL
;
3210 for (i
= 0; vec_safe_iterate (other
, i
, &iter
); i
++)
3211 walk_tree_without_duplicates (&iter
, prune_nrv_r
, &data
);
3212 if (bitmap_empty_p (nrv
))
3215 /* Prune also the candidates that are referenced by nested functions. */
3216 node
= cgraph_get_create_node (fndecl
);
3217 for (node
= node
->nested
; node
; node
= node
->next_nested
)
3218 walk_tree_without_duplicates (&DECL_SAVED_TREE (node
->symbol
.decl
), prune_nrv_r
,
3220 if (bitmap_empty_p (nrv
))
3223 /* Extract a set of NRVs with non-overlapping live ranges. */
3224 if (!prune_nrv_in_block (nrv
, DECL_INITIAL (fndecl
)))
3227 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3229 data
.result
= DECL_RESULT (fndecl
);
3230 data
.gnat_ret
= gnat_ret
;
3231 data
.visited
= pointer_set_create ();
3232 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl
)))
3233 func
= finalize_nrv_unc_r
;
3235 func
= finalize_nrv_r
;
3236 walk_tree (&DECL_SAVED_TREE (fndecl
), func
, &data
, NULL
);
3237 pointer_set_destroy (data
.visited
);
3240 /* Return true if RET_VAL can be used as a Named Return Value for the
3241 anonymous return object RET_OBJ. */
3244 return_value_ok_for_nrv_p (tree ret_obj
, tree ret_val
)
3246 if (TREE_CODE (ret_val
) != VAR_DECL
)
3249 if (TREE_THIS_VOLATILE (ret_val
))
3252 if (DECL_CONTEXT (ret_val
) != current_function_decl
)
3255 if (TREE_STATIC (ret_val
))
3258 if (TREE_ADDRESSABLE (ret_val
))
3261 if (ret_obj
&& DECL_ALIGN (ret_val
) > DECL_ALIGN (ret_obj
))
3267 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3268 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3269 around RESULT_OBJ, which may be null in this case. */
3272 build_return_expr (tree ret_obj
, tree ret_val
)
3278 /* The gimplifier explicitly enforces the following invariant:
3287 As a consequence, type consistency dictates that we use the type
3288 of the RET_OBJ as the operation type. */
3289 tree operation_type
= TREE_TYPE (ret_obj
);
3291 /* Convert the right operand to the operation type. Note that it's the
3292 same transformation as in the MODIFY_EXPR case of build_binary_op,
3293 with the assumption that the type cannot involve a placeholder. */
3294 if (operation_type
!= TREE_TYPE (ret_val
))
3295 ret_val
= convert (operation_type
, ret_val
);
3297 result_expr
= build2 (MODIFY_EXPR
, void_type_node
, ret_obj
, ret_val
);
3299 /* If the function returns an aggregate type, find out whether this is
3300 a candidate for Named Return Value. If so, record it. Otherwise,
3301 if this is an expression of some kind, record it elsewhere. */
3303 && AGGREGATE_TYPE_P (operation_type
)
3304 && !TYPE_IS_FAT_POINTER_P (operation_type
)
3305 && TYPE_MODE (operation_type
) == BLKmode
3306 && aggregate_value_p (operation_type
, current_function_decl
))
3308 /* Recognize the temporary created for a return value with variable
3309 size in Call_to_gnu. We want to eliminate it if possible. */
3310 if (TREE_CODE (ret_val
) == COMPOUND_EXPR
3311 && TREE_CODE (TREE_OPERAND (ret_val
, 0)) == INIT_EXPR
3312 && TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 0)
3313 == TREE_OPERAND (ret_val
, 1))
3314 ret_val
= TREE_OPERAND (ret_val
, 1);
3316 /* Strip useless conversions around the return value. */
3317 if (gnat_useless_type_conversion (ret_val
))
3318 ret_val
= TREE_OPERAND (ret_val
, 0);
3320 /* Now apply the test to the return value. */
3321 if (return_value_ok_for_nrv_p (ret_obj
, ret_val
))
3323 if (!f_named_ret_val
)
3324 f_named_ret_val
= BITMAP_GGC_ALLOC ();
3325 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
3328 /* Note that we need not care about CONSTRUCTORs here, as they are
3329 totally transparent given the read-compose-write semantics of
3330 assignments from CONSTRUCTORs. */
3331 else if (EXPR_P (ret_val
))
3332 vec_safe_push (f_other_ret_val
, ret_val
);
3336 result_expr
= ret_obj
;
3338 return build1 (RETURN_EXPR
, void_type_node
, result_expr
);
3341 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
3342 and the GNAT node GNAT_SUBPROG. */
3345 build_function_stub (tree gnu_subprog
, Entity_Id gnat_subprog
)
3347 tree gnu_subprog_type
, gnu_subprog_addr
, gnu_subprog_call
;
3348 tree gnu_subprog_param
, gnu_stub_param
, gnu_param
;
3349 tree gnu_stub_decl
= DECL_FUNCTION_STUB (gnu_subprog
);
3350 vec
<tree
, va_gc
> *gnu_param_vec
= NULL
;
3352 gnu_subprog_type
= TREE_TYPE (gnu_subprog
);
3354 /* Initialize the information structure for the function. */
3355 allocate_struct_function (gnu_stub_decl
, false);
3358 begin_subprog_body (gnu_stub_decl
);
3360 start_stmt_group ();
3363 /* Loop over the parameters of the stub and translate any of them
3364 passed by descriptor into a by reference one. */
3365 for (gnu_stub_param
= DECL_ARGUMENTS (gnu_stub_decl
),
3366 gnu_subprog_param
= DECL_ARGUMENTS (gnu_subprog
);
3368 gnu_stub_param
= DECL_CHAIN (gnu_stub_param
),
3369 gnu_subprog_param
= DECL_CHAIN (gnu_subprog_param
))
3371 if (DECL_BY_DESCRIPTOR_P (gnu_stub_param
))
3373 gcc_assert (DECL_BY_REF_P (gnu_subprog_param
));
3375 = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param
),
3377 DECL_PARM_ALT_TYPE (gnu_stub_param
),
3378 DECL_BY_DOUBLE_REF_P (gnu_subprog_param
),
3382 gnu_param
= gnu_stub_param
;
3384 vec_safe_push (gnu_param_vec
, gnu_param
);
3387 /* Invoke the internal subprogram. */
3388 gnu_subprog_addr
= build1 (ADDR_EXPR
, build_pointer_type (gnu_subprog_type
),
3390 gnu_subprog_call
= build_call_vec (TREE_TYPE (gnu_subprog_type
),
3391 gnu_subprog_addr
, gnu_param_vec
);
3393 /* Propagate the return value, if any. */
3394 if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type
)))
3395 add_stmt (gnu_subprog_call
);
3397 add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl
),
3401 end_subprog_body (end_stmt_group ());
3402 rest_of_subprog_body_compilation (gnu_stub_decl
);
3405 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3406 don't return anything. */
3409 Subprogram_Body_to_gnu (Node_Id gnat_node
)
3411 /* Defining identifier of a parameter to the subprogram. */
3412 Entity_Id gnat_param
;
3413 /* The defining identifier for the subprogram body. Note that if a
3414 specification has appeared before for this body, then the identifier
3415 occurring in that specification will also be a defining identifier and all
3416 the calls to this subprogram will point to that specification. */
3417 Entity_Id gnat_subprog_id
3418 = (Present (Corresponding_Spec (gnat_node
))
3419 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
3420 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3421 tree gnu_subprog_decl
;
3422 /* Its RESULT_DECL node. */
3423 tree gnu_result_decl
;
3424 /* Its FUNCTION_TYPE node. */
3425 tree gnu_subprog_type
;
3426 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3428 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3429 tree gnu_return_var_elmt
= NULL_TREE
;
3431 struct language_function
*gnu_subprog_language
;
3432 vec
<parm_attr
, va_gc
> *cache
;
3434 /* If this is a generic object or if it has been eliminated,
3436 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
3437 || Ekind (gnat_subprog_id
) == E_Generic_Function
3438 || Is_Eliminated (gnat_subprog_id
))
3441 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3442 the already-elaborated tree node. However, if this subprogram had its
3443 elaboration deferred, we will already have made a tree node for it. So
3444 treat it as not being defined in that case. Such a subprogram cannot
3445 have an address clause or a freeze node, so this test is safe, though it
3446 does disable some otherwise-useful error checking. */
3448 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
3449 Acts_As_Spec (gnat_node
)
3450 && !present_gnu_tree (gnat_subprog_id
));
3451 gnu_result_decl
= DECL_RESULT (gnu_subprog_decl
);
3452 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
3453 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3455 gnu_return_var_elmt
= value_member (void_type_node
, gnu_cico_list
);
3457 /* If the function returns by invisible reference, make it explicit in the
3458 function body. See gnat_to_gnu_entity, E_Subprogram_Type case.
3459 Handle the explicit case here and the copy-in/copy-out case below. */
3460 if (TREE_ADDRESSABLE (gnu_subprog_type
) && !gnu_return_var_elmt
)
3462 TREE_TYPE (gnu_result_decl
)
3463 = build_reference_type (TREE_TYPE (gnu_result_decl
));
3464 relayout_decl (gnu_result_decl
);
3467 /* Set the line number in the decl to correspond to that of the body so that
3468 the line number notes are written correctly. */
3469 Sloc_to_locus (Sloc (gnat_node
), &DECL_SOURCE_LOCATION (gnu_subprog_decl
));
3471 /* Initialize the information structure for the function. */
3472 allocate_struct_function (gnu_subprog_decl
, false);
3473 gnu_subprog_language
= ggc_alloc_cleared_language_function ();
3474 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->language
= gnu_subprog_language
;
3477 begin_subprog_body (gnu_subprog_decl
);
3479 /* If there are In Out or Out parameters, we need to ensure that the return
3480 statement properly copies them out. We do this by making a new block and
3481 converting any return into a goto to a label at the end of the block. */
3484 tree gnu_return_var
= NULL_TREE
;
3486 vec_safe_push (gnu_return_label_stack
,
3487 create_artificial_label (input_location
));
3489 start_stmt_group ();
3492 /* If this is a function with In Out or Out parameters, we also need a
3493 variable for the return value to be placed. */
3494 if (gnu_return_var_elmt
)
3496 tree gnu_return_type
3497 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt
));
3499 /* If the function returns by invisible reference, make it
3500 explicit in the function body. See gnat_to_gnu_entity,
3501 E_Subprogram_Type case. */
3502 if (TREE_ADDRESSABLE (gnu_subprog_type
))
3503 gnu_return_type
= build_reference_type (gnu_return_type
);
3506 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE
,
3507 gnu_return_type
, NULL_TREE
, false, false,
3508 false, false, NULL
, gnat_subprog_id
);
3509 TREE_VALUE (gnu_return_var_elmt
) = gnu_return_var
;
3512 vec_safe_push (gnu_return_var_stack
, gnu_return_var
);
3514 /* See whether there are parameters for which we don't have a GCC tree
3515 yet. These must be Out parameters. Make a VAR_DECL for them and
3516 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3517 We can match up the entries because TYPE_CI_CO_LIST is in the order
3518 of the parameters. */
3519 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
3520 Present (gnat_param
);
3521 gnat_param
= Next_Formal_With_Extras (gnat_param
))
3522 if (!present_gnu_tree (gnat_param
))
3524 tree gnu_cico_entry
= gnu_cico_list
;
3527 /* Skip any entries that have been already filled in; they must
3528 correspond to In Out parameters. */
3529 while (gnu_cico_entry
&& TREE_VALUE (gnu_cico_entry
))
3530 gnu_cico_entry
= TREE_CHAIN (gnu_cico_entry
);
3532 /* Do any needed dereferences for by-ref objects. */
3533 gnu_decl
= gnat_to_gnu_entity (gnat_param
, NULL_TREE
, 1);
3534 gcc_assert (DECL_P (gnu_decl
));
3535 if (DECL_BY_REF_P (gnu_decl
))
3536 gnu_decl
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_decl
);
3538 /* Do any needed references for padded types. */
3539 TREE_VALUE (gnu_cico_entry
)
3540 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry
)), gnu_decl
);
3544 vec_safe_push (gnu_return_label_stack
, NULL_TREE
);
3546 /* Get a tree corresponding to the code for the subprogram. */
3547 start_stmt_group ();
3550 /* On VMS, establish our condition handler to possibly turn a condition into
3551 the corresponding exception if the subprogram has a foreign convention or
3554 To ensure proper execution of local finalizations on condition instances,
3555 we must turn a condition into the corresponding exception even if there
3556 is no applicable Ada handler, and need at least one condition handler per
3557 possible call chain involving GNAT code. OTOH, establishing the handler
3558 has a cost so we want to minimize the number of subprograms into which
3559 this happens. The foreign or exported condition is expected to satisfy
3560 all the constraints. */
3561 if (TARGET_ABI_OPEN_VMS
3562 && (Has_Foreign_Convention (gnat_subprog_id
)
3563 || Is_Exported (gnat_subprog_id
)))
3564 establish_gnat_vms_condition_handler ();
3566 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
3568 /* Generate the code of the subprogram itself. A return statement will be
3569 present and any Out parameters will be handled there. */
3570 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
3572 gnu_result
= end_stmt_group ();
3574 /* If we populated the parameter attributes cache, we need to make sure that
3575 the cached expressions are evaluated on all the possible paths leading to
3576 their uses. So we force their evaluation on entry of the function. */
3577 cache
= gnu_subprog_language
->parm_attr_cache
;
3580 struct parm_attr_d
*pa
;
3583 start_stmt_group ();
3585 FOR_EACH_VEC_ELT (*cache
, i
, pa
)
3588 add_stmt_with_node_force (pa
->first
, gnat_node
);
3590 add_stmt_with_node_force (pa
->last
, gnat_node
);
3592 add_stmt_with_node_force (pa
->length
, gnat_node
);
3595 add_stmt (gnu_result
);
3596 gnu_result
= end_stmt_group ();
3598 gnu_subprog_language
->parm_attr_cache
= NULL
;
3601 /* If we are dealing with a return from an Ada procedure with parameters
3602 passed by copy-in/copy-out, we need to return a record containing the
3603 final values of these parameters. If the list contains only one entry,
3604 return just that entry though.
3606 For a full description of the copy-in/copy-out parameter mechanism, see
3607 the part of the gnat_to_gnu_entity routine dealing with the translation
3610 We need to make a block that contains the definition of that label and
3611 the copying of the return value. It first contains the function, then
3612 the label and copy statement. */
3617 add_stmt (gnu_result
);
3618 add_stmt (build1 (LABEL_EXPR
, void_type_node
,
3619 gnu_return_label_stack
->last ()));
3621 if (list_length (gnu_cico_list
) == 1)
3622 gnu_retval
= TREE_VALUE (gnu_cico_list
);
3624 gnu_retval
= build_constructor_from_list (TREE_TYPE (gnu_subprog_type
),
3627 add_stmt_with_node (build_return_expr (gnu_result_decl
, gnu_retval
),
3628 End_Label (Handled_Statement_Sequence (gnat_node
)));
3630 gnu_result
= end_stmt_group ();
3633 gnu_return_label_stack
->pop ();
3635 /* Attempt setting the end_locus of our GCC body tree, typically a
3636 BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
3637 declaration tree. */
3638 set_end_locus_from_node (gnu_result
, gnat_node
);
3639 set_end_locus_from_node (gnu_subprog_decl
, gnat_node
);
3641 /* On SEH targets, install an exception handler around the main entry
3642 point to catch unhandled exceptions. */
3643 if (DECL_NAME (gnu_subprog_decl
) == main_identifier_node
3644 && targetm_common
.except_unwind_info (&global_options
) == UI_SEH
)
3649 t
= build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
3650 1, integer_zero_node
);
3651 t
= build_call_n_expr (unhandled_except_decl
, 1, t
);
3653 etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, unhandled_others_decl
);
3654 etype
= tree_cons (NULL_TREE
, etype
, NULL_TREE
);
3656 t
= build2 (CATCH_EXPR
, void_type_node
, etype
, t
);
3657 gnu_result
= build2 (TRY_CATCH_EXPR
, TREE_TYPE (gnu_result
),
3661 end_subprog_body (gnu_result
);
3663 /* Finally annotate the parameters and disconnect the trees for parameters
3664 that we have turned into variables since they are now unusable. */
3665 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
3666 Present (gnat_param
);
3667 gnat_param
= Next_Formal_With_Extras (gnat_param
))
3669 tree gnu_param
= get_gnu_tree (gnat_param
);
3670 bool is_var_decl
= (TREE_CODE (gnu_param
) == VAR_DECL
);
3672 annotate_object (gnat_param
, TREE_TYPE (gnu_param
), NULL_TREE
,
3673 DECL_BY_REF_P (gnu_param
),
3674 !is_var_decl
&& DECL_BY_DOUBLE_REF_P (gnu_param
));
3677 save_gnu_tree (gnat_param
, NULL_TREE
, false);
3680 /* Disconnect the variable created for the return value. */
3681 if (gnu_return_var_elmt
)
3682 TREE_VALUE (gnu_return_var_elmt
) = void_type_node
;
3684 /* If the function returns an aggregate type and we have candidates for
3685 a Named Return Value, finalize the optimization. */
3686 if (optimize
&& gnu_subprog_language
->named_ret_val
)
3688 finalize_nrv (gnu_subprog_decl
,
3689 gnu_subprog_language
->named_ret_val
,
3690 gnu_subprog_language
->other_ret_val
,
3691 gnu_subprog_language
->gnat_ret
);
3692 gnu_subprog_language
->named_ret_val
= NULL
;
3693 gnu_subprog_language
->other_ret_val
= NULL
;
3696 rest_of_subprog_body_compilation (gnu_subprog_decl
);
3698 /* If there is a stub associated with the function, build it now. */
3699 if (DECL_FUNCTION_STUB (gnu_subprog_decl
))
3700 build_function_stub (gnu_subprog_decl
, gnat_subprog_id
);
3703 /* Return true if GNAT_NODE requires atomic synchronization. */
3706 atomic_sync_required_p (Node_Id gnat_node
)
3708 const Node_Id gnat_parent
= Parent (gnat_node
);
3710 unsigned char attr_id
;
3712 /* First, scan the node to find the Atomic_Sync_Required flag. */
3713 kind
= Nkind (gnat_node
);
3714 if (kind
== N_Type_Conversion
|| kind
== N_Unchecked_Type_Conversion
)
3716 gnat_node
= Expression (gnat_node
);
3717 kind
= Nkind (gnat_node
);
3722 case N_Expanded_Name
:
3723 case N_Explicit_Dereference
:
3725 case N_Indexed_Component
:
3726 case N_Selected_Component
:
3727 if (!Atomic_Sync_Required (gnat_node
))
3735 /* Then, scan the parent to find out cases where the flag is irrelevant. */
3736 kind
= Nkind (gnat_parent
);
3739 case N_Attribute_Reference
:
3740 attr_id
= Get_Attribute_Id (Attribute_Name (gnat_parent
));
3741 /* Do not mess up machine code insertions. */
3742 if (attr_id
== Attr_Asm_Input
|| attr_id
== Attr_Asm_Output
)
3746 case N_Object_Renaming_Declaration
:
3747 /* Do not generate a function call as a renamed object. */
3757 /* Create a temporary variable with PREFIX and TYPE, and return it. */
3760 create_temporary (const char *prefix
, tree type
)
3762 tree gnu_temp
= create_var_decl (create_tmp_var_name (prefix
), NULL_TREE
,
3763 type
, NULL_TREE
, false, false, false, false,
3765 DECL_ARTIFICIAL (gnu_temp
) = 1;
3766 DECL_IGNORED_P (gnu_temp
) = 1;
3771 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
3772 Put the initialization statement into GNU_INIT_STMT and annotate it with
3773 the SLOC of GNAT_NODE. Return the temporary variable. */
3776 create_init_temporary (const char *prefix
, tree gnu_init
, tree
*gnu_init_stmt
,
3779 tree gnu_temp
= create_temporary (prefix
, TREE_TYPE (gnu_init
));
3781 *gnu_init_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_temp
, gnu_init
);
3782 set_expr_location_from_node (*gnu_init_stmt
, gnat_node
);
3787 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
3788 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
3789 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
3790 If GNU_TARGET is non-null, this must be a function call on the RHS of a
3791 N_Assignment_Statement and the result is to be placed into that object.
3792 If, in addition, ATOMIC_SYNC is true, then the assignment to GNU_TARGET
3793 requires atomic synchronization. */
3796 Call_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, tree gnu_target
,
3799 const bool function_call
= (Nkind (gnat_node
) == N_Function_Call
);
3800 const bool returning_value
= (function_call
&& !gnu_target
);
3801 /* The GCC node corresponding to the GNAT subprogram name. This can either
3802 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
3803 or an indirect reference expression (an INDIRECT_REF node) pointing to a
3805 tree gnu_subprog
= gnat_to_gnu (Name (gnat_node
));
3806 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
3807 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog
);
3808 /* The return type of the FUNCTION_TYPE. */
3809 tree gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
3810 tree gnu_subprog_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog
);
3811 vec
<tree
, va_gc
> *gnu_actual_vec
= NULL
;
3812 tree gnu_name_list
= NULL_TREE
;
3813 tree gnu_stmt_list
= NULL_TREE
;
3814 tree gnu_after_list
= NULL_TREE
;
3815 tree gnu_retval
= NULL_TREE
;
3816 tree gnu_call
, gnu_result
;
3817 bool went_into_elab_proc
= false;
3818 bool pushed_binding_level
= false;
3819 Entity_Id gnat_formal
;
3820 Node_Id gnat_actual
;
3822 gcc_assert (TREE_CODE (gnu_subprog_type
) == FUNCTION_TYPE
);
3824 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
3825 all our args first. */
3826 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
&& DECL_STUBBED_P (gnu_subprog
))
3828 tree call_expr
= build_call_raise (PE_Stubbed_Subprogram_Called
,
3829 gnat_node
, N_Raise_Program_Error
);
3831 for (gnat_actual
= First_Actual (gnat_node
);
3832 Present (gnat_actual
);
3833 gnat_actual
= Next_Actual (gnat_actual
))
3834 add_stmt (gnat_to_gnu (gnat_actual
));
3836 if (returning_value
)
3838 *gnu_result_type_p
= gnu_result_type
;
3839 return build1 (NULL_EXPR
, gnu_result_type
, call_expr
);
3845 /* The only way we can be making a call via an access type is if Name is an
3846 explicit dereference. In that case, get the list of formal args from the
3847 type the access type is pointing to. Otherwise, get the formals from the
3848 entity being called. */
3849 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3850 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
3851 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
3852 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
3853 gnat_formal
= Empty
;
3855 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
3857 /* The lifetime of the temporaries created for the call ends right after the
3858 return value is copied, so we can give them the scope of the elaboration
3859 routine at top level. */
3860 if (!current_function_decl
)
3862 current_function_decl
= get_elaboration_procedure ();
3863 went_into_elab_proc
= true;
3866 /* First, create the temporary for the return value when:
3868 1. There is no target and the function has copy-in/copy-out parameters,
3869 because we need to preserve the return value before copying back the
3872 2. There is no target and this is not an object declaration, and the
3873 return type has variable size, because in these cases the gimplifier
3874 cannot create the temporary.
3876 3. There is a target and it is a slice or an array with fixed size,
3877 and the return type has variable size, because the gimplifier
3878 doesn't handle these cases.
3880 This must be done before we push a binding level around the call, since
3881 we will pop it before copying the return value. */
3883 && ((!gnu_target
&& TYPE_CI_CO_LIST (gnu_subprog_type
))
3885 && Nkind (Parent (gnat_node
)) != N_Object_Declaration
3886 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
)
3888 && (TREE_CODE (gnu_target
) == ARRAY_RANGE_REF
3889 || (TREE_CODE (TREE_TYPE (gnu_target
)) == ARRAY_TYPE
3890 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target
)))
3892 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
)))
3893 gnu_retval
= create_temporary ("R", gnu_result_type
);
3895 /* Create the list of the actual parameters as GCC expects it, namely a
3896 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
3897 is an expression and the TREE_PURPOSE field is null. But skip Out
3898 parameters not passed by reference and that need not be copied in. */
3899 for (gnat_actual
= First_Actual (gnat_node
);
3900 Present (gnat_actual
);
3901 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3902 gnat_actual
= Next_Actual (gnat_actual
))
3904 tree gnu_formal
= present_gnu_tree (gnat_formal
)
3905 ? get_gnu_tree (gnat_formal
) : NULL_TREE
;
3906 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
3907 const bool is_true_formal_parm
3908 = gnu_formal
&& TREE_CODE (gnu_formal
) == PARM_DECL
;
3909 const bool is_by_ref_formal_parm
3910 = is_true_formal_parm
3911 && (DECL_BY_REF_P (gnu_formal
)
3912 || DECL_BY_COMPONENT_PTR_P (gnu_formal
)
3913 || DECL_BY_DESCRIPTOR_P (gnu_formal
));
3914 /* In the Out or In Out case, we must suppress conversions that yield
3915 an lvalue but can nevertheless cause the creation of a temporary,
3916 because we need the real object in this case, either to pass its
3917 address if it's passed by reference or as target of the back copy
3918 done after the call if it uses the copy-in/copy-out mechanism.
3919 We do it in the In case too, except for an unchecked conversion
3920 because it alone can cause the actual to be misaligned and the
3921 addressability test is applied to the real object. */
3922 const bool suppress_type_conversion
3923 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
3924 && Ekind (gnat_formal
) != E_In_Parameter
)
3925 || (Nkind (gnat_actual
) == N_Type_Conversion
3926 && Is_Composite_Type (Underlying_Type (Etype (gnat_formal
)))));
3927 Node_Id gnat_name
= suppress_type_conversion
3928 ? Expression (gnat_actual
) : gnat_actual
;
3929 tree gnu_name
= gnat_to_gnu (gnat_name
), gnu_name_type
;
3932 /* If it's possible we may need to use this expression twice, make sure
3933 that any side-effects are handled via SAVE_EXPRs; likewise if we need
3934 to force side-effects before the call.
3935 ??? This is more conservative than we need since we don't need to do
3936 this for pass-by-ref with no conversion. */
3937 if (Ekind (gnat_formal
) != E_In_Parameter
)
3938 gnu_name
= gnat_stabilize_reference (gnu_name
, true, NULL
);
3940 /* If we are passing a non-addressable parameter by reference, pass the
3941 address of a copy. In the Out or In Out case, set up to copy back
3942 out after the call. */
3943 if (is_by_ref_formal_parm
3944 && (gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
)))
3945 && !addressable_p (gnu_name
, gnu_name_type
))
3947 bool in_param
= (Ekind (gnat_formal
) == E_In_Parameter
);
3948 tree gnu_orig
= gnu_name
, gnu_temp
, gnu_stmt
;
3950 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
3951 but sort of an instantiation for them. */
3952 if (TREE_CODE (gnu_name
) == CONSTRUCTOR
)
3955 /* If the type is passed by reference, a copy is not allowed. */
3956 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type
))
3957 post_error ("misaligned actual cannot be passed by reference",
3960 /* For users of Starlet we issue a warning because the interface
3961 apparently assumes that by-ref parameters outlive the procedure
3962 invocation. The code still will not work as intended, but we
3963 cannot do much better since low-level parts of the back-end
3964 would allocate temporaries at will because of the misalignment
3965 if we did not do so here. */
3966 else if (Is_Valued_Procedure (Entity (Name (gnat_node
))))
3969 ("?possible violation of implicit assumption", gnat_actual
);
3971 ("?made by pragma Import_Valued_Procedure on &", gnat_actual
,
3972 Entity (Name (gnat_node
)));
3973 post_error_ne ("?because of misalignment of &", gnat_actual
,
3977 /* If the actual type of the object is already the nominal type,
3978 we have nothing to do, except if the size is self-referential
3979 in which case we'll remove the unpadding below. */
3980 if (TREE_TYPE (gnu_name
) == gnu_name_type
3981 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type
)))
3984 /* Otherwise remove the unpadding from all the objects. */
3985 else if (TREE_CODE (gnu_name
) == COMPONENT_REF
3986 && TYPE_IS_PADDING_P
3987 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))
3988 gnu_orig
= gnu_name
= TREE_OPERAND (gnu_name
, 0);
3990 /* Otherwise convert to the nominal type of the object if needed.
3991 There are several cases in which we need to make the temporary
3992 using this type instead of the actual type of the object when
3993 they are distinct, because the expectations of the callee would
3994 otherwise not be met:
3995 - if it's a justified modular type,
3996 - if the actual type is a smaller form of it,
3997 - if it's a smaller form of the actual type. */
3998 else if ((TREE_CODE (gnu_name_type
) == RECORD_TYPE
3999 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type
)
4000 || smaller_form_type_p (TREE_TYPE (gnu_name
),
4002 || (INTEGRAL_TYPE_P (gnu_name_type
)
4003 && smaller_form_type_p (gnu_name_type
,
4004 TREE_TYPE (gnu_name
))))
4005 gnu_name
= convert (gnu_name_type
, gnu_name
);
4007 /* If this is an In Out or Out parameter and we're returning a value,
4008 we need to create a temporary for the return value because we must
4009 preserve it before copying back at the very end. */
4010 if (!in_param
&& returning_value
&& !gnu_retval
)
4011 gnu_retval
= create_temporary ("R", gnu_result_type
);
4013 /* If we haven't pushed a binding level, push a new one. This will
4014 narrow the lifetime of the temporary we are about to make as much
4015 as possible. The drawback is that we'd need to create a temporary
4016 for the return value, if any (see comment before the loop). So do
4017 it only when this temporary was already created just above. */
4018 if (!pushed_binding_level
&& !(in_param
&& returning_value
))
4020 start_stmt_group ();
4022 pushed_binding_level
= true;
4025 /* Create an explicit temporary holding the copy. */
4027 = create_init_temporary ("A", gnu_name
, &gnu_stmt
, gnat_actual
);
4029 /* But initialize it on the fly like for an implicit temporary as
4030 we aren't necessarily having a statement list. */
4031 gnu_name
= build_compound_expr (TREE_TYPE (gnu_name
), gnu_stmt
,
4034 /* Set up to move the copy back to the original if needed. */
4037 gnu_stmt
= build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_orig
,
4039 set_expr_location_from_node (gnu_stmt
, gnat_node
);
4040 append_to_statement_list (gnu_stmt
, &gnu_after_list
);
4044 /* Start from the real object and build the actual. */
4045 gnu_actual
= gnu_name
;
4047 /* If this is an atomic access of an In or In Out parameter for which
4048 synchronization is required, build the atomic load. */
4049 if (is_true_formal_parm
4050 && !is_by_ref_formal_parm
4051 && Ekind (gnat_formal
) != E_Out_Parameter
4052 && atomic_sync_required_p (gnat_actual
))
4053 gnu_actual
= build_atomic_load (gnu_actual
);
4055 /* If this was a procedure call, we may not have removed any padding.
4056 So do it here for the part we will use as an input, if any. */
4057 if (Ekind (gnat_formal
) != E_Out_Parameter
4058 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
4060 = convert (get_unpadded_type (Etype (gnat_actual
)), gnu_actual
);
4062 /* Put back the conversion we suppressed above in the computation of the
4063 real object. And even if we didn't suppress any conversion there, we
4064 may have suppressed a conversion to the Etype of the actual earlier,
4065 since the parent is a procedure call, so put it back here. */
4066 if (suppress_type_conversion
4067 && Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
4069 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
4070 gnu_actual
, No_Truncation (gnat_actual
));
4073 = convert (gnat_to_gnu_type (Etype (gnat_actual
)), gnu_actual
);
4075 /* Make sure that the actual is in range of the formal's type. */
4076 if (Ekind (gnat_formal
) != E_Out_Parameter
4077 && Do_Range_Check (gnat_actual
))
4079 = emit_range_check (gnu_actual
, Etype (gnat_formal
), gnat_actual
);
4081 /* Unless this is an In parameter, we must remove any justified modular
4082 building from GNU_NAME to get an lvalue. */
4083 if (Ekind (gnat_formal
) != E_In_Parameter
4084 && TREE_CODE (gnu_name
) == CONSTRUCTOR
4085 && TREE_CODE (TREE_TYPE (gnu_name
)) == RECORD_TYPE
4086 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name
)))
4088 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name
))), gnu_name
);
4090 /* If we have not saved a GCC object for the formal, it means it is an
4091 Out parameter not passed by reference and that need not be copied in.
4092 Otherwise, first see if the parameter is passed by reference. */
4093 if (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
))
4095 if (Ekind (gnat_formal
) != E_In_Parameter
)
4097 /* In Out or Out parameters passed by reference don't use the
4098 copy-in/copy-out mechanism so the address of the real object
4099 must be passed to the function. */
4100 gnu_actual
= gnu_name
;
4102 /* If we have a padded type, be sure we've removed padding. */
4103 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
4104 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
4107 /* If we have the constructed subtype of an aliased object
4108 with an unconstrained nominal subtype, the type of the
4109 actual includes the template, although it is formally
4110 constrained. So we need to convert it back to the real
4111 constructed subtype to retrieve the constrained part
4112 and takes its address. */
4113 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
4114 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual
))
4115 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual
))
4116 && Is_Array_Type (Etype (gnat_actual
)))
4117 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
4121 /* There is no need to convert the actual to the formal's type before
4122 taking its address. The only exception is for unconstrained array
4123 types because of the way we build fat pointers. */
4124 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4126 /* Put back a view conversion for In Out or Out parameters. */
4127 if (Ekind (gnat_formal
) != E_In_Parameter
)
4128 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
4130 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4133 /* The symmetry of the paths to the type of an entity is broken here
4134 since arguments don't know that they will be passed by ref. */
4135 gnu_formal_type
= TREE_TYPE (gnu_formal
);
4137 if (DECL_BY_DOUBLE_REF_P (gnu_formal
))
4139 = build_unary_op (ADDR_EXPR
, TREE_TYPE (gnu_formal_type
),
4142 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4144 else if (is_true_formal_parm
&& DECL_BY_COMPONENT_PTR_P (gnu_formal
))
4146 gnu_formal_type
= TREE_TYPE (gnu_formal
);
4147 gnu_actual
= maybe_implicit_deref (gnu_actual
);
4148 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
4150 if (TYPE_IS_PADDING_P (gnu_formal_type
))
4152 gnu_formal_type
= TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
4153 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4156 /* Take the address of the object and convert to the proper pointer
4157 type. We'd like to actually compute the address of the beginning
4158 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4159 possibility that the ARRAY_REF might return a constant and we'd be
4160 getting the wrong address. Neither approach is exactly correct,
4161 but this is the most likely to work in all cases. */
4162 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
4164 else if (is_true_formal_parm
&& DECL_BY_DESCRIPTOR_P (gnu_formal
))
4166 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4168 /* If this is 'Null_Parameter, pass a zero descriptor. */
4169 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
4170 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
4171 && TREE_PRIVATE (gnu_actual
))
4173 = convert (DECL_ARG_TYPE (gnu_formal
), integer_zero_node
);
4175 gnu_actual
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
4177 (TREE_TYPE (TREE_TYPE (gnu_formal
)),
4178 gnu_actual
, gnat_actual
));
4184 if (Ekind (gnat_formal
) != E_In_Parameter
)
4185 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
4187 if (!is_true_formal_parm
)
4189 /* Make sure side-effects are evaluated before the call. */
4190 if (TREE_SIDE_EFFECTS (gnu_name
))
4191 append_to_statement_list (gnu_name
, &gnu_stmt_list
);
4195 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
4197 /* If this is 'Null_Parameter, pass a zero even though we are
4198 dereferencing it. */
4199 if (TREE_CODE (gnu_actual
) == INDIRECT_REF
4200 && TREE_PRIVATE (gnu_actual
)
4201 && (gnu_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
)))
4202 && TREE_CODE (gnu_size
) == INTEGER_CST
4203 && compare_tree_int (gnu_size
, BITS_PER_WORD
) <= 0)
4205 = unchecked_convert (DECL_ARG_TYPE (gnu_formal
),
4206 convert (gnat_type_for_size
4207 (TREE_INT_CST_LOW (gnu_size
), 1),
4211 gnu_actual
= convert (DECL_ARG_TYPE (gnu_formal
), gnu_actual
);
4214 vec_safe_push (gnu_actual_vec
, gnu_actual
);
4218 = build_call_vec (gnu_result_type
, gnu_subprog_addr
, gnu_actual_vec
);
4219 set_expr_location_from_node (gnu_call
, gnat_node
);
4221 /* If we have created a temporary for the return value, initialize it. */
4225 = build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_retval
, gnu_call
);
4226 set_expr_location_from_node (gnu_stmt
, gnat_node
);
4227 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
4228 gnu_call
= gnu_retval
;
4231 /* If this is a subprogram with copy-in/copy-out parameters, we need to
4232 unpack the valued returned from the function into the In Out or Out
4233 parameters. We deal with the function return (if this is an Ada
4235 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
4237 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
4238 copy-out parameters. */
4239 tree gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
4240 const int length
= list_length (gnu_cico_list
);
4242 /* The call sequence must contain one and only one call, even though the
4243 function is pure. Save the result into a temporary if needed. */
4249 /* If we haven't pushed a binding level, push a new one. This
4250 will narrow the lifetime of the temporary we are about to
4251 make as much as possible. */
4252 if (!pushed_binding_level
)
4254 start_stmt_group ();
4256 pushed_binding_level
= true;
4259 = create_init_temporary ("P", gnu_call
, &gnu_stmt
, gnat_node
);
4260 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
4263 gnu_name_list
= nreverse (gnu_name_list
);
4266 /* The first entry is for the actual return value if this is a
4267 function, so skip it. */
4269 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
4271 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
4272 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
4274 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
4276 for (gnat_actual
= First_Actual (gnat_node
);
4277 Present (gnat_actual
);
4278 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
4279 gnat_actual
= Next_Actual (gnat_actual
))
4280 /* If we are dealing with a copy-in/copy-out parameter, we must
4281 retrieve its value from the record returned in the call. */
4282 if (!(present_gnu_tree (gnat_formal
)
4283 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
4284 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
4285 || (TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
4286 && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))
4287 || (DECL_BY_DESCRIPTOR_P
4288 (get_gnu_tree (gnat_formal
))))))))
4289 && Ekind (gnat_formal
) != E_In_Parameter
)
4291 /* Get the value to assign to this Out or In Out parameter. It is
4292 either the result of the function if there is only a single such
4293 parameter or the appropriate field from the record returned. */
4297 : build_component_ref (gnu_call
, NULL_TREE
,
4298 TREE_PURPOSE (gnu_cico_list
), false);
4300 /* If the actual is a conversion, get the inner expression, which
4301 will be the real destination, and convert the result to the
4302 type of the actual parameter. */
4304 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
4306 /* If the result is a padded type, remove the padding. */
4307 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
4309 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
4312 /* If the actual is a type conversion, the real target object is
4313 denoted by the inner Expression and we need to convert the
4314 result to the associated type.
4315 We also need to convert our gnu assignment target to this type
4316 if the corresponding GNU_NAME was constructed from the GNAT
4317 conversion node and not from the inner Expression. */
4318 if (Nkind (gnat_actual
) == N_Type_Conversion
)
4321 = convert_with_check
4322 (Etype (Expression (gnat_actual
)), gnu_result
,
4323 Do_Overflow_Check (gnat_actual
),
4324 Do_Range_Check (Expression (gnat_actual
)),
4325 Float_Truncate (gnat_actual
), gnat_actual
);
4327 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal
))))
4328 gnu_actual
= convert (TREE_TYPE (gnu_result
), gnu_actual
);
4331 /* Unchecked conversions as actuals for Out parameters are not
4332 allowed in user code because they are not variables, but do
4333 occur in front-end expansions. The associated GNU_NAME is
4334 always obtained from the inner expression in such cases. */
4335 else if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
4336 gnu_result
= unchecked_convert (TREE_TYPE (gnu_actual
),
4338 No_Truncation (gnat_actual
));
4341 if (Do_Range_Check (gnat_actual
))
4343 = emit_range_check (gnu_result
, Etype (gnat_actual
),
4346 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
4347 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
4348 gnu_result
= convert (TREE_TYPE (gnu_actual
), gnu_result
);
4351 if (atomic_sync_required_p (gnat_actual
))
4352 gnu_result
= build_atomic_store (gnu_actual
, gnu_result
);
4354 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
4355 gnu_actual
, gnu_result
);
4356 set_expr_location_from_node (gnu_result
, gnat_node
);
4357 append_to_statement_list (gnu_result
, &gnu_stmt_list
);
4358 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
4359 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
4363 /* If this is a function call, the result is the call expression unless a
4364 target is specified, in which case we copy the result into the target
4365 and return the assignment statement. */
4368 /* If this is a function with copy-in/copy-out parameters, extract the
4369 return value from it and update the return type. */
4370 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
4372 tree gnu_elmt
= TYPE_CI_CO_LIST (gnu_subprog_type
);
4373 gnu_call
= build_component_ref (gnu_call
, NULL_TREE
,
4374 TREE_PURPOSE (gnu_elmt
), false);
4375 gnu_result_type
= TREE_TYPE (gnu_call
);
4378 /* If the function returns an unconstrained array or by direct reference,
4379 we have to dereference the pointer. */
4380 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
)
4381 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
))
4382 gnu_call
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_call
);
4386 Node_Id gnat_parent
= Parent (gnat_node
);
4387 enum tree_code op_code
;
4389 /* If range check is needed, emit code to generate it. */
4390 if (Do_Range_Check (gnat_node
))
4392 = emit_range_check (gnu_call
, Etype (Name (gnat_parent
)),
4395 /* ??? If the return type has variable size, then force the return
4396 slot optimization as we would not be able to create a temporary.
4397 Likewise if it was unconstrained as we would copy too much data.
4398 That's what has been done historically. */
4399 if (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
4400 || (TYPE_IS_PADDING_P (gnu_result_type
)
4401 && CONTAINS_PLACEHOLDER_P
4402 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type
))))))
4403 op_code
= INIT_EXPR
;
4405 op_code
= MODIFY_EXPR
;
4408 gnu_call
= build_atomic_store (gnu_target
, gnu_call
);
4411 = build_binary_op (op_code
, NULL_TREE
, gnu_target
, gnu_call
);
4412 set_expr_location_from_node (gnu_call
, gnat_parent
);
4413 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
4416 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
4419 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
4420 parameters, the result is just the call statement. */
4421 else if (!TYPE_CI_CO_LIST (gnu_subprog_type
))
4422 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
4424 /* Finally, add the copy back statements, if any. */
4425 append_to_statement_list (gnu_after_list
, &gnu_stmt_list
);
4427 if (went_into_elab_proc
)
4428 current_function_decl
= NULL_TREE
;
4430 /* If we have pushed a binding level, pop it and finish up the enclosing
4432 if (pushed_binding_level
)
4434 add_stmt (gnu_stmt_list
);
4436 gnu_result
= end_stmt_group ();
4439 /* Otherwise, retrieve the statement list, if any. */
4440 else if (gnu_stmt_list
)
4441 gnu_result
= gnu_stmt_list
;
4443 /* Otherwise, just return the call expression. */
4447 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
4448 But first simplify if we have only one statement in the list. */
4449 if (returning_value
)
4451 tree first
= expr_first (gnu_result
), last
= expr_last (gnu_result
);
4455 = build_compound_expr (TREE_TYPE (gnu_call
), gnu_result
, gnu_call
);
4461 /* Subroutine of gnat_to_gnu to translate gnat_node, an
4462 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
4465 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node
)
4467 tree gnu_jmpsave_decl
= NULL_TREE
;
4468 tree gnu_jmpbuf_decl
= NULL_TREE
;
4469 /* If just annotating, ignore all EH and cleanups. */
4470 bool gcc_zcx
= (!type_annotate_only
4471 && Present (Exception_Handlers (gnat_node
))
4472 && Exception_Mechanism
== Back_End_Exceptions
);
4474 = (!type_annotate_only
&& Present (Exception_Handlers (gnat_node
))
4475 && Exception_Mechanism
== Setjmp_Longjmp
);
4476 bool at_end
= !type_annotate_only
&& Present (At_End_Proc (gnat_node
));
4477 bool binding_for_block
= (at_end
|| gcc_zcx
|| setjmp_longjmp
);
4478 tree gnu_inner_block
; /* The statement(s) for the block itself. */
4483 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
4484 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
4485 add_cleanup, and when we leave the binding, end_stmt_group will create
4486 the TRY_FINALLY_EXPR.
4488 ??? The region level calls down there have been specifically put in place
4489 for a ZCX context and currently the order in which things are emitted
4490 (region/handlers) is different from the SJLJ case. Instead of putting
4491 other calls with different conditions at other places for the SJLJ case,
4492 it seems cleaner to reorder things for the SJLJ case and generalize the
4493 condition to make it not ZCX specific.
4495 If there are any exceptions or cleanup processing involved, we need an
4496 outer statement group (for Setjmp_Longjmp) and binding level. */
4497 if (binding_for_block
)
4499 start_stmt_group ();
4503 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
4504 area for address of previous buffer. Do this first since we need to have
4505 the setjmp buf known for any decls in this block. */
4509 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
4511 build_call_n_expr (get_jmpbuf_decl
, 0),
4512 false, false, false, false, NULL
, gnat_node
);
4513 DECL_ARTIFICIAL (gnu_jmpsave_decl
) = 1;
4515 /* The __builtin_setjmp receivers will immediately reinstall it. Now
4516 because of the unstructured form of EH used by setjmp_longjmp, there
4517 might be forward edges going to __builtin_setjmp receivers on which
4518 it is uninitialized, although they will never be actually taken. */
4519 TREE_NO_WARNING (gnu_jmpsave_decl
) = 1;
4521 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE
,
4524 false, false, false, false, NULL
, gnat_node
);
4525 DECL_ARTIFICIAL (gnu_jmpbuf_decl
) = 1;
4527 set_block_jmpbuf_decl (gnu_jmpbuf_decl
);
4529 /* When we exit this block, restore the saved value. */
4530 add_cleanup (build_call_n_expr (set_jmpbuf_decl
, 1, gnu_jmpsave_decl
),
4531 End_Label (gnat_node
));
4534 /* If we are to call a function when exiting this block, add a cleanup
4535 to the binding level we made above. Note that add_cleanup is FIFO
4536 so we must register this cleanup after the EH cleanup just above. */
4538 add_cleanup (build_call_n_expr (gnat_to_gnu (At_End_Proc (gnat_node
)), 0),
4539 End_Label (gnat_node
));
4541 /* Now build the tree for the declarations and statements inside this block.
4542 If this is SJLJ, set our jmp_buf as the current buffer. */
4543 start_stmt_group ();
4546 add_stmt (build_call_n_expr (set_jmpbuf_decl
, 1,
4547 build_unary_op (ADDR_EXPR
, NULL_TREE
,
4550 if (Present (First_Real_Statement (gnat_node
)))
4551 process_decls (Statements (gnat_node
), Empty
,
4552 First_Real_Statement (gnat_node
), true, true);
4554 /* Generate code for each statement in the block. */
4555 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
4556 ? First_Real_Statement (gnat_node
)
4557 : First (Statements (gnat_node
)));
4558 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
4559 add_stmt (gnat_to_gnu (gnat_temp
));
4560 gnu_inner_block
= end_stmt_group ();
4562 /* Now generate code for the two exception models, if either is relevant for
4566 tree
*gnu_else_ptr
= 0;
4569 /* Make a binding level for the exception handling declarations and code
4570 and set up gnu_except_ptr_stack for the handlers to use. */
4571 start_stmt_group ();
4574 vec_safe_push (gnu_except_ptr_stack
,
4575 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
4576 build_pointer_type (except_type_node
),
4577 build_call_n_expr (get_excptr_decl
, 0),
4578 false, false, false, false,
4581 /* Generate code for each handler. The N_Exception_Handler case does the
4582 real work and returns a COND_EXPR for each handler, which we chain
4584 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
4585 Present (gnat_temp
); gnat_temp
= Next_Non_Pragma (gnat_temp
))
4587 gnu_expr
= gnat_to_gnu (gnat_temp
);
4589 /* If this is the first one, set it as the outer one. Otherwise,
4590 point the "else" part of the previous handler to us. Then point
4591 to our "else" part. */
4593 add_stmt (gnu_expr
);
4595 *gnu_else_ptr
= gnu_expr
;
4597 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
4600 /* If none of the exception handlers did anything, re-raise but do not
4602 gnu_expr
= build_call_n_expr (raise_nodefer_decl
, 1,
4603 gnu_except_ptr_stack
->last ());
4604 set_expr_location_from_node
4606 Present (End_Label (gnat_node
)) ? End_Label (gnat_node
) : gnat_node
);
4609 *gnu_else_ptr
= gnu_expr
;
4611 add_stmt (gnu_expr
);
4613 /* End the binding level dedicated to the exception handlers and get the
4614 whole statement group. */
4615 gnu_except_ptr_stack
->pop ();
4617 gnu_handler
= end_stmt_group ();
4619 /* If the setjmp returns 1, we restore our incoming longjmp value and
4620 then check the handlers. */
4621 start_stmt_group ();
4622 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl
, 1,
4625 add_stmt (gnu_handler
);
4626 gnu_handler
= end_stmt_group ();
4628 /* This block is now "if (setjmp) ... <handlers> else <block>". */
4629 gnu_result
= build3 (COND_EXPR
, void_type_node
,
4632 build_unary_op (ADDR_EXPR
, NULL_TREE
,
4634 gnu_handler
, gnu_inner_block
);
4641 /* First make a block containing the handlers. */
4642 start_stmt_group ();
4643 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
4644 Present (gnat_temp
);
4645 gnat_temp
= Next_Non_Pragma (gnat_temp
))
4646 add_stmt (gnat_to_gnu (gnat_temp
));
4647 gnu_handlers
= end_stmt_group ();
4649 /* Now make the TRY_CATCH_EXPR for the block. */
4650 gnu_result
= build2 (TRY_CATCH_EXPR
, void_type_node
,
4651 gnu_inner_block
, gnu_handlers
);
4652 /* Set a location. We need to find a uniq location for the dispatching
4653 code, otherwise we can get coverage or debugging issues. Try with
4654 the location of the end label. */
4655 if (Present (End_Label (gnat_node
))
4656 && Sloc_to_locus (Sloc (End_Label (gnat_node
)), &locus
))
4657 SET_EXPR_LOCATION (gnu_result
, locus
);
4659 set_expr_location_from_node (gnu_result
, gnat_node
);
4662 gnu_result
= gnu_inner_block
;
4664 /* Now close our outer block, if we had to make one. */
4665 if (binding_for_block
)
4667 add_stmt (gnu_result
);
4669 gnu_result
= end_stmt_group ();
4675 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4676 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
4677 exception handling. */
4680 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node
)
4682 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
4683 an "if" statement to select the proper exceptions. For "Others", exclude
4684 exceptions where Handled_By_Others is nonzero unless the All_Others flag
4685 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
4686 tree gnu_choice
= boolean_false_node
;
4687 tree gnu_body
= build_stmt_group (Statements (gnat_node
), false);
4690 for (gnat_temp
= First (Exception_Choices (gnat_node
));
4691 gnat_temp
; gnat_temp
= Next (gnat_temp
))
4695 if (Nkind (gnat_temp
) == N_Others_Choice
)
4697 if (All_Others (gnat_temp
))
4698 this_choice
= boolean_true_node
;
4702 (EQ_EXPR
, boolean_type_node
,
4707 (INDIRECT_REF
, NULL_TREE
,
4708 gnu_except_ptr_stack
->last ()),
4709 get_identifier ("not_handled_by_others"), NULL_TREE
,
4714 else if (Nkind (gnat_temp
) == N_Identifier
4715 || Nkind (gnat_temp
) == N_Expanded_Name
)
4717 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
4720 /* Exception may be a renaming. Recover original exception which is
4721 the one elaborated and registered. */
4722 if (Present (Renamed_Object (gnat_ex_id
)))
4723 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
4725 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
4729 (EQ_EXPR
, boolean_type_node
,
4730 gnu_except_ptr_stack
->last (),
4731 convert (TREE_TYPE (gnu_except_ptr_stack
->last ()),
4732 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
4734 /* If this is the distinguished exception "Non_Ada_Error" (and we are
4735 in VMS mode), also allow a non-Ada exception (a VMS condition) t
4737 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
4740 = build_component_ref
4741 (build_unary_op (INDIRECT_REF
, NULL_TREE
,
4742 gnu_except_ptr_stack
->last ()),
4743 get_identifier ("lang"), NULL_TREE
, false);
4747 (TRUTH_ORIF_EXPR
, boolean_type_node
,
4748 build_binary_op (EQ_EXPR
, boolean_type_node
, gnu_comp
,
4749 build_int_cst (TREE_TYPE (gnu_comp
), 'V')),
4756 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
4757 gnu_choice
, this_choice
);
4760 return build3 (COND_EXPR
, void_type_node
, gnu_choice
, gnu_body
, NULL_TREE
);
4763 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4764 to a GCC tree, which is returned. This is the variant for ZCX. */
4767 Exception_Handler_to_gnu_zcx (Node_Id gnat_node
)
4769 tree gnu_etypes_list
= NULL_TREE
;
4772 tree gnu_current_exc_ptr
;
4773 tree prev_gnu_incoming_exc_ptr
;
4776 /* We build a TREE_LIST of nodes representing what exception types this
4777 handler can catch, with special cases for others and all others cases.
4779 Each exception type is actually identified by a pointer to the exception
4780 id, or to a dummy object for "others" and "all others". */
4781 for (gnat_temp
= First (Exception_Choices (gnat_node
));
4782 gnat_temp
; gnat_temp
= Next (gnat_temp
))
4784 if (Nkind (gnat_temp
) == N_Others_Choice
)
4787 = All_Others (gnat_temp
) ? all_others_decl
: others_decl
;
4790 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
4792 else if (Nkind (gnat_temp
) == N_Identifier
4793 || Nkind (gnat_temp
) == N_Expanded_Name
)
4795 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
4797 /* Exception may be a renaming. Recover original exception which is
4798 the one elaborated and registered. */
4799 if (Present (Renamed_Object (gnat_ex_id
)))
4800 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
4802 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
4803 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
4805 /* The Non_Ada_Error case for VMS exceptions is handled
4806 by the personality routine. */
4811 /* The GCC interface expects NULL to be passed for catch all handlers, so
4812 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
4813 is integer_zero_node. It would not work, however, because GCC's
4814 notion of "catch all" is stronger than our notion of "others". Until
4815 we correctly use the cleanup interface as well, doing that would
4816 prevent the "all others" handlers from being seen, because nothing
4817 can be caught beyond a catch all from GCC's point of view. */
4818 gnu_etypes_list
= tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
4821 start_stmt_group ();
4824 /* Expand a call to the begin_handler hook at the beginning of the handler,
4825 and arrange for a call to the end_handler hook to occur on every possible
4828 The hooks expect a pointer to the low level occurrence. This is required
4829 for our stack management scheme because a raise inside the handler pushes
4830 a new occurrence on top of the stack, which means that this top does not
4831 necessarily match the occurrence this handler was dealing with.
4833 __builtin_eh_pointer references the exception occurrence being
4834 propagated. Upon handler entry, this is the exception for which the
4835 handler is triggered. This might not be the case upon handler exit,
4836 however, as we might have a new occurrence propagated by the handler's
4837 body, and the end_handler hook called as a cleanup in this context.
4839 We use a local variable to retrieve the incoming value at handler entry
4840 time, and reuse it to feed the end_handler hook's argument at exit. */
4843 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
4844 1, integer_zero_node
);
4845 prev_gnu_incoming_exc_ptr
= gnu_incoming_exc_ptr
;
4846 gnu_incoming_exc_ptr
= create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
4847 ptr_type_node
, gnu_current_exc_ptr
,
4848 false, false, false, false,
4851 add_stmt_with_node (build_call_n_expr (begin_handler_decl
, 1,
4852 gnu_incoming_exc_ptr
),
4854 /* ??? We don't seem to have an End_Label at hand to set the location. */
4855 add_cleanup (build_call_n_expr (end_handler_decl
, 1, gnu_incoming_exc_ptr
),
4857 add_stmt_list (Statements (gnat_node
));
4860 gnu_incoming_exc_ptr
= prev_gnu_incoming_exc_ptr
;
4862 return build2 (CATCH_EXPR
, void_type_node
, gnu_etypes_list
,
4866 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
4869 Compilation_Unit_to_gnu (Node_Id gnat_node
)
4871 const Node_Id gnat_unit
= Unit (gnat_node
);
4872 const bool body_p
= (Nkind (gnat_unit
) == N_Package_Body
4873 || Nkind (gnat_unit
) == N_Subprogram_Body
);
4874 const Entity_Id gnat_unit_entity
= Defining_Entity (gnat_unit
);
4875 Node_Id gnat_pragma
;
4876 /* Make the decl for the elaboration procedure. */
4877 tree gnu_elab_proc_decl
4878 = create_subprog_decl
4879 (create_concat_name (gnat_unit_entity
, body_p
? "elabb" : "elabs"),
4880 NULL_TREE
, void_ftype
, NULL_TREE
, is_disabled
, true, false, true, NULL
,
4882 struct elab_info
*info
;
4884 vec_safe_push (gnu_elab_proc_stack
, gnu_elab_proc_decl
);
4885 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl
) = 1;
4887 /* Initialize the information structure for the function. */
4888 allocate_struct_function (gnu_elab_proc_decl
, false);
4891 current_function_decl
= NULL_TREE
;
4893 start_stmt_group ();
4896 /* For a body, first process the spec if there is one. */
4897 if (Nkind (gnat_unit
) == N_Package_Body
4898 || (Nkind (gnat_unit
) == N_Subprogram_Body
&& !Acts_As_Spec (gnat_node
)))
4899 add_stmt (gnat_to_gnu (Library_Unit (gnat_node
)));
4901 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
4903 elaborate_all_entities (gnat_node
);
4905 if (Nkind (gnat_unit
) == N_Subprogram_Declaration
4906 || Nkind (gnat_unit
) == N_Generic_Package_Declaration
4907 || Nkind (gnat_unit
) == N_Generic_Subprogram_Declaration
)
4911 /* Then process any pragmas and declarations preceding the unit. */
4912 for (gnat_pragma
= First (Context_Items (gnat_node
));
4913 Present (gnat_pragma
);
4914 gnat_pragma
= Next (gnat_pragma
))
4915 if (Nkind (gnat_pragma
) == N_Pragma
)
4916 add_stmt (gnat_to_gnu (gnat_pragma
));
4917 process_decls (Declarations (Aux_Decls_Node (gnat_node
)), Empty
, Empty
,
4920 /* Process the unit itself. */
4921 add_stmt (gnat_to_gnu (gnat_unit
));
4923 /* If we can inline, generate code for all the inlined subprograms. */
4926 Entity_Id gnat_entity
;
4928 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
4929 Present (gnat_entity
);
4930 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
4932 Node_Id gnat_body
= Parent (Declaration_Node (gnat_entity
));
4934 if (Nkind (gnat_body
) != N_Subprogram_Body
)
4936 /* ??? This really should always be present. */
4937 if (No (Corresponding_Body (gnat_body
)))
4940 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
4943 if (Present (gnat_body
))
4945 /* Define the entity first so we set DECL_EXTERNAL. */
4946 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4947 add_stmt (gnat_to_gnu (gnat_body
));
4952 /* Process any pragmas and actions following the unit. */
4953 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node
)));
4954 add_stmt_list (Actions (Aux_Decls_Node (gnat_node
)));
4955 finalize_from_with_types ();
4957 /* Save away what we've made so far and record this potential elaboration
4959 info
= ggc_alloc_elab_info ();
4960 set_current_block_context (gnu_elab_proc_decl
);
4962 DECL_SAVED_TREE (gnu_elab_proc_decl
) = end_stmt_group ();
4964 set_end_locus_from_node (gnu_elab_proc_decl
, gnat_unit
);
4966 info
->next
= elab_info_list
;
4967 info
->elab_proc
= gnu_elab_proc_decl
;
4968 info
->gnat_node
= gnat_node
;
4969 elab_info_list
= info
;
4971 /* Generate elaboration code for this unit, if necessary, and say whether
4973 gnu_elab_proc_stack
->pop ();
4975 /* Invalidate the global renaming pointers. This is necessary because
4976 stabilization of the renamed entities may create SAVE_EXPRs which
4977 have been tied to a specific elaboration routine just above. */
4978 invalidate_global_renaming_pointers ();
4981 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Raise_xxx_Error,
4982 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where
4983 we should place the result type. LABEL_P is true if there is a label to
4984 branch to for the exception. */
4987 Raise_Error_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
4989 const Node_Kind kind
= Nkind (gnat_node
);
4990 const int reason
= UI_To_Int (Reason (gnat_node
));
4991 const Node_Id gnat_cond
= Condition (gnat_node
);
4992 const bool with_extra_info
4993 = Exception_Extra_Info
4994 && !No_Exception_Handlers_Set ()
4995 && !get_exception_label (kind
);
4996 tree gnu_result
= NULL_TREE
, gnu_cond
= NULL_TREE
;
4998 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
5002 case CE_Access_Check_Failed
:
5003 if (with_extra_info
)
5004 gnu_result
= build_call_raise_column (reason
, gnat_node
);
5007 case CE_Index_Check_Failed
:
5008 case CE_Range_Check_Failed
:
5009 case CE_Invalid_Data
:
5010 if (Present (gnat_cond
) && Nkind (gnat_cond
) == N_Op_Not
)
5012 Node_Id gnat_range
, gnat_index
, gnat_type
;
5013 tree gnu_index
, gnu_low_bound
, gnu_high_bound
;
5014 struct range_check_info_d
*rci
;
5016 switch (Nkind (Right_Opnd (gnat_cond
)))
5019 gnat_range
= Right_Opnd (Right_Opnd (gnat_cond
));
5020 gcc_assert (Nkind (gnat_range
) == N_Range
);
5021 gnu_low_bound
= gnat_to_gnu (Low_Bound (gnat_range
));
5022 gnu_high_bound
= gnat_to_gnu (High_Bound (gnat_range
));
5026 gnu_low_bound
= gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond
)));
5027 gnu_high_bound
= NULL_TREE
;
5031 gnu_low_bound
= NULL_TREE
;
5032 gnu_high_bound
= gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond
)));
5039 gnat_index
= Left_Opnd (Right_Opnd (gnat_cond
));
5040 gnat_type
= Etype (gnat_index
);
5041 gnu_index
= gnat_to_gnu (gnat_index
);
5046 && Known_Esize (gnat_type
)
5047 && UI_To_Int (Esize (gnat_type
)) <= 32)
5049 = build_call_raise_range (reason
, gnat_node
, gnu_index
,
5050 gnu_low_bound
, gnu_high_bound
);
5052 /* If loop unswitching is enabled, we try to compute invariant
5053 conditions for checks applied to iteration variables, i.e.
5054 conditions that are both independent of the variable and
5055 necessary in order for the check to fail in the course of
5056 some iteration, and prepend them to the original condition
5057 of the checks. This will make it possible later for the
5058 loop unswitching pass to replace the loop with two loops,
5059 one of which has the checks eliminated and the other has
5060 the original checks reinstated, and a run time selection.
5061 The former loop will be suitable for vectorization. */
5062 if (flag_unswitch_loops
5064 || (gnu_low_bound
= gnat_invariant_expr (gnu_low_bound
)))
5066 || (gnu_high_bound
= gnat_invariant_expr (gnu_high_bound
)))
5067 && (rci
= push_range_check_info (gnu_index
)))
5069 rci
->low_bound
= gnu_low_bound
;
5070 rci
->high_bound
= gnu_high_bound
;
5071 rci
->type
= get_unpadded_type (gnat_type
);
5072 rci
->invariant_cond
= build1 (SAVE_EXPR
, boolean_type_node
,
5074 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
5076 rci
->invariant_cond
,
5077 gnat_to_gnu (gnat_cond
));
5088 gnu_result
= build_call_raise (reason
, gnat_node
, kind
);
5089 set_expr_location_from_node (gnu_result
, gnat_node
);
5091 /* If the type is VOID, this is a statement, so we need to generate the code
5092 for the call. Handle a condition, if there is one. */
5093 if (VOID_TYPE_P (*gnu_result_type_p
))
5095 if (Present (gnat_cond
))
5098 gnu_cond
= gnat_to_gnu (gnat_cond
);
5099 gnu_result
= build3 (COND_EXPR
, void_type_node
, gnu_cond
, gnu_result
,
5100 alloc_stmt_list ());
5104 gnu_result
= build1 (NULL_EXPR
, *gnu_result_type_p
, gnu_result
);
5109 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
5110 parameter of a call. */
5113 lhs_or_actual_p (Node_Id gnat_node
)
5115 Node_Id gnat_parent
= Parent (gnat_node
);
5116 Node_Kind kind
= Nkind (gnat_parent
);
5118 if (kind
== N_Assignment_Statement
&& Name (gnat_parent
) == gnat_node
)
5121 if ((kind
== N_Procedure_Call_Statement
|| kind
== N_Function_Call
)
5122 && Name (gnat_parent
) != gnat_node
)
5125 if (kind
== N_Parameter_Association
)
5131 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
5132 of an assignment or an actual parameter of a call. */
5135 present_in_lhs_or_actual_p (Node_Id gnat_node
)
5139 if (lhs_or_actual_p (gnat_node
))
5142 kind
= Nkind (Parent (gnat_node
));
5144 if ((kind
== N_Type_Conversion
|| kind
== N_Unchecked_Type_Conversion
)
5145 && lhs_or_actual_p (Parent (gnat_node
)))
5151 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
5152 as gigi is concerned. This is used to avoid conversions on the LHS. */
5155 unchecked_conversion_nop (Node_Id gnat_node
)
5157 Entity_Id from_type
, to_type
;
5159 /* The conversion must be on the LHS of an assignment or an actual parameter
5160 of a call. Otherwise, even if the conversion was essentially a no-op, it
5161 could de facto ensure type consistency and this should be preserved. */
5162 if (!lhs_or_actual_p (gnat_node
))
5165 from_type
= Etype (Expression (gnat_node
));
5167 /* We're interested in artificial conversions generated by the front-end
5168 to make private types explicit, e.g. in Expand_Assign_Array. */
5169 if (!Is_Private_Type (from_type
))
5172 from_type
= Underlying_Type (from_type
);
5173 to_type
= Etype (gnat_node
);
5175 /* The direct conversion to the underlying type is a no-op. */
5176 if (to_type
== from_type
)
5179 /* For an array subtype, the conversion to the PAT is a no-op. */
5180 if (Ekind (from_type
) == E_Array_Subtype
5181 && to_type
== Packed_Array_Type (from_type
))
5184 /* For a record subtype, the conversion to the type is a no-op. */
5185 if (Ekind (from_type
) == E_Record_Subtype
5186 && to_type
== Etype (from_type
))
5192 /* This function is the driver of the GNAT to GCC tree transformation process.
5193 It is the entry point of the tree transformer. GNAT_NODE is the root of
5194 some GNAT tree. Return the root of the corresponding GCC tree. If this
5195 is an expression, return the GCC equivalent of the expression. If this
5196 is a statement, return the statement or add it to the current statement
5197 group, in which case anything returned is to be interpreted as occurring
5198 after anything added. */
5201 gnat_to_gnu (Node_Id gnat_node
)
5203 const Node_Kind kind
= Nkind (gnat_node
);
5204 bool went_into_elab_proc
= false;
5205 tree gnu_result
= error_mark_node
; /* Default to no value. */
5206 tree gnu_result_type
= void_type_node
;
5207 tree gnu_expr
, gnu_lhs
, gnu_rhs
;
5210 /* Save node number for error message and set location information. */
5211 error_gnat_node
= gnat_node
;
5212 Sloc_to_locus (Sloc (gnat_node
), &input_location
);
5214 /* If this node is a statement and we are only annotating types, return an
5215 empty statement list. */
5216 if (type_annotate_only
&& IN (kind
, N_Statement_Other_Than_Procedure_Call
))
5217 return alloc_stmt_list ();
5219 /* If this node is a non-static subexpression and we are only annotating
5220 types, make this into a NULL_EXPR. */
5221 if (type_annotate_only
5222 && IN (kind
, N_Subexpr
)
5223 && kind
!= N_Identifier
5224 && !Compile_Time_Known_Value (gnat_node
))
5225 return build1 (NULL_EXPR
, get_unpadded_type (Etype (gnat_node
)),
5226 build_call_raise (CE_Range_Check_Failed
, gnat_node
,
5227 N_Raise_Constraint_Error
));
5229 if ((IN (kind
, N_Statement_Other_Than_Procedure_Call
)
5230 && kind
!= N_Null_Statement
)
5231 || kind
== N_Procedure_Call_Statement
5233 || kind
== N_Implicit_Label_Declaration
5234 || kind
== N_Handled_Sequence_Of_Statements
5235 || (IN (kind
, N_Raise_xxx_Error
) && Ekind (Etype (gnat_node
)) == E_Void
))
5237 tree current_elab_proc
= get_elaboration_procedure ();
5239 /* If this is a statement and we are at top level, it must be part of
5240 the elaboration procedure, so mark us as being in that procedure. */
5241 if (!current_function_decl
)
5243 current_function_decl
= current_elab_proc
;
5244 went_into_elab_proc
= true;
5247 /* If we are in the elaboration procedure, check if we are violating a
5248 No_Elaboration_Code restriction by having a statement there. Don't
5249 check for a possible No_Elaboration_Code restriction violation on
5250 N_Handled_Sequence_Of_Statements, as we want to signal an error on
5251 every nested real statement instead. This also avoids triggering
5252 spurious errors on dummy (empty) sequences created by the front-end
5253 for package bodies in some cases. */
5254 if (current_function_decl
== current_elab_proc
5255 && kind
!= N_Handled_Sequence_Of_Statements
)
5256 Check_Elaboration_Code_Allowed (gnat_node
);
5261 /********************************/
5262 /* Chapter 2: Lexical Elements */
5263 /********************************/
5266 case N_Expanded_Name
:
5267 case N_Operator_Symbol
:
5268 case N_Defining_Identifier
:
5269 gnu_result
= Identifier_to_gnu (gnat_node
, &gnu_result_type
);
5271 /* If this is an atomic access on the RHS for which synchronization is
5272 required, build the atomic load. */
5273 if (atomic_sync_required_p (gnat_node
)
5274 && !present_in_lhs_or_actual_p (gnat_node
))
5275 gnu_result
= build_atomic_load (gnu_result
);
5278 case N_Integer_Literal
:
5282 /* Get the type of the result, looking inside any padding and
5283 justified modular types. Then get the value in that type. */
5284 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5286 if (TREE_CODE (gnu_type
) == RECORD_TYPE
5287 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
5288 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
5290 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
5292 /* If the result overflows (meaning it doesn't fit in its base type),
5293 abort. We would like to check that the value is within the range
5294 of the subtype, but that causes problems with subtypes whose usage
5295 will raise Constraint_Error and with biased representation, so
5297 gcc_assert (!TREE_OVERFLOW (gnu_result
));
5301 case N_Character_Literal
:
5302 /* If a Entity is present, it means that this was one of the
5303 literals in a user-defined character type. In that case,
5304 just return the value in the CONST_DECL. Otherwise, use the
5305 character code. In that case, the base type should be an
5306 INTEGER_TYPE, but we won't bother checking for that. */
5307 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5308 if (Present (Entity (gnat_node
)))
5309 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
5312 = build_int_cst_type
5313 (gnu_result_type
, UI_To_CC (Char_Literal_Value (gnat_node
)));
5316 case N_Real_Literal
:
5317 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5319 /* If this is of a fixed-point type, the value we want is the
5320 value of the corresponding integer. */
5321 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
5323 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
5325 gcc_assert (!TREE_OVERFLOW (gnu_result
));
5328 /* Convert the Ureal to a vax float (represented on a signed type). */
5329 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
5331 gnu_result
= UI_To_gnu (Get_Vax_Real_Literal_As_Signed (gnat_node
),
5337 Ureal ur_realval
= Realval (gnat_node
);
5339 /* First convert the real value to a machine number if it isn't
5340 already. That forces BASE to 2 for non-zero values and simplifies
5341 the rest of our logic. */
5343 if (!Is_Machine_Number (gnat_node
))
5345 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
5346 ur_realval
, Round_Even
, gnat_node
);
5348 if (UR_Is_Zero (ur_realval
))
5349 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
5352 REAL_VALUE_TYPE tmp
;
5355 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
5357 /* The base must be 2 as Machine guarantees this, so we scale
5358 the value, which we know can fit in the mantissa of the type
5359 (hence the use of that type above). */
5361 gcc_assert (Rbase (ur_realval
) == 2);
5362 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
5363 - UI_To_Int (Denominator (ur_realval
)));
5364 gnu_result
= build_real (gnu_result_type
, tmp
);
5367 /* Now see if we need to negate the result. Do it this way to
5368 properly handle -0. */
5369 if (UR_Is_Negative (Realval (gnat_node
)))
5371 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
5377 case N_String_Literal
:
5378 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5379 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
5381 String_Id gnat_string
= Strval (gnat_node
);
5382 int length
= String_Length (gnat_string
);
5385 if (length
>= ALLOCA_THRESHOLD
)
5386 string
= XNEWVEC (char, length
+ 1);
5388 string
= (char *) alloca (length
+ 1);
5390 /* Build the string with the characters in the literal. Note
5391 that Ada strings are 1-origin. */
5392 for (i
= 0; i
< length
; i
++)
5393 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
5395 /* Put a null at the end of the string in case it's in a context
5396 where GCC will want to treat it as a C string. */
5399 gnu_result
= build_string (length
, string
);
5401 /* Strings in GCC don't normally have types, but we want
5402 this to not be converted to the array type. */
5403 TREE_TYPE (gnu_result
) = gnu_result_type
;
5405 if (length
>= ALLOCA_THRESHOLD
)
5410 /* Build a list consisting of each character, then make
5412 String_Id gnat_string
= Strval (gnat_node
);
5413 int length
= String_Length (gnat_string
);
5415 tree gnu_idx
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
5416 vec
<constructor_elt
, va_gc
> *gnu_vec
;
5417 vec_alloc (gnu_vec
, length
);
5419 for (i
= 0; i
< length
; i
++)
5421 tree t
= build_int_cst (TREE_TYPE (gnu_result_type
),
5422 Get_String_Char (gnat_string
, i
+ 1));
5424 CONSTRUCTOR_APPEND_ELT (gnu_vec
, gnu_idx
, t
);
5425 gnu_idx
= int_const_binop (PLUS_EXPR
, gnu_idx
, integer_one_node
);
5428 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
5433 gnu_result
= Pragma_to_gnu (gnat_node
);
5436 /**************************************/
5437 /* Chapter 3: Declarations and Types */
5438 /**************************************/
5440 case N_Subtype_Declaration
:
5441 case N_Full_Type_Declaration
:
5442 case N_Incomplete_Type_Declaration
:
5443 case N_Private_Type_Declaration
:
5444 case N_Private_Extension_Declaration
:
5445 case N_Task_Type_Declaration
:
5446 process_type (Defining_Entity (gnat_node
));
5447 gnu_result
= alloc_stmt_list ();
5450 case N_Object_Declaration
:
5451 case N_Exception_Declaration
:
5452 gnat_temp
= Defining_Entity (gnat_node
);
5453 gnu_result
= alloc_stmt_list ();
5455 /* If we are just annotating types and this object has an unconstrained
5456 or task type, don't elaborate it. */
5457 if (type_annotate_only
5458 && (((Is_Array_Type (Etype (gnat_temp
))
5459 || Is_Record_Type (Etype (gnat_temp
)))
5460 && !Is_Constrained (Etype (gnat_temp
)))
5461 || Is_Concurrent_Type (Etype (gnat_temp
))))
5464 if (Present (Expression (gnat_node
))
5465 && !(kind
== N_Object_Declaration
&& No_Initialization (gnat_node
))
5466 && (!type_annotate_only
5467 || Compile_Time_Known_Value (Expression (gnat_node
))))
5469 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
5470 if (Do_Range_Check (Expression (gnat_node
)))
5472 = emit_range_check (gnu_expr
, Etype (gnat_temp
), gnat_node
);
5474 /* If this object has its elaboration delayed, we must force
5475 evaluation of GNU_EXPR right now and save it for when the object
5477 if (Present (Freeze_Node (gnat_temp
)))
5479 if (TREE_CONSTANT (gnu_expr
))
5481 else if (global_bindings_p ())
5483 = create_var_decl (create_concat_name (gnat_temp
, "init"),
5484 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
5485 false, false, false, false,
5488 gnu_expr
= gnat_save_expr (gnu_expr
);
5490 save_gnu_tree (gnat_node
, gnu_expr
, true);
5494 gnu_expr
= NULL_TREE
;
5496 if (type_annotate_only
&& gnu_expr
&& TREE_CODE (gnu_expr
) == ERROR_MARK
)
5497 gnu_expr
= NULL_TREE
;
5499 /* If this is a deferred constant with an address clause, we ignore the
5500 full view since the clause is on the partial view and we cannot have
5501 2 different GCC trees for the object. The only bits of the full view
5502 we will use is the initializer, but it will be directly fetched. */
5503 if (Ekind(gnat_temp
) == E_Constant
5504 && Present (Address_Clause (gnat_temp
))
5505 && Present (Full_View (gnat_temp
)))
5506 save_gnu_tree (Full_View (gnat_temp
), error_mark_node
, true);
5508 if (No (Freeze_Node (gnat_temp
)))
5509 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
5512 case N_Object_Renaming_Declaration
:
5513 gnat_temp
= Defining_Entity (gnat_node
);
5515 /* Don't do anything if this renaming is handled by the front end or if
5516 we are just annotating types and this object has a composite or task
5517 type, don't elaborate it. We return the result in case it has any
5518 SAVE_EXPRs in it that need to be evaluated here. */
5519 if (!Is_Renaming_Of_Object (gnat_temp
)
5520 && ! (type_annotate_only
5521 && (Is_Array_Type (Etype (gnat_temp
))
5522 || Is_Record_Type (Etype (gnat_temp
))
5523 || Is_Concurrent_Type (Etype (gnat_temp
)))))
5525 = gnat_to_gnu_entity (gnat_temp
,
5526 gnat_to_gnu (Renamed_Object (gnat_temp
)), 1);
5528 gnu_result
= alloc_stmt_list ();
5531 case N_Implicit_Label_Declaration
:
5532 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
5533 gnu_result
= alloc_stmt_list ();
5536 case N_Exception_Renaming_Declaration
:
5537 case N_Number_Declaration
:
5538 case N_Package_Renaming_Declaration
:
5539 case N_Subprogram_Renaming_Declaration
:
5540 /* These are fully handled in the front end. */
5541 gnu_result
= alloc_stmt_list ();
5544 /*************************************/
5545 /* Chapter 4: Names and Expressions */
5546 /*************************************/
5548 case N_Explicit_Dereference
:
5549 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
5550 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5551 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
5553 /* If this is an atomic access on the RHS for which synchronization is
5554 required, build the atomic load. */
5555 if (atomic_sync_required_p (gnat_node
)
5556 && !present_in_lhs_or_actual_p (gnat_node
))
5557 gnu_result
= build_atomic_load (gnu_result
);
5560 case N_Indexed_Component
:
5562 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
5566 Node_Id
*gnat_expr_array
;
5568 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
5570 /* Convert vector inputs to their representative array type, to fit
5571 what the code below expects. */
5572 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object
)))
5574 if (present_in_lhs_or_actual_p (gnat_node
))
5575 gnat_mark_addressable (gnu_array_object
);
5576 gnu_array_object
= maybe_vector_array (gnu_array_object
);
5579 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
5581 /* If we got a padded type, remove it too. */
5582 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
5584 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
5587 gnu_result
= gnu_array_object
;
5589 /* The failure of this assertion will very likely come from a missing
5590 expansion for a packed array access. */
5591 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object
)) == ARRAY_TYPE
);
5593 /* First compute the number of dimensions of the array, then
5594 fill the expression array, the order depending on whether
5595 this is a Convention_Fortran array or not. */
5596 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
5597 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
5598 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
5599 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
5602 gnat_expr_array
= XALLOCAVEC (Node_Id
, ndim
);
5604 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
5605 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
5607 i
--, gnat_temp
= Next (gnat_temp
))
5608 gnat_expr_array
[i
] = gnat_temp
;
5610 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
5612 i
++, gnat_temp
= Next (gnat_temp
))
5613 gnat_expr_array
[i
] = gnat_temp
;
5615 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
5616 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
5618 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
5619 gnat_temp
= gnat_expr_array
[i
];
5620 gnu_expr
= gnat_to_gnu (gnat_temp
);
5622 if (Do_Range_Check (gnat_temp
))
5625 (gnu_array_object
, gnu_expr
,
5626 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
5627 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
5630 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
5631 gnu_result
, gnu_expr
);
5634 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5636 /* If this is an atomic access on the RHS for which synchronization is
5637 required, build the atomic load. */
5638 if (atomic_sync_required_p (gnat_node
)
5639 && !present_in_lhs_or_actual_p (gnat_node
))
5640 gnu_result
= build_atomic_load (gnu_result
);
5646 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
5649 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
5650 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5652 /* Do any implicit dereferences of the prefix and do any needed
5654 gnu_result
= maybe_implicit_deref (gnu_result
);
5655 gnu_result
= maybe_unconstrained_array (gnu_result
);
5656 gnu_type
= TREE_TYPE (gnu_result
);
5657 if (Do_Range_Check (gnat_range_node
))
5659 /* Get the bounds of the slice. */
5661 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
5662 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
5663 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
5664 /* Get the permitted bounds. */
5665 tree gnu_base_index_type
5666 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
));
5667 tree gnu_base_min_expr
= SUBSTITUTE_PLACEHOLDER_IN_EXPR
5668 (TYPE_MIN_VALUE (gnu_base_index_type
), gnu_result
);
5669 tree gnu_base_max_expr
= SUBSTITUTE_PLACEHOLDER_IN_EXPR
5670 (TYPE_MAX_VALUE (gnu_base_index_type
), gnu_result
);
5671 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
5673 gnu_min_expr
= gnat_protect_expr (gnu_min_expr
);
5674 gnu_max_expr
= gnat_protect_expr (gnu_max_expr
);
5676 /* Derive a good type to convert everything to. */
5677 gnu_expr_type
= get_base_type (gnu_index_type
);
5679 /* Test whether the minimum slice value is too small. */
5680 gnu_expr_l
= build_binary_op (LT_EXPR
, boolean_type_node
,
5681 convert (gnu_expr_type
,
5683 convert (gnu_expr_type
,
5684 gnu_base_min_expr
));
5686 /* Test whether the maximum slice value is too large. */
5687 gnu_expr_h
= build_binary_op (GT_EXPR
, boolean_type_node
,
5688 convert (gnu_expr_type
,
5690 convert (gnu_expr_type
,
5691 gnu_base_max_expr
));
5693 /* Build a slice index check that returns the low bound,
5694 assuming the slice is not empty. */
5695 gnu_expr
= emit_check
5696 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
5697 gnu_expr_l
, gnu_expr_h
),
5698 gnu_min_expr
, CE_Index_Check_Failed
, gnat_node
);
5700 /* Build a conditional expression that does the index checks and
5701 returns the low bound if the slice is not empty (max >= min),
5702 and returns the naked low bound otherwise (max < min), unless
5703 it is non-constant and the high bound is; this prevents VRP
5704 from inferring bogus ranges on the unlikely path. */
5705 gnu_expr
= fold_build3 (COND_EXPR
, gnu_expr_type
,
5706 build_binary_op (GE_EXPR
, gnu_expr_type
,
5707 convert (gnu_expr_type
,
5709 convert (gnu_expr_type
,
5712 TREE_CODE (gnu_min_expr
) != INTEGER_CST
5713 && TREE_CODE (gnu_max_expr
) == INTEGER_CST
5714 ? gnu_max_expr
: gnu_min_expr
);
5717 /* Simply return the naked low bound. */
5718 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
5720 /* If this is a slice with non-constant size of an array with constant
5721 size, set the maximum size for the allocation of temporaries. */
5722 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type
))
5723 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type
)))
5724 TYPE_ARRAY_MAX_SIZE (gnu_result_type
) = TYPE_SIZE_UNIT (gnu_type
);
5726 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
5727 gnu_result
, gnu_expr
);
5731 case N_Selected_Component
:
5733 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
5734 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
5735 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
5738 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
5739 || IN (Ekind (gnat_pref_type
), Access_Kind
))
5741 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
5742 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
5743 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
5744 gnat_pref_type
= Designated_Type (gnat_pref_type
);
5747 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
5749 /* For discriminant references in tagged types always substitute the
5750 corresponding discriminant as the actual selected component. */
5751 if (Is_Tagged_Type (gnat_pref_type
))
5752 while (Present (Corresponding_Discriminant (gnat_field
)))
5753 gnat_field
= Corresponding_Discriminant (gnat_field
);
5755 /* For discriminant references of untagged types always substitute the
5756 corresponding stored discriminant. */
5757 else if (Present (Corresponding_Discriminant (gnat_field
)))
5758 gnat_field
= Original_Record_Component (gnat_field
);
5760 /* Handle extracting the real or imaginary part of a complex.
5761 The real part is the first field and the imaginary the last. */
5762 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
5763 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
5764 ? REALPART_EXPR
: IMAGPART_EXPR
,
5765 NULL_TREE
, gnu_prefix
);
5768 gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
5770 /* If there are discriminants, the prefix might be evaluated more
5771 than once, which is a problem if it has side-effects. */
5772 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
5773 ? Designated_Type (Etype
5774 (Prefix (gnat_node
)))
5775 : Etype (Prefix (gnat_node
))))
5776 gnu_prefix
= gnat_stabilize_reference (gnu_prefix
, false, NULL
);
5779 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
,
5780 (Nkind (Parent (gnat_node
))
5781 == N_Attribute_Reference
)
5782 && lvalue_required_for_attribute_p
5783 (Parent (gnat_node
)));
5786 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5788 /* If this is an atomic access on the RHS for which synchronization is
5789 required, build the atomic load. */
5790 if (atomic_sync_required_p (gnat_node
)
5791 && !present_in_lhs_or_actual_p (gnat_node
))
5792 gnu_result
= build_atomic_load (gnu_result
);
5796 case N_Attribute_Reference
:
5798 /* The attribute designator. */
5799 const int attr
= Get_Attribute_Id (Attribute_Name (gnat_node
));
5801 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
5802 is a unit, not an object with a GCC equivalent. */
5803 if (attr
== Attr_Elab_Spec
|| attr
== Attr_Elab_Body
)
5805 create_subprog_decl (create_concat_name
5806 (Entity (Prefix (gnat_node
)),
5807 attr
== Attr_Elab_Body
? "elabb" : "elabs"),
5808 NULL_TREE
, void_ftype
, NULL_TREE
, is_disabled
,
5809 true, true, true, NULL
, gnat_node
);
5811 gnu_result
= Attribute_to_gnu (gnat_node
, &gnu_result_type
, attr
);
5816 /* Like 'Access as far as we are concerned. */
5817 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
5818 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
5819 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5823 case N_Extension_Aggregate
:
5827 /* ??? It is wrong to evaluate the type now, but there doesn't
5828 seem to be any other practical way of doing it. */
5830 gcc_assert (!Expansion_Delayed (gnat_node
));
5832 gnu_aggr_type
= gnu_result_type
5833 = get_unpadded_type (Etype (gnat_node
));
5835 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
5836 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
5838 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type
)));
5839 else if (TREE_CODE (gnu_result_type
) == VECTOR_TYPE
)
5840 gnu_aggr_type
= TYPE_REPRESENTATIVE_ARRAY (gnu_result_type
);
5842 if (Null_Record_Present (gnat_node
))
5843 gnu_result
= gnat_build_constructor (gnu_aggr_type
,
5846 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
5847 || TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
5849 = assoc_to_constructor (Etype (gnat_node
),
5850 First (Component_Associations (gnat_node
)),
5852 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
5853 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
5855 Component_Type (Etype (gnat_node
)));
5856 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
5859 (COMPLEX_EXPR
, gnu_aggr_type
,
5860 gnat_to_gnu (Expression (First
5861 (Component_Associations (gnat_node
)))),
5862 gnat_to_gnu (Expression
5864 (First (Component_Associations (gnat_node
))))));
5868 gnu_result
= convert (gnu_result_type
, gnu_result
);
5873 if (TARGET_VTABLE_USES_DESCRIPTORS
5874 && Ekind (Etype (gnat_node
)) == E_Access_Subprogram_Type
5875 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
5876 gnu_result
= null_fdesc_node
;
5878 gnu_result
= null_pointer_node
;
5879 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5882 case N_Type_Conversion
:
5883 case N_Qualified_Expression
:
5884 /* Get the operand expression. */
5885 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
5886 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5888 /* If this is a qualified expression for a tagged type, we mark the type
5889 as used. Because of polymorphism, this might be the only reference to
5890 the tagged type in the program while objects have it as dynamic type.
5891 The debugger needs to see it to display these objects properly. */
5892 if (kind
== N_Qualified_Expression
&& Is_Tagged_Type (Etype (gnat_node
)))
5893 used_types_insert (gnu_result_type
);
5896 = convert_with_check (Etype (gnat_node
), gnu_result
,
5897 Do_Overflow_Check (gnat_node
),
5898 Do_Range_Check (Expression (gnat_node
)),
5899 kind
== N_Type_Conversion
5900 && Float_Truncate (gnat_node
), gnat_node
);
5903 case N_Unchecked_Type_Conversion
:
5904 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
5906 /* Skip further processing if the conversion is deemed a no-op. */
5907 if (unchecked_conversion_nop (gnat_node
))
5909 gnu_result_type
= TREE_TYPE (gnu_result
);
5913 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5915 /* If the result is a pointer type, see if we are improperly
5916 converting to a stricter alignment. */
5917 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
5918 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
5920 unsigned int align
= known_alignment (gnu_result
);
5921 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
5922 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
5924 if (align
!= 0 && align
< oalign
&& !TYPE_ALIGN_OK (gnu_obj_type
))
5925 post_error_ne_tree_2
5926 ("?source alignment (^) '< alignment of & (^)",
5927 gnat_node
, Designated_Type (Etype (gnat_node
)),
5928 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
5931 /* If we are converting a descriptor to a function pointer, first
5932 build the pointer. */
5933 if (TARGET_VTABLE_USES_DESCRIPTORS
5934 && TREE_TYPE (gnu_result
) == fdesc_type_node
5935 && POINTER_TYPE_P (gnu_result_type
))
5936 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
5938 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
,
5939 No_Truncation (gnat_node
));
5945 tree gnu_obj
= gnat_to_gnu (Left_Opnd (gnat_node
));
5946 Node_Id gnat_range
= Right_Opnd (gnat_node
);
5947 tree gnu_low
, gnu_high
;
5949 /* GNAT_RANGE is either an N_Range node or an identifier denoting a
5951 if (Nkind (gnat_range
) == N_Range
)
5953 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
5954 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
5956 else if (Nkind (gnat_range
) == N_Identifier
5957 || Nkind (gnat_range
) == N_Expanded_Name
)
5959 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
5961 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
5962 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
5967 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5969 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
5970 ensure that GNU_OBJ is evaluated only once and perform a full range
5972 if (operand_equal_p (gnu_low
, gnu_high
, 0))
5974 = build_binary_op (EQ_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
5978 gnu_obj
= gnat_protect_expr (gnu_obj
);
5979 t1
= build_binary_op (GE_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
5981 set_expr_location_from_node (t1
, gnat_node
);
5982 t2
= build_binary_op (LE_EXPR
, gnu_result_type
, gnu_obj
, gnu_high
);
5984 set_expr_location_from_node (t2
, gnat_node
);
5986 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
, t1
, t2
);
5989 if (kind
== N_Not_In
)
5991 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result
), gnu_result
);
5996 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
5997 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
5998 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5999 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
6001 : (Rounded_Result (gnat_node
)
6002 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
6003 gnu_result_type
, gnu_lhs
, gnu_rhs
);
6006 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
6007 /* These can either be operations on booleans or on modular types.
6008 Fall through for boolean types since that's the way GNU_CODES is
6010 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
6011 Modular_Integer_Kind
))
6014 = (kind
== N_Op_Or
? BIT_IOR_EXPR
6015 : kind
== N_Op_And
? BIT_AND_EXPR
6018 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
6019 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
6020 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6021 gnu_result
= build_binary_op (code
, gnu_result_type
,
6026 /* ... fall through ... */
6028 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
6029 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
6030 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
6031 case N_Op_Mod
: case N_Op_Rem
:
6032 case N_Op_Rotate_Left
:
6033 case N_Op_Rotate_Right
:
6034 case N_Op_Shift_Left
:
6035 case N_Op_Shift_Right
:
6036 case N_Op_Shift_Right_Arithmetic
:
6037 case N_And_Then
: case N_Or_Else
:
6039 enum tree_code code
= gnu_codes
[kind
];
6040 bool ignore_lhs_overflow
= false;
6041 location_t saved_location
= input_location
;
6044 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
6045 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
6046 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6048 /* Pending generic support for efficient vector logical operations in
6049 GCC, convert vectors to their representative array type view and
6051 gnu_lhs
= maybe_vector_array (gnu_lhs
);
6052 gnu_rhs
= maybe_vector_array (gnu_rhs
);
6054 /* If this is a comparison operator, convert any references to
6055 an unconstrained array value into a reference to the
6057 if (TREE_CODE_CLASS (code
) == tcc_comparison
)
6059 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
6060 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
6063 /* If the result type is a private type, its full view may be a
6064 numeric subtype. The representation we need is that of its base
6065 type, given that it is the result of an arithmetic operation. */
6066 else if (Is_Private_Type (Etype (gnat_node
)))
6067 gnu_type
= gnu_result_type
6068 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node
))));
6070 /* If this is a shift whose count is not guaranteed to be correct,
6071 we need to adjust the shift count. */
6072 if (IN (kind
, N_Op_Shift
) && !Shift_Count_OK (gnat_node
))
6074 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
6076 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
6078 if (kind
== N_Op_Rotate_Left
|| kind
== N_Op_Rotate_Right
)
6079 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
6080 gnu_rhs
, gnu_max_shift
);
6081 else if (kind
== N_Op_Shift_Right_Arithmetic
)
6084 (MIN_EXPR
, gnu_count_type
,
6085 build_binary_op (MINUS_EXPR
,
6088 convert (gnu_count_type
,
6093 /* For right shifts, the type says what kind of shift to do,
6094 so we may need to choose a different type. In this case,
6095 we have to ignore integer overflow lest it propagates all
6096 the way down and causes a CE to be explicitly raised. */
6097 if (kind
== N_Op_Shift_Right
&& !TYPE_UNSIGNED (gnu_type
))
6099 gnu_type
= gnat_unsigned_type (gnu_type
);
6100 ignore_lhs_overflow
= true;
6102 else if (kind
== N_Op_Shift_Right_Arithmetic
6103 && TYPE_UNSIGNED (gnu_type
))
6105 gnu_type
= gnat_signed_type (gnu_type
);
6106 ignore_lhs_overflow
= true;
6109 if (gnu_type
!= gnu_result_type
)
6111 tree gnu_old_lhs
= gnu_lhs
;
6112 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
6113 if (TREE_CODE (gnu_lhs
) == INTEGER_CST
&& ignore_lhs_overflow
)
6114 TREE_OVERFLOW (gnu_lhs
) = TREE_OVERFLOW (gnu_old_lhs
);
6115 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
6118 /* Instead of expanding overflow checks for addition, subtraction
6119 and multiplication itself, the front end will leave this to
6120 the back end when Backend_Overflow_Checks_On_Target is set.
6121 As the GCC back end itself does not know yet how to properly
6122 do overflow checking, do it here. The goal is to push
6123 the expansions further into the back end over time. */
6124 if (Do_Overflow_Check (gnat_node
) && Backend_Overflow_Checks_On_Target
6125 && (kind
== N_Op_Add
6126 || kind
== N_Op_Subtract
6127 || kind
== N_Op_Multiply
)
6128 && !TYPE_UNSIGNED (gnu_type
)
6129 && !FLOAT_TYPE_P (gnu_type
))
6130 gnu_result
= build_binary_op_trapv (code
, gnu_type
,
6131 gnu_lhs
, gnu_rhs
, gnat_node
);
6134 /* Some operations, e.g. comparisons of arrays, generate complex
6135 trees that need to be annotated while they are being built. */
6136 input_location
= saved_location
;
6137 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
6140 /* If this is a logical shift with the shift count not verified,
6141 we must return zero if it is too large. We cannot compensate
6142 above in this case. */
6143 if ((kind
== N_Op_Shift_Left
|| kind
== N_Op_Shift_Right
)
6144 && !Shift_Count_OK (gnat_node
))
6148 build_binary_op (GE_EXPR
, boolean_type_node
,
6150 convert (TREE_TYPE (gnu_rhs
),
6151 TYPE_SIZE (gnu_type
))),
6152 convert (gnu_type
, integer_zero_node
),
6157 case N_If_Expression
:
6159 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
6160 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
6162 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
6164 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6166 = build_cond_expr (gnu_result_type
, gnu_cond
, gnu_true
, gnu_false
);
6171 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
6172 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6176 /* This case can apply to a boolean or a modular type.
6177 Fall through for a boolean operand since GNU_CODES is set
6178 up to handle this. */
6179 if (Is_Modular_Integer_Type (Etype (gnat_node
))
6180 || (Ekind (Etype (gnat_node
)) == E_Private_Type
6181 && Is_Modular_Integer_Type (Full_View (Etype (gnat_node
)))))
6183 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
6184 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6185 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
6190 /* ... fall through ... */
6192 case N_Op_Minus
: case N_Op_Abs
:
6193 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
6195 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
6196 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6198 gnu_result_type
= get_unpadded_type (Base_Type
6199 (Full_View (Etype (gnat_node
))));
6201 if (Do_Overflow_Check (gnat_node
)
6202 && !TYPE_UNSIGNED (gnu_result_type
)
6203 && !FLOAT_TYPE_P (gnu_result_type
))
6205 = build_unary_op_trapv (gnu_codes
[kind
],
6206 gnu_result_type
, gnu_expr
, gnat_node
);
6208 gnu_result
= build_unary_op (gnu_codes
[kind
],
6209 gnu_result_type
, gnu_expr
);
6216 bool ignore_init_type
= false;
6218 gnat_temp
= Expression (gnat_node
);
6220 /* The Expression operand can either be an N_Identifier or
6221 Expanded_Name, which must represent a type, or a
6222 N_Qualified_Expression, which contains both the object type and an
6223 initial value for the object. */
6224 if (Nkind (gnat_temp
) == N_Identifier
6225 || Nkind (gnat_temp
) == N_Expanded_Name
)
6226 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
6227 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
6229 Entity_Id gnat_desig_type
6230 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
6232 ignore_init_type
= Has_Constrained_Partial_View (gnat_desig_type
);
6233 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
6235 gnu_init
= maybe_unconstrained_array (gnu_init
);
6236 if (Do_Range_Check (Expression (gnat_temp
)))
6238 = emit_range_check (gnu_init
, gnat_desig_type
, gnat_temp
);
6240 if (Is_Elementary_Type (gnat_desig_type
)
6241 || Is_Constrained (gnat_desig_type
))
6242 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
6245 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
6246 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
6247 gnu_type
= TREE_TYPE (gnu_init
);
6250 /* See the N_Qualified_Expression case for the rationale. */
6251 if (Is_Tagged_Type (gnat_desig_type
))
6252 used_types_insert (gnu_type
);
6254 gnu_init
= convert (gnu_type
, gnu_init
);
6259 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6260 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
6261 Procedure_To_Call (gnat_node
),
6262 Storage_Pool (gnat_node
), gnat_node
,
6267 /**************************/
6268 /* Chapter 5: Statements */
6269 /**************************/
6272 gnu_result
= build1 (LABEL_EXPR
, void_type_node
,
6273 gnat_to_gnu (Identifier (gnat_node
)));
6276 case N_Null_Statement
:
6277 /* When not optimizing, turn null statements from source into gotos to
6278 the next statement that the middle-end knows how to preserve. */
6279 if (!optimize
&& Comes_From_Source (gnat_node
))
6281 tree stmt
, label
= create_label_decl (NULL_TREE
, gnat_node
);
6282 DECL_IGNORED_P (label
) = 1;
6283 start_stmt_group ();
6284 stmt
= build1 (GOTO_EXPR
, void_type_node
, label
);
6285 set_expr_location_from_node (stmt
, gnat_node
);
6287 stmt
= build1 (LABEL_EXPR
, void_type_node
, label
);
6288 set_expr_location_from_node (stmt
, gnat_node
);
6290 gnu_result
= end_stmt_group ();
6293 gnu_result
= alloc_stmt_list ();
6296 case N_Assignment_Statement
:
6297 /* Get the LHS and RHS of the statement and convert any reference to an
6298 unconstrained array into a reference to the underlying array. */
6299 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
6301 /* If the type has a size that overflows, convert this into raise of
6302 Storage_Error: execution shouldn't have gotten here anyway. */
6303 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
6304 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))))
6305 gnu_result
= build_call_raise (SE_Object_Too_Large
, gnat_node
,
6306 N_Raise_Storage_Error
);
6307 else if (Nkind (Expression (gnat_node
)) == N_Function_Call
)
6309 = Call_to_gnu (Expression (gnat_node
), &gnu_result_type
, gnu_lhs
,
6310 atomic_sync_required_p (Name (gnat_node
)));
6314 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
6316 /* If range check is needed, emit code to generate it. */
6317 if (Do_Range_Check (Expression (gnat_node
)))
6318 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)),
6321 if (atomic_sync_required_p (Name (gnat_node
)))
6322 gnu_result
= build_atomic_store (gnu_lhs
, gnu_rhs
);
6325 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
6327 /* If the type being assigned is an array type and the two sides are
6328 not completely disjoint, play safe and use memmove. But don't do
6329 it for a bit-packed array as it might not be byte-aligned. */
6330 if (TREE_CODE (gnu_result
) == MODIFY_EXPR
6331 && Is_Array_Type (Etype (Name (gnat_node
)))
6332 && !Is_Bit_Packed_Array (Etype (Name (gnat_node
)))
6333 && !(Forwards_OK (gnat_node
) && Backwards_OK (gnat_node
)))
6335 tree to
, from
, size
, to_ptr
, from_ptr
, t
;
6337 to
= TREE_OPERAND (gnu_result
, 0);
6338 from
= TREE_OPERAND (gnu_result
, 1);
6340 size
= TYPE_SIZE_UNIT (TREE_TYPE (from
));
6341 size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, from
);
6343 to_ptr
= build_fold_addr_expr (to
);
6344 from_ptr
= build_fold_addr_expr (from
);
6346 t
= builtin_decl_implicit (BUILT_IN_MEMMOVE
);
6347 gnu_result
= build_call_expr (t
, 3, to_ptr
, from_ptr
, size
);
6352 case N_If_Statement
:
6354 tree
*gnu_else_ptr
; /* Point to put next "else if" or "else". */
6356 /* Make the outer COND_EXPR. Avoid non-determinism. */
6357 gnu_result
= build3 (COND_EXPR
, void_type_node
,
6358 gnat_to_gnu (Condition (gnat_node
)),
6359 NULL_TREE
, NULL_TREE
);
6360 COND_EXPR_THEN (gnu_result
)
6361 = build_stmt_group (Then_Statements (gnat_node
), false);
6362 TREE_SIDE_EFFECTS (gnu_result
) = 1;
6363 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_result
);
6365 /* Now make a COND_EXPR for each of the "else if" parts. Put each
6366 into the previous "else" part and point to where to put any
6367 outer "else". Also avoid non-determinism. */
6368 if (Present (Elsif_Parts (gnat_node
)))
6369 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
6370 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
6372 gnu_expr
= build3 (COND_EXPR
, void_type_node
,
6373 gnat_to_gnu (Condition (gnat_temp
)),
6374 NULL_TREE
, NULL_TREE
);
6375 COND_EXPR_THEN (gnu_expr
)
6376 = build_stmt_group (Then_Statements (gnat_temp
), false);
6377 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
6378 set_expr_location_from_node (gnu_expr
, gnat_temp
);
6379 *gnu_else_ptr
= gnu_expr
;
6380 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
6383 *gnu_else_ptr
= build_stmt_group (Else_Statements (gnat_node
), false);
6387 case N_Case_Statement
:
6388 gnu_result
= Case_Statement_to_gnu (gnat_node
);
6391 case N_Loop_Statement
:
6392 gnu_result
= Loop_Statement_to_gnu (gnat_node
);
6395 case N_Block_Statement
:
6396 /* The only way to enter the block is to fall through to it. */
6397 if (stmt_group_may_fallthru ())
6399 start_stmt_group ();
6401 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
6402 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
6404 gnu_result
= end_stmt_group ();
6407 gnu_result
= alloc_stmt_list ();
6410 case N_Exit_Statement
:
6412 = build2 (EXIT_STMT
, void_type_node
,
6413 (Present (Condition (gnat_node
))
6414 ? gnat_to_gnu (Condition (gnat_node
)) : NULL_TREE
),
6415 (Present (Name (gnat_node
))
6416 ? get_gnu_tree (Entity (Name (gnat_node
)))
6417 : LOOP_STMT_LABEL (gnu_loop_stack
->last ()->stmt
)));
6420 case N_Simple_Return_Statement
:
6422 tree gnu_ret_obj
, gnu_ret_val
;
6424 /* If the subprogram is a function, we must return the expression. */
6425 if (Present (Expression (gnat_node
)))
6427 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
6429 /* If this function has copy-in/copy-out parameters, get the real
6430 object for the return. See Subprogram_to_gnu. */
6431 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
6432 gnu_ret_obj
= gnu_return_var_stack
->last ();
6434 gnu_ret_obj
= DECL_RESULT (current_function_decl
);
6436 /* Get the GCC tree for the expression to be returned. */
6437 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
6439 /* Do not remove the padding from GNU_RET_VAL if the inner type is
6440 self-referential since we want to allocate the fixed size. */
6441 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
6442 && TYPE_IS_PADDING_P
6443 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0)))
6444 && CONTAINS_PLACEHOLDER_P
6445 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
))))
6446 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
6448 /* If the function returns by direct reference, return a pointer
6449 to the return value. */
6450 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
)
6451 || By_Ref (gnat_node
))
6452 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
6454 /* Otherwise, if it returns an unconstrained array, we have to
6455 allocate a new version of the result and return it. */
6456 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
))
6458 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
6460 /* And find out whether this is a candidate for Named Return
6461 Value. If so, record it. */
6462 if (!TYPE_CI_CO_LIST (gnu_subprog_type
) && optimize
)
6464 tree ret_val
= gnu_ret_val
;
6466 /* Strip useless conversions around the return value. */
6467 if (gnat_useless_type_conversion (ret_val
))
6468 ret_val
= TREE_OPERAND (ret_val
, 0);
6470 /* Strip unpadding around the return value. */
6471 if (TREE_CODE (ret_val
) == COMPONENT_REF
6472 && TYPE_IS_PADDING_P
6473 (TREE_TYPE (TREE_OPERAND (ret_val
, 0))))
6474 ret_val
= TREE_OPERAND (ret_val
, 0);
6476 /* Now apply the test to the return value. */
6477 if (return_value_ok_for_nrv_p (NULL_TREE
, ret_val
))
6479 if (!f_named_ret_val
)
6480 f_named_ret_val
= BITMAP_GGC_ALLOC ();
6481 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
6483 f_gnat_ret
= gnat_node
;
6487 gnu_ret_val
= build_allocator (TREE_TYPE (gnu_ret_val
),
6489 TREE_TYPE (gnu_ret_obj
),
6490 Procedure_To_Call (gnat_node
),
6491 Storage_Pool (gnat_node
),
6495 /* Otherwise, if it returns by invisible reference, dereference
6496 the pointer it is passed using the type of the return value
6497 and build the copy operation manually. This ensures that we
6498 don't copy too much data, for example if the return type is
6499 unconstrained with a maximum size. */
6500 else if (TREE_ADDRESSABLE (gnu_subprog_type
))
6503 = build_unary_op (INDIRECT_REF
, TREE_TYPE (gnu_ret_val
),
6505 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
6506 gnu_ret_deref
, gnu_ret_val
);
6507 add_stmt_with_node (gnu_result
, gnat_node
);
6508 gnu_ret_val
= NULL_TREE
;
6513 gnu_ret_obj
= gnu_ret_val
= NULL_TREE
;
6515 /* If we have a return label defined, convert this into a branch to
6516 that label. The return proper will be handled elsewhere. */
6517 if (gnu_return_label_stack
->last ())
6520 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_ret_obj
,
6523 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
6524 gnu_return_label_stack
->last ());
6526 /* When not optimizing, make sure the return is preserved. */
6527 if (!optimize
&& Comes_From_Source (gnat_node
))
6528 DECL_ARTIFICIAL (gnu_return_label_stack
->last ()) = 0;
6531 /* Otherwise, build a regular return. */
6533 gnu_result
= build_return_expr (gnu_ret_obj
, gnu_ret_val
);
6537 case N_Goto_Statement
:
6539 = build1 (GOTO_EXPR
, void_type_node
, gnat_to_gnu (Name (gnat_node
)));
6542 /***************************/
6543 /* Chapter 6: Subprograms */
6544 /***************************/
6546 case N_Subprogram_Declaration
:
6547 /* Unless there is a freeze node, declare the subprogram. We consider
6548 this a "definition" even though we're not generating code for
6549 the subprogram because we will be making the corresponding GCC
6552 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
6553 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
6555 gnu_result
= alloc_stmt_list ();
6558 case N_Abstract_Subprogram_Declaration
:
6559 /* This subprogram doesn't exist for code generation purposes, but we
6560 have to elaborate the types of any parameters and result, unless
6561 they are imported types (nothing to generate in this case).
6563 The parameter list may contain types with freeze nodes, e.g. not null
6564 subtypes, so the subprogram itself may carry a freeze node, in which
6565 case its elaboration must be deferred. */
6567 /* Process the parameter types first. */
6568 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
6570 = First_Formal_With_Extras
6571 (Defining_Entity (Specification (gnat_node
)));
6572 Present (gnat_temp
);
6573 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
6574 if (Is_Itype (Etype (gnat_temp
))
6575 && !From_With_Type (Etype (gnat_temp
)))
6576 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
6578 /* Then the result type, set to Standard_Void_Type for procedures. */
6580 Entity_Id gnat_temp_type
6581 = Etype (Defining_Entity (Specification (gnat_node
)));
6583 if (Is_Itype (gnat_temp_type
) && !From_With_Type (gnat_temp_type
))
6584 gnat_to_gnu_entity (Etype (gnat_temp_type
), NULL_TREE
, 0);
6587 gnu_result
= alloc_stmt_list ();
6590 case N_Defining_Program_Unit_Name
:
6591 /* For a child unit identifier go up a level to get the specification.
6592 We get this when we try to find the spec of a child unit package
6593 that is the compilation unit being compiled. */
6594 gnu_result
= gnat_to_gnu (Parent (gnat_node
));
6597 case N_Subprogram_Body
:
6598 Subprogram_Body_to_gnu (gnat_node
);
6599 gnu_result
= alloc_stmt_list ();
6602 case N_Function_Call
:
6603 case N_Procedure_Call_Statement
:
6604 gnu_result
= Call_to_gnu (gnat_node
, &gnu_result_type
, NULL_TREE
, false);
6607 /************************/
6608 /* Chapter 7: Packages */
6609 /************************/
6611 case N_Package_Declaration
:
6612 gnu_result
= gnat_to_gnu (Specification (gnat_node
));
6615 case N_Package_Specification
:
6617 start_stmt_group ();
6618 process_decls (Visible_Declarations (gnat_node
),
6619 Private_Declarations (gnat_node
), Empty
, true, true);
6620 gnu_result
= end_stmt_group ();
6623 case N_Package_Body
:
6625 /* If this is the body of a generic package - do nothing. */
6626 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
6628 gnu_result
= alloc_stmt_list ();
6632 start_stmt_group ();
6633 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
6635 if (Present (Handled_Statement_Sequence (gnat_node
)))
6636 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
6638 gnu_result
= end_stmt_group ();
6641 /********************************/
6642 /* Chapter 8: Visibility Rules */
6643 /********************************/
6645 case N_Use_Package_Clause
:
6646 case N_Use_Type_Clause
:
6647 /* Nothing to do here - but these may appear in list of declarations. */
6648 gnu_result
= alloc_stmt_list ();
6651 /*********************/
6652 /* Chapter 9: Tasks */
6653 /*********************/
6655 case N_Protected_Type_Declaration
:
6656 gnu_result
= alloc_stmt_list ();
6659 case N_Single_Task_Declaration
:
6660 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
6661 gnu_result
= alloc_stmt_list ();
6664 /*********************************************************/
6665 /* Chapter 10: Program Structure and Compilation Issues */
6666 /*********************************************************/
6668 case N_Compilation_Unit
:
6669 /* This is not called for the main unit on which gigi is invoked. */
6670 Compilation_Unit_to_gnu (gnat_node
);
6671 gnu_result
= alloc_stmt_list ();
6674 case N_Subprogram_Body_Stub
:
6675 case N_Package_Body_Stub
:
6676 case N_Protected_Body_Stub
:
6677 case N_Task_Body_Stub
:
6678 /* Simply process whatever unit is being inserted. */
6679 if (Present (Library_Unit (gnat_node
)))
6680 gnu_result
= gnat_to_gnu (Unit (Library_Unit (gnat_node
)));
6683 gcc_assert (type_annotate_only
);
6684 gnu_result
= alloc_stmt_list ();
6689 gnu_result
= gnat_to_gnu (Proper_Body (gnat_node
));
6692 /***************************/
6693 /* Chapter 11: Exceptions */
6694 /***************************/
6696 case N_Handled_Sequence_Of_Statements
:
6697 /* If there is an At_End procedure attached to this node, and the EH
6698 mechanism is SJLJ, we must have at least a corresponding At_End
6699 handler, unless the No_Exception_Handlers restriction is set. */
6700 gcc_assert (type_annotate_only
6701 || Exception_Mechanism
!= Setjmp_Longjmp
6702 || No (At_End_Proc (gnat_node
))
6703 || Present (Exception_Handlers (gnat_node
))
6704 || No_Exception_Handlers_Set ());
6706 gnu_result
= Handled_Sequence_Of_Statements_to_gnu (gnat_node
);
6709 case N_Exception_Handler
:
6710 if (Exception_Mechanism
== Setjmp_Longjmp
)
6711 gnu_result
= Exception_Handler_to_gnu_sjlj (gnat_node
);
6712 else if (Exception_Mechanism
== Back_End_Exceptions
)
6713 gnu_result
= Exception_Handler_to_gnu_zcx (gnat_node
);
6718 case N_Raise_Statement
:
6719 /* Only for reraise in back-end exceptions mode. */
6720 gcc_assert (No (Name (gnat_node
))
6721 && Exception_Mechanism
== Back_End_Exceptions
);
6723 start_stmt_group ();
6726 /* Clear the current exception pointer so that the occurrence won't be
6728 gnu_expr
= create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE
,
6729 ptr_type_node
, gnu_incoming_exc_ptr
,
6730 false, false, false, false, NULL
, gnat_node
);
6732 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_incoming_exc_ptr
,
6733 convert (ptr_type_node
, integer_zero_node
)));
6734 add_stmt (build_call_n_expr (reraise_zcx_decl
, 1, gnu_expr
));
6736 gnu_result
= end_stmt_group ();
6739 case N_Push_Constraint_Error_Label
:
6740 push_exception_label_stack (&gnu_constraint_error_label_stack
,
6741 Exception_Label (gnat_node
));
6744 case N_Push_Storage_Error_Label
:
6745 push_exception_label_stack (&gnu_storage_error_label_stack
,
6746 Exception_Label (gnat_node
));
6749 case N_Push_Program_Error_Label
:
6750 push_exception_label_stack (&gnu_program_error_label_stack
,
6751 Exception_Label (gnat_node
));
6754 case N_Pop_Constraint_Error_Label
:
6755 gnu_constraint_error_label_stack
->pop ();
6758 case N_Pop_Storage_Error_Label
:
6759 gnu_storage_error_label_stack
->pop ();
6762 case N_Pop_Program_Error_Label
:
6763 gnu_program_error_label_stack
->pop ();
6766 /******************************/
6767 /* Chapter 12: Generic Units */
6768 /******************************/
6770 case N_Generic_Function_Renaming_Declaration
:
6771 case N_Generic_Package_Renaming_Declaration
:
6772 case N_Generic_Procedure_Renaming_Declaration
:
6773 case N_Generic_Package_Declaration
:
6774 case N_Generic_Subprogram_Declaration
:
6775 case N_Package_Instantiation
:
6776 case N_Procedure_Instantiation
:
6777 case N_Function_Instantiation
:
6778 /* These nodes can appear on a declaration list but there is nothing to
6779 to be done with them. */
6780 gnu_result
= alloc_stmt_list ();
6783 /**************************************************/
6784 /* Chapter 13: Representation Clauses and */
6785 /* Implementation-Dependent Features */
6786 /**************************************************/
6788 case N_Attribute_Definition_Clause
:
6789 gnu_result
= alloc_stmt_list ();
6791 /* The only one we need to deal with is 'Address since, for the others,
6792 the front-end puts the information elsewhere. */
6793 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
)
6796 /* And we only deal with 'Address if the object has a Freeze node. */
6797 gnat_temp
= Entity (Name (gnat_node
));
6798 if (No (Freeze_Node (gnat_temp
)))
6801 /* Get the value to use as the address and save it as the equivalent
6802 for the object. When it is frozen, gnat_to_gnu_entity will do the
6804 save_gnu_tree (gnat_temp
, gnat_to_gnu (Expression (gnat_node
)), true);
6807 case N_Enumeration_Representation_Clause
:
6808 case N_Record_Representation_Clause
:
6810 /* We do nothing with these. SEM puts the information elsewhere. */
6811 gnu_result
= alloc_stmt_list ();
6814 case N_Code_Statement
:
6815 if (!type_annotate_only
)
6817 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
6818 tree gnu_inputs
= NULL_TREE
, gnu_outputs
= NULL_TREE
;
6819 tree gnu_clobbers
= NULL_TREE
, tail
;
6820 bool allows_mem
, allows_reg
, fake
;
6821 int ninputs
, noutputs
, i
;
6822 const char **oconstraints
;
6823 const char *constraint
;
6826 /* First retrieve the 3 operand lists built by the front-end. */
6827 Setup_Asm_Outputs (gnat_node
);
6828 while (Present (gnat_temp
= Asm_Output_Variable ()))
6830 tree gnu_value
= gnat_to_gnu (gnat_temp
);
6831 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
6832 (Asm_Output_Constraint ()));
6834 gnu_outputs
= tree_cons (gnu_constr
, gnu_value
, gnu_outputs
);
6838 Setup_Asm_Inputs (gnat_node
);
6839 while (Present (gnat_temp
= Asm_Input_Value ()))
6841 tree gnu_value
= gnat_to_gnu (gnat_temp
);
6842 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
6843 (Asm_Input_Constraint ()));
6845 gnu_inputs
= tree_cons (gnu_constr
, gnu_value
, gnu_inputs
);
6849 Clobber_Setup (gnat_node
);
6850 while ((clobber
= Clobber_Get_Next ()))
6852 = tree_cons (NULL_TREE
,
6853 build_string (strlen (clobber
) + 1, clobber
),
6856 /* Then perform some standard checking and processing on the
6857 operands. In particular, mark them addressable if needed. */
6858 gnu_outputs
= nreverse (gnu_outputs
);
6859 noutputs
= list_length (gnu_outputs
);
6860 gnu_inputs
= nreverse (gnu_inputs
);
6861 ninputs
= list_length (gnu_inputs
);
6862 oconstraints
= XALLOCAVEC (const char *, noutputs
);
6864 for (i
= 0, tail
= gnu_outputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
6866 tree output
= TREE_VALUE (tail
);
6868 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
6869 oconstraints
[i
] = constraint
;
6871 if (parse_output_constraint (&constraint
, i
, ninputs
, noutputs
,
6872 &allows_mem
, &allows_reg
, &fake
))
6874 /* If the operand is going to end up in memory,
6875 mark it addressable. Note that we don't test
6876 allows_mem like in the input case below; this
6877 is modelled on the C front-end. */
6880 output
= remove_conversions (output
, false);
6881 if (TREE_CODE (output
) == CONST_DECL
6882 && DECL_CONST_CORRESPONDING_VAR (output
))
6883 output
= DECL_CONST_CORRESPONDING_VAR (output
);
6884 if (!gnat_mark_addressable (output
))
6885 output
= error_mark_node
;
6889 output
= error_mark_node
;
6891 TREE_VALUE (tail
) = output
;
6894 for (i
= 0, tail
= gnu_inputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
6896 tree input
= TREE_VALUE (tail
);
6898 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
6900 if (parse_input_constraint (&constraint
, i
, ninputs
, noutputs
,
6902 &allows_mem
, &allows_reg
))
6904 /* If the operand is going to end up in memory,
6905 mark it addressable. */
6906 if (!allows_reg
&& allows_mem
)
6908 input
= remove_conversions (input
, false);
6909 if (TREE_CODE (input
) == CONST_DECL
6910 && DECL_CONST_CORRESPONDING_VAR (input
))
6911 input
= DECL_CONST_CORRESPONDING_VAR (input
);
6912 if (!gnat_mark_addressable (input
))
6913 input
= error_mark_node
;
6917 input
= error_mark_node
;
6919 TREE_VALUE (tail
) = input
;
6922 gnu_result
= build5 (ASM_EXPR
, void_type_node
,
6923 gnu_template
, gnu_outputs
,
6924 gnu_inputs
, gnu_clobbers
, NULL_TREE
);
6925 ASM_VOLATILE_P (gnu_result
) = Is_Asm_Volatile (gnat_node
);
6928 gnu_result
= alloc_stmt_list ();
6936 case N_Expression_With_Actions
:
6937 /* This construct doesn't define a scope so we don't wrap the statement
6938 list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it
6940 gnu_result
= build_stmt_group (Actions (gnat_node
), false);
6941 gnu_result
= build1 (SAVE_EXPR
, void_type_node
, gnu_result
);
6942 TREE_SIDE_EFFECTS (gnu_result
) = 1;
6943 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
6945 = build_compound_expr (TREE_TYPE (gnu_expr
), gnu_result
, gnu_expr
);
6946 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6949 case N_Freeze_Entity
:
6950 start_stmt_group ();
6951 process_freeze_entity (gnat_node
);
6952 process_decls (Actions (gnat_node
), Empty
, Empty
, true, true);
6953 gnu_result
= end_stmt_group ();
6956 case N_Itype_Reference
:
6957 if (!present_gnu_tree (Itype (gnat_node
)))
6958 process_type (Itype (gnat_node
));
6960 gnu_result
= alloc_stmt_list ();
6963 case N_Free_Statement
:
6964 if (!type_annotate_only
)
6966 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
6967 tree gnu_ptr_type
= TREE_TYPE (gnu_ptr
);
6968 tree gnu_obj_type
, gnu_actual_obj_type
;
6970 /* If this is a thin pointer, we must first dereference it to create
6971 a fat pointer, then go back below to a thin pointer. The reason
6972 for this is that we need to have a fat pointer someplace in order
6973 to properly compute the size. */
6974 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
6975 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
6976 build_unary_op (INDIRECT_REF
, NULL_TREE
,
6979 /* If this is a fat pointer, the object must have been allocated with
6980 the template in front of the array. So pass the template address,
6981 and get the total size; do it by converting to a thin pointer. */
6982 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
6984 = convert (build_pointer_type
6985 (TYPE_OBJECT_RECORD_TYPE
6986 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
6989 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
6991 /* If this is a thin pointer, the object must have been allocated with
6992 the template in front of the array. So pass the template address,
6993 and get the total size. */
6994 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
6996 = build_binary_op (POINTER_PLUS_EXPR
, TREE_TYPE (gnu_ptr
),
6998 fold_build1 (NEGATE_EXPR
, sizetype
,
7001 TYPE_FIELDS ((gnu_obj_type
)))));
7003 /* If we have a special dynamic constrained subtype on the node, use
7004 it to compute the size; otherwise, use the designated subtype. */
7005 if (Present (Actual_Designated_Subtype (gnat_node
)))
7008 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node
));
7010 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
))
7012 = build_unc_object_type_from_ptr (gnu_ptr_type
,
7013 gnu_actual_obj_type
,
7014 get_identifier ("DEALLOC"),
7018 gnu_actual_obj_type
= gnu_obj_type
;
7021 = build_call_alloc_dealloc (gnu_ptr
,
7022 TYPE_SIZE_UNIT (gnu_actual_obj_type
),
7024 Procedure_To_Call (gnat_node
),
7025 Storage_Pool (gnat_node
),
7030 case N_Raise_Constraint_Error
:
7031 case N_Raise_Program_Error
:
7032 case N_Raise_Storage_Error
:
7033 if (type_annotate_only
)
7034 gnu_result
= alloc_stmt_list ();
7036 gnu_result
= Raise_Error_to_gnu (gnat_node
, &gnu_result_type
);
7039 case N_Validate_Unchecked_Conversion
:
7040 /* The only validation we currently do on an unchecked conversion is
7041 that of aliasing assumptions. */
7042 if (flag_strict_aliasing
)
7043 gnat_validate_uc_list
.safe_push (gnat_node
);
7044 gnu_result
= alloc_stmt_list ();
7047 case N_Function_Specification
:
7048 case N_Procedure_Specification
:
7050 case N_Component_Association
:
7051 case N_Protected_Body
:
7053 /* These nodes should only be present when annotating types. */
7054 gcc_assert (type_annotate_only
);
7055 gnu_result
= alloc_stmt_list ();
7059 /* Other nodes are not supposed to reach here. */
7063 /* If we pushed the processing of the elaboration routine, pop it back. */
7064 if (went_into_elab_proc
)
7065 current_function_decl
= NULL_TREE
;
7067 /* When not optimizing, turn boolean rvalues B into B != false tests
7068 so that the code just below can put the location information of the
7069 reference to B on the inequality operator for better debug info. */
7071 && TREE_CODE (gnu_result
) != INTEGER_CST
7072 && (kind
== N_Identifier
7073 || kind
== N_Expanded_Name
7074 || kind
== N_Explicit_Dereference
7075 || kind
== N_Function_Call
7076 || kind
== N_Indexed_Component
7077 || kind
== N_Selected_Component
)
7078 && TREE_CODE (get_base_type (gnu_result_type
)) == BOOLEAN_TYPE
7079 && !lvalue_required_p (gnat_node
, gnu_result_type
, false, false, false))
7080 gnu_result
= build_binary_op (NE_EXPR
, gnu_result_type
,
7081 convert (gnu_result_type
, gnu_result
),
7082 convert (gnu_result_type
,
7083 boolean_false_node
));
7085 /* Set the location information on the result. Note that we may have
7086 no result if we tried to build a CALL_EXPR node to a procedure with
7087 no side-effects and optimization is enabled. */
7088 if (gnu_result
&& EXPR_P (gnu_result
))
7089 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
7091 /* If we're supposed to return something of void_type, it means we have
7092 something we're elaborating for effect, so just return. */
7093 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
7096 /* If the result is a constant that overflowed, raise Constraint_Error. */
7097 if (TREE_CODE (gnu_result
) == INTEGER_CST
&& TREE_OVERFLOW (gnu_result
))
7099 post_error ("?`Constraint_Error` will be raised at run time", gnat_node
);
7101 = build1 (NULL_EXPR
, gnu_result_type
,
7102 build_call_raise (CE_Overflow_Check_Failed
, gnat_node
,
7103 N_Raise_Constraint_Error
));
7106 /* If the result has side-effects and is of an unconstrained type, make a
7107 SAVE_EXPR so that we can be sure it will only be referenced once. But
7108 this is useless for a call to a function that returns an unconstrained
7109 type with default discriminant, as we cannot compute the size of the
7110 actual returned object. We must do this before any conversions. */
7111 if (TREE_SIDE_EFFECTS (gnu_result
)
7112 && !(TREE_CODE (gnu_result
) == CALL_EXPR
7113 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
7114 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
7115 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))))
7116 gnu_result
= gnat_stabilize_reference (gnu_result
, false, NULL
);
7118 /* Now convert the result to the result type, unless we are in one of the
7121 1. If this is the LHS of an assignment or an actual parameter of a
7122 call, return the result almost unmodified since the RHS will have
7123 to be converted to our type in that case, unless the result type
7124 has a simpler size. Likewise if there is just a no-op unchecked
7125 conversion in-between. Similarly, don't convert integral types
7126 that are the operands of an unchecked conversion since we need
7127 to ignore those conversions (for 'Valid).
7129 2. If we have a label (which doesn't have any well-defined type), a
7130 field or an error, return the result almost unmodified. Similarly,
7131 if the two types are record types with the same name, don't convert.
7132 This will be the case when we are converting from a packable version
7133 of a type to its original type and we need those conversions to be
7134 NOPs in order for assignments into these types to work properly.
7136 3. If the type is void or if we have no result, return error_mark_node
7137 to show we have no result.
7139 4. If this a call to a function that returns an unconstrained type with
7140 default discriminant, return the call expression unmodified since we
7141 cannot compute the size of the actual returned object.
7143 5. Finally, if the type of the result is already correct. */
7145 if (Present (Parent (gnat_node
))
7146 && (lhs_or_actual_p (gnat_node
)
7147 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
7148 && unchecked_conversion_nop (Parent (gnat_node
)))
7149 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
7150 && !AGGREGATE_TYPE_P (gnu_result_type
)
7151 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))))
7152 && !(TYPE_SIZE (gnu_result_type
)
7153 && TYPE_SIZE (TREE_TYPE (gnu_result
))
7154 && (AGGREGATE_TYPE_P (gnu_result_type
)
7155 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
7156 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
7157 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
7159 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
7160 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
7161 && (CONTAINS_PLACEHOLDER_P
7162 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
7163 && !(TREE_CODE (gnu_result_type
) == RECORD_TYPE
7164 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type
))))
7166 /* Remove padding only if the inner object is of self-referential
7167 size: in that case it must be an object of unconstrained type
7168 with a default discriminant and we want to avoid copying too
7170 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
7171 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
7172 (TREE_TYPE (gnu_result
))))))
7173 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
7177 else if (TREE_CODE (gnu_result
) == LABEL_DECL
7178 || TREE_CODE (gnu_result
) == FIELD_DECL
7179 || TREE_CODE (gnu_result
) == ERROR_MARK
7180 || (TYPE_NAME (gnu_result_type
)
7181 == TYPE_NAME (TREE_TYPE (gnu_result
))
7182 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
7183 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
))
7185 /* Remove any padding. */
7186 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
7187 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
7191 else if (gnu_result
== error_mark_node
|| gnu_result_type
== void_type_node
)
7192 gnu_result
= error_mark_node
;
7194 else if (TREE_CODE (gnu_result
) == CALL_EXPR
7195 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
7196 && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
)))
7198 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
)))
7201 else if (TREE_TYPE (gnu_result
) != gnu_result_type
)
7202 gnu_result
= convert (gnu_result_type
, gnu_result
);
7204 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
7205 while ((TREE_CODE (gnu_result
) == NOP_EXPR
7206 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
7207 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
7208 gnu_result
= TREE_OPERAND (gnu_result
, 0);
7213 /* Subroutine of above to push the exception label stack. GNU_STACK is
7214 a pointer to the stack to update and GNAT_LABEL, if present, is the
7215 label to push onto the stack. */
7218 push_exception_label_stack (vec
<tree
, va_gc
> **gnu_stack
, Entity_Id gnat_label
)
7220 tree gnu_label
= (Present (gnat_label
)
7221 ? gnat_to_gnu_entity (gnat_label
, NULL_TREE
, 0)
7224 vec_safe_push (*gnu_stack
, gnu_label
);
7227 /* Record the current code position in GNAT_NODE. */
7230 record_code_position (Node_Id gnat_node
)
7232 tree stmt_stmt
= build1 (STMT_STMT
, void_type_node
, NULL_TREE
);
7234 add_stmt_with_node (stmt_stmt
, gnat_node
);
7235 save_gnu_tree (gnat_node
, stmt_stmt
, true);
7238 /* Insert the code for GNAT_NODE at the position saved for that node. */
7241 insert_code_for (Node_Id gnat_node
)
7243 STMT_STMT_STMT (get_gnu_tree (gnat_node
)) = gnat_to_gnu (gnat_node
);
7244 save_gnu_tree (gnat_node
, NULL_TREE
, true);
7247 /* Start a new statement group chained to the previous group. */
7250 start_stmt_group (void)
7252 struct stmt_group
*group
= stmt_group_free_list
;
7254 /* First see if we can get one from the free list. */
7256 stmt_group_free_list
= group
->previous
;
7258 group
= ggc_alloc_stmt_group ();
7260 group
->previous
= current_stmt_group
;
7261 group
->stmt_list
= group
->block
= group
->cleanups
= NULL_TREE
;
7262 current_stmt_group
= group
;
7265 /* Add GNU_STMT to the current statement group. If it is an expression with
7266 no effects, it is ignored. */
7269 add_stmt (tree gnu_stmt
)
7271 append_to_statement_list (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
7274 /* Similar, but the statement is always added, regardless of side-effects. */
7277 add_stmt_force (tree gnu_stmt
)
7279 append_to_statement_list_force (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
7282 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
7285 add_stmt_with_node (tree gnu_stmt
, Node_Id gnat_node
)
7287 if (Present (gnat_node
))
7288 set_expr_location_from_node (gnu_stmt
, gnat_node
);
7289 add_stmt (gnu_stmt
);
7292 /* Similar, but the statement is always added, regardless of side-effects. */
7295 add_stmt_with_node_force (tree gnu_stmt
, Node_Id gnat_node
)
7297 if (Present (gnat_node
))
7298 set_expr_location_from_node (gnu_stmt
, gnat_node
);
7299 add_stmt_force (gnu_stmt
);
7302 /* Add a declaration statement for GNU_DECL to the current statement group.
7303 Get SLOC from Entity_Id. */
7306 add_decl_expr (tree gnu_decl
, Entity_Id gnat_entity
)
7308 tree type
= TREE_TYPE (gnu_decl
);
7309 tree gnu_stmt
, gnu_init
, t
;
7311 /* If this is a variable that Gigi is to ignore, we may have been given
7312 an ERROR_MARK. So test for it. We also might have been given a
7313 reference for a renaming. So only do something for a decl. Also
7314 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
7315 if (!DECL_P (gnu_decl
)
7316 || (TREE_CODE (gnu_decl
) == TYPE_DECL
7317 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
))
7320 gnu_stmt
= build1 (DECL_EXPR
, void_type_node
, gnu_decl
);
7322 /* If we are external or global, we don't want to output the DECL_EXPR for
7323 this DECL node since we already have evaluated the expressions in the
7324 sizes and positions as globals and doing it again would be wrong. */
7325 if (DECL_EXTERNAL (gnu_decl
) || global_bindings_p ())
7327 /* Mark everything as used to prevent node sharing with subprograms.
7328 Note that walk_tree knows how to deal with TYPE_DECL, but neither
7329 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
7330 MARK_VISITED (gnu_stmt
);
7331 if (TREE_CODE (gnu_decl
) == VAR_DECL
7332 || TREE_CODE (gnu_decl
) == CONST_DECL
)
7334 MARK_VISITED (DECL_SIZE (gnu_decl
));
7335 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl
));
7336 MARK_VISITED (DECL_INITIAL (gnu_decl
));
7338 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
7339 else if (TREE_CODE (gnu_decl
) == TYPE_DECL
7340 && RECORD_OR_UNION_TYPE_P (type
)
7341 && !TYPE_FAT_POINTER_P (type
))
7342 MARK_VISITED (TYPE_ADA_SIZE (type
));
7345 add_stmt_with_node (gnu_stmt
, gnat_entity
);
7347 /* If this is a variable and an initializer is attached to it, it must be
7348 valid for the context. Similar to init_const in create_var_decl_1. */
7349 if (TREE_CODE (gnu_decl
) == VAR_DECL
7350 && (gnu_init
= DECL_INITIAL (gnu_decl
)) != NULL_TREE
7351 && (!gnat_types_compatible_p (type
, TREE_TYPE (gnu_init
))
7352 || (TREE_STATIC (gnu_decl
)
7353 && !initializer_constant_valid_p (gnu_init
,
7354 TREE_TYPE (gnu_init
)))))
7356 /* If GNU_DECL has a padded type, convert it to the unpadded
7357 type so the assignment is done properly. */
7358 if (TYPE_IS_PADDING_P (type
))
7359 t
= convert (TREE_TYPE (TYPE_FIELDS (type
)), gnu_decl
);
7363 gnu_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, t
, gnu_init
);
7365 DECL_INITIAL (gnu_decl
) = NULL_TREE
;
7366 if (TREE_READONLY (gnu_decl
))
7368 TREE_READONLY (gnu_decl
) = 0;
7369 DECL_READONLY_ONCE_ELAB (gnu_decl
) = 1;
7372 add_stmt_with_node (gnu_stmt
, gnat_entity
);
7376 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
7379 mark_visited_r (tree
*tp
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
7383 if (TREE_VISITED (t
))
7386 /* Don't mark a dummy type as visited because we want to mark its sizes
7387 and fields once it's filled in. */
7388 else if (!TYPE_IS_DUMMY_P (t
))
7389 TREE_VISITED (t
) = 1;
7392 TYPE_SIZES_GIMPLIFIED (t
) = 1;
7397 /* Mark nodes rooted at T with TREE_VISITED and types as having their
7398 sized gimplified. We use this to indicate all variable sizes and
7399 positions in global types may not be shared by any subprogram. */
7402 mark_visited (tree t
)
7404 walk_tree (&t
, mark_visited_r
, NULL
, NULL
);
7407 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
7408 set its location to that of GNAT_NODE if present. */
7411 add_cleanup (tree gnu_cleanup
, Node_Id gnat_node
)
7413 if (Present (gnat_node
))
7414 set_expr_location_from_node (gnu_cleanup
, gnat_node
);
7415 append_to_statement_list (gnu_cleanup
, ¤t_stmt_group
->cleanups
);
7418 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
7421 set_block_for_group (tree gnu_block
)
7423 gcc_assert (!current_stmt_group
->block
);
7424 current_stmt_group
->block
= gnu_block
;
7427 /* Return code corresponding to the current code group. It is normally
7428 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
7429 BLOCK or cleanups were set. */
7432 end_stmt_group (void)
7434 struct stmt_group
*group
= current_stmt_group
;
7435 tree gnu_retval
= group
->stmt_list
;
7437 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
7438 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
7439 make a BIND_EXPR. Note that we nest in that because the cleanup may
7440 reference variables in the block. */
7441 if (gnu_retval
== NULL_TREE
)
7442 gnu_retval
= alloc_stmt_list ();
7444 if (group
->cleanups
)
7445 gnu_retval
= build2 (TRY_FINALLY_EXPR
, void_type_node
, gnu_retval
,
7448 if (current_stmt_group
->block
)
7449 gnu_retval
= build3 (BIND_EXPR
, void_type_node
, BLOCK_VARS (group
->block
),
7450 gnu_retval
, group
->block
);
7452 /* Remove this group from the stack and add it to the free list. */
7453 current_stmt_group
= group
->previous
;
7454 group
->previous
= stmt_group_free_list
;
7455 stmt_group_free_list
= group
;
7460 /* Return whether the current statement group may fall through. */
7463 stmt_group_may_fallthru (void)
7465 if (current_stmt_group
->stmt_list
)
7466 return block_may_fallthru (current_stmt_group
->stmt_list
);
7471 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
7475 add_stmt_list (List_Id gnat_list
)
7479 if (Present (gnat_list
))
7480 for (gnat_node
= First (gnat_list
); Present (gnat_node
);
7481 gnat_node
= Next (gnat_node
))
7482 add_stmt (gnat_to_gnu (gnat_node
));
7485 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
7486 If BINDING_P is true, push and pop a binding level around the list. */
7489 build_stmt_group (List_Id gnat_list
, bool binding_p
)
7491 start_stmt_group ();
7495 add_stmt_list (gnat_list
);
7499 return end_stmt_group ();
7502 /* Generate GIMPLE in place for the expression at *EXPR_P. */
7505 gnat_gimplify_expr (tree
*expr_p
, gimple_seq
*pre_p
,
7506 gimple_seq
*post_p ATTRIBUTE_UNUSED
)
7508 tree expr
= *expr_p
;
7511 if (IS_ADA_STMT (expr
))
7512 return gnat_gimplify_stmt (expr_p
);
7514 switch (TREE_CODE (expr
))
7517 /* If this is for a scalar, just make a VAR_DECL for it. If for
7518 an aggregate, get a null pointer of the appropriate type and
7520 if (AGGREGATE_TYPE_P (TREE_TYPE (expr
)))
7521 *expr_p
= build1 (INDIRECT_REF
, TREE_TYPE (expr
),
7522 convert (build_pointer_type (TREE_TYPE (expr
)),
7523 integer_zero_node
));
7526 *expr_p
= create_tmp_var (TREE_TYPE (expr
), NULL
);
7527 TREE_NO_WARNING (*expr_p
) = 1;
7530 gimplify_and_add (TREE_OPERAND (expr
, 0), pre_p
);
7533 case UNCONSTRAINED_ARRAY_REF
:
7534 /* We should only do this if we are just elaborating for side-effects,
7535 but we can't know that yet. */
7536 *expr_p
= TREE_OPERAND (*expr_p
, 0);
7540 op
= TREE_OPERAND (expr
, 0);
7542 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
7543 is put into static memory. We know that it's going to be read-only
7544 given the semantics we have and it must be in static memory when the
7545 reference is in an elaboration procedure. */
7546 if (TREE_CODE (op
) == CONSTRUCTOR
&& TREE_CONSTANT (op
))
7548 tree addr
= build_fold_addr_expr (tree_output_constant_def (op
));
7549 *expr_p
= fold_convert (TREE_TYPE (expr
), addr
);
7553 return GS_UNHANDLED
;
7555 case VIEW_CONVERT_EXPR
:
7556 op
= TREE_OPERAND (expr
, 0);
7558 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
7559 type to a scalar one, explicitly create the local temporary. That's
7560 required if the type is passed by reference. */
7561 if ((TREE_CODE (op
) == CONSTRUCTOR
|| TREE_CODE (op
) == CALL_EXPR
)
7562 && AGGREGATE_TYPE_P (TREE_TYPE (op
))
7563 && !AGGREGATE_TYPE_P (TREE_TYPE (expr
)))
7565 tree mod
, new_var
= create_tmp_var_raw (TREE_TYPE (op
), "C");
7566 gimple_add_tmp_var (new_var
);
7568 mod
= build2 (INIT_EXPR
, TREE_TYPE (new_var
), new_var
, op
);
7569 gimplify_and_add (mod
, pre_p
);
7571 TREE_OPERAND (expr
, 0) = new_var
;
7575 return GS_UNHANDLED
;
7578 op
= DECL_EXPR_DECL (expr
);
7580 /* The expressions for the RM bounds must be gimplified to ensure that
7581 they are properly elaborated. See gimplify_decl_expr. */
7582 if ((TREE_CODE (op
) == TYPE_DECL
|| TREE_CODE (op
) == VAR_DECL
)
7583 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op
)))
7584 switch (TREE_CODE (TREE_TYPE (op
)))
7591 tree type
= TYPE_MAIN_VARIANT (TREE_TYPE (op
)), t
, val
;
7593 val
= TYPE_RM_MIN_VALUE (type
);
7596 gimplify_one_sizepos (&val
, pre_p
);
7597 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
7598 SET_TYPE_RM_MIN_VALUE (t
, val
);
7601 val
= TYPE_RM_MAX_VALUE (type
);
7604 gimplify_one_sizepos (&val
, pre_p
);
7605 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
7606 SET_TYPE_RM_MAX_VALUE (t
, val
);
7616 /* ... fall through ... */
7619 return GS_UNHANDLED
;
7623 /* Generate GIMPLE in place for the statement at *STMT_P. */
7625 static enum gimplify_status
7626 gnat_gimplify_stmt (tree
*stmt_p
)
7628 tree stmt
= *stmt_p
;
7630 switch (TREE_CODE (stmt
))
7633 *stmt_p
= STMT_STMT_STMT (stmt
);
7638 tree gnu_start_label
= create_artificial_label (input_location
);
7639 tree gnu_cond
= LOOP_STMT_COND (stmt
);
7640 tree gnu_update
= LOOP_STMT_UPDATE (stmt
);
7641 tree gnu_end_label
= LOOP_STMT_LABEL (stmt
);
7644 /* Build the condition expression from the test, if any. */
7647 = build3 (COND_EXPR
, void_type_node
, gnu_cond
, alloc_stmt_list (),
7648 build1 (GOTO_EXPR
, void_type_node
, gnu_end_label
));
7650 /* Set to emit the statements of the loop. */
7651 *stmt_p
= NULL_TREE
;
7653 /* We first emit the start label and then a conditional jump to the
7654 end label if there's a top condition, then the update if it's at
7655 the top, then the body of the loop, then a conditional jump to
7656 the end label if there's a bottom condition, then the update if
7657 it's at the bottom, and finally a jump to the start label and the
7658 definition of the end label. */
7659 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
7663 if (gnu_cond
&& !LOOP_STMT_BOTTOM_COND_P (stmt
))
7664 append_to_statement_list (gnu_cond
, stmt_p
);
7666 if (gnu_update
&& LOOP_STMT_TOP_UPDATE_P (stmt
))
7667 append_to_statement_list (gnu_update
, stmt_p
);
7669 append_to_statement_list (LOOP_STMT_BODY (stmt
), stmt_p
);
7671 if (gnu_cond
&& LOOP_STMT_BOTTOM_COND_P (stmt
))
7672 append_to_statement_list (gnu_cond
, stmt_p
);
7674 if (gnu_update
&& !LOOP_STMT_TOP_UPDATE_P (stmt
))
7675 append_to_statement_list (gnu_update
, stmt_p
);
7677 t
= build1 (GOTO_EXPR
, void_type_node
, gnu_start_label
);
7678 SET_EXPR_LOCATION (t
, DECL_SOURCE_LOCATION (gnu_end_label
));
7679 append_to_statement_list (t
, stmt_p
);
7681 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
7688 /* Build a statement to jump to the corresponding end label, then
7689 see if it needs to be conditional. */
7690 *stmt_p
= build1 (GOTO_EXPR
, void_type_node
, EXIT_STMT_LABEL (stmt
));
7691 if (EXIT_STMT_COND (stmt
))
7692 *stmt_p
= build3 (COND_EXPR
, void_type_node
,
7693 EXIT_STMT_COND (stmt
), *stmt_p
, alloc_stmt_list ());
7701 /* Force references to each of the entities in packages withed by GNAT_NODE.
7702 Operate recursively but check that we aren't elaborating something more
7705 This routine is exclusively called in type_annotate mode, to compute DDA
7706 information for types in withed units, for ASIS use. */
7709 elaborate_all_entities (Node_Id gnat_node
)
7711 Entity_Id gnat_with_clause
, gnat_entity
;
7713 /* Process each unit only once. As we trace the context of all relevant
7714 units transitively, including generic bodies, we may encounter the
7715 same generic unit repeatedly. */
7716 if (!present_gnu_tree (gnat_node
))
7717 save_gnu_tree (gnat_node
, integer_zero_node
, true);
7719 /* Save entities in all context units. A body may have an implicit_with
7720 on its own spec, if the context includes a child unit, so don't save
7722 for (gnat_with_clause
= First (Context_Items (gnat_node
));
7723 Present (gnat_with_clause
);
7724 gnat_with_clause
= Next (gnat_with_clause
))
7725 if (Nkind (gnat_with_clause
) == N_With_Clause
7726 && !present_gnu_tree (Library_Unit (gnat_with_clause
))
7727 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
7729 elaborate_all_entities (Library_Unit (gnat_with_clause
));
7731 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
7733 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
7734 Present (gnat_entity
);
7735 gnat_entity
= Next_Entity (gnat_entity
))
7736 if (Is_Public (gnat_entity
)
7737 && Convention (gnat_entity
) != Convention_Intrinsic
7738 && Ekind (gnat_entity
) != E_Package
7739 && Ekind (gnat_entity
) != E_Package_Body
7740 && Ekind (gnat_entity
) != E_Operator
7741 && !(IN (Ekind (gnat_entity
), Type_Kind
)
7742 && !Is_Frozen (gnat_entity
))
7743 && !((Ekind (gnat_entity
) == E_Procedure
7744 || Ekind (gnat_entity
) == E_Function
)
7745 && Is_Intrinsic_Subprogram (gnat_entity
))
7746 && !IN (Ekind (gnat_entity
), Named_Kind
)
7747 && !IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
7748 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
7750 else if (Ekind (Entity (Name (gnat_with_clause
))) == E_Generic_Package
)
7753 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause
)));
7755 /* Retrieve compilation unit node of generic body. */
7756 while (Present (gnat_body
)
7757 && Nkind (gnat_body
) != N_Compilation_Unit
)
7758 gnat_body
= Parent (gnat_body
);
7760 /* If body is available, elaborate its context. */
7761 if (Present (gnat_body
))
7762 elaborate_all_entities (gnat_body
);
7766 if (Nkind (Unit (gnat_node
)) == N_Package_Body
)
7767 elaborate_all_entities (Library_Unit (gnat_node
));
7770 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
7773 process_freeze_entity (Node_Id gnat_node
)
7775 const Entity_Id gnat_entity
= Entity (gnat_node
);
7776 const Entity_Kind kind
= Ekind (gnat_entity
);
7777 tree gnu_old
, gnu_new
;
7779 /* If this is a package, we need to generate code for the package. */
7780 if (kind
== E_Package
)
7783 (Parent (Corresponding_Body
7784 (Parent (Declaration_Node (gnat_entity
)))));
7788 /* Don't do anything for class-wide types as they are always transformed
7789 into their root type. */
7790 if (kind
== E_Class_Wide_Type
)
7793 /* Check for an old definition. This freeze node might be for an Itype. */
7795 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
7797 /* If this entity has an address representation clause, GNU_OLD is the
7798 address, so discard it here. */
7799 if (Present (Address_Clause (gnat_entity
)))
7800 gnu_old
= NULL_TREE
;
7802 /* Don't do anything for subprograms that may have been elaborated before
7803 their freeze nodes. This can happen, for example, because of an inner
7804 call in an instance body or because of previous compilation of a spec
7805 for inlining purposes. */
7807 && ((TREE_CODE (gnu_old
) == FUNCTION_DECL
7808 && (kind
== E_Function
|| kind
== E_Procedure
))
7809 || (TREE_CODE (TREE_TYPE (gnu_old
)) == FUNCTION_TYPE
7810 && kind
== E_Subprogram_Type
)))
7813 /* If we have a non-dummy type old tree, we have nothing to do, except
7814 aborting if this is the public view of a private type whose full view was
7815 not delayed, as this node was never delayed as it should have been. We
7816 let this happen for concurrent types and their Corresponding_Record_Type,
7817 however, because each might legitimately be elaborated before its own
7818 freeze node, e.g. while processing the other. */
7820 && !(TREE_CODE (gnu_old
) == TYPE_DECL
7821 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
7823 gcc_assert ((IN (kind
, Incomplete_Or_Private_Kind
)
7824 && Present (Full_View (gnat_entity
))
7825 && No (Freeze_Node (Full_View (gnat_entity
))))
7826 || Is_Concurrent_Type (gnat_entity
)
7827 || (IN (kind
, Record_Kind
)
7828 && Is_Concurrent_Record_Type (gnat_entity
)));
7832 /* Reset the saved tree, if any, and elaborate the object or type for real.
7833 If there is a full view, elaborate it and use the result. And, if this
7834 is the root type of a class-wide type, reuse it for the latter. */
7837 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
7838 if (IN (kind
, Incomplete_Or_Private_Kind
)
7839 && Present (Full_View (gnat_entity
))
7840 && present_gnu_tree (Full_View (gnat_entity
)))
7841 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, false);
7842 if (IN (kind
, Type_Kind
)
7843 && Present (Class_Wide_Type (gnat_entity
))
7844 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
7845 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, false);
7848 if (IN (kind
, Incomplete_Or_Private_Kind
)
7849 && Present (Full_View (gnat_entity
)))
7851 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
7853 /* Propagate back-annotations from full view to partial view. */
7854 if (Unknown_Alignment (gnat_entity
))
7855 Set_Alignment (gnat_entity
, Alignment (Full_View (gnat_entity
)));
7857 if (Unknown_Esize (gnat_entity
))
7858 Set_Esize (gnat_entity
, Esize (Full_View (gnat_entity
)));
7860 if (Unknown_RM_Size (gnat_entity
))
7861 Set_RM_Size (gnat_entity
, RM_Size (Full_View (gnat_entity
)));
7863 /* The above call may have defined this entity (the simplest example
7864 of this is when we have a private enumeral type since the bounds
7865 will have the public view). */
7866 if (!present_gnu_tree (gnat_entity
))
7867 save_gnu_tree (gnat_entity
, gnu_new
, false);
7872 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
7873 && present_gnu_tree (Declaration_Node (gnat_entity
)))
7874 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
7876 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
7879 if (IN (kind
, Type_Kind
)
7880 && Present (Class_Wide_Type (gnat_entity
))
7881 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
7882 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, false);
7884 /* If we have an old type and we've made pointers to this type, update those
7885 pointers. If this is a Taft amendment type in the main unit, we need to
7886 mark the type as used since other units referencing it don't see the full
7887 declaration and, therefore, cannot mark it as used themselves. */
7890 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
7891 TREE_TYPE (gnu_new
));
7892 if (DECL_TAFT_TYPE_P (gnu_old
))
7893 used_types_insert (TREE_TYPE (gnu_new
));
7897 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
7898 We make two passes, one to elaborate anything other than bodies (but
7899 we declare a function if there was no spec). The second pass
7900 elaborates the bodies.
7902 GNAT_END_LIST gives the element in the list past the end. Normally,
7903 this is Empty, but can be First_Real_Statement for a
7904 Handled_Sequence_Of_Statements.
7906 We make a complete pass through both lists if PASS1P is true, then make
7907 the second pass over both lists if PASS2P is true. The lists usually
7908 correspond to the public and private parts of a package. */
7911 process_decls (List_Id gnat_decls
, List_Id gnat_decls2
,
7912 Node_Id gnat_end_list
, bool pass1p
, bool pass2p
)
7914 List_Id gnat_decl_array
[2];
7918 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
7921 for (i
= 0; i
<= 1; i
++)
7922 if (Present (gnat_decl_array
[i
]))
7923 for (gnat_decl
= First (gnat_decl_array
[i
]);
7924 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
7926 /* For package specs, we recurse inside the declarations,
7927 thus taking the two pass approach inside the boundary. */
7928 if (Nkind (gnat_decl
) == N_Package_Declaration
7929 && (Nkind (Specification (gnat_decl
)
7930 == N_Package_Specification
)))
7931 process_decls (Visible_Declarations (Specification (gnat_decl
)),
7932 Private_Declarations (Specification (gnat_decl
)),
7933 Empty
, true, false);
7935 /* Similarly for any declarations in the actions of a
7937 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
7939 process_freeze_entity (gnat_decl
);
7940 process_decls (Actions (gnat_decl
), Empty
, Empty
, true, false);
7943 /* Package bodies with freeze nodes get their elaboration deferred
7944 until the freeze node, but the code must be placed in the right
7945 place, so record the code position now. */
7946 else if (Nkind (gnat_decl
) == N_Package_Body
7947 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
7948 record_code_position (gnat_decl
);
7950 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
7951 && Present (Library_Unit (gnat_decl
))
7952 && Present (Freeze_Node
7955 (Library_Unit (gnat_decl
)))))))
7956 record_code_position
7957 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
7959 /* We defer most subprogram bodies to the second pass. */
7960 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
7962 if (Acts_As_Spec (gnat_decl
))
7964 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
7966 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
7967 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
7968 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
7972 /* For bodies and stubs that act as their own specs, the entity
7973 itself must be elaborated in the first pass, because it may
7974 be used in other declarations. */
7975 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
7977 Node_Id gnat_subprog_id
7978 = Defining_Entity (Specification (gnat_decl
));
7980 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
7981 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
7982 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
7983 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
7986 /* Concurrent stubs stand for the corresponding subprogram bodies,
7987 which are deferred like other bodies. */
7988 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
7989 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
7993 add_stmt (gnat_to_gnu (gnat_decl
));
7996 /* Here we elaborate everything we deferred above except for package bodies,
7997 which are elaborated at their freeze nodes. Note that we must also
7998 go inside things (package specs and freeze nodes) the first pass did. */
8000 for (i
= 0; i
<= 1; i
++)
8001 if (Present (gnat_decl_array
[i
]))
8002 for (gnat_decl
= First (gnat_decl_array
[i
]);
8003 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
8005 if (Nkind (gnat_decl
) == N_Subprogram_Body
8006 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
8007 || Nkind (gnat_decl
) == N_Task_Body_Stub
8008 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
8009 add_stmt (gnat_to_gnu (gnat_decl
));
8011 else if (Nkind (gnat_decl
) == N_Package_Declaration
8012 && (Nkind (Specification (gnat_decl
)
8013 == N_Package_Specification
)))
8014 process_decls (Visible_Declarations (Specification (gnat_decl
)),
8015 Private_Declarations (Specification (gnat_decl
)),
8016 Empty
, false, true);
8018 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
8019 process_decls (Actions (gnat_decl
), Empty
, Empty
, false, true);
8023 /* Make a unary operation of kind CODE using build_unary_op, but guard
8024 the operation by an overflow check. CODE can be one of NEGATE_EXPR
8025 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
8026 the operation is to be performed in that type. GNAT_NODE is the gnat
8027 node conveying the source location for which the error should be
8031 build_unary_op_trapv (enum tree_code code
, tree gnu_type
, tree operand
,
8034 gcc_assert (code
== NEGATE_EXPR
|| code
== ABS_EXPR
);
8036 operand
= gnat_protect_expr (operand
);
8038 return emit_check (build_binary_op (EQ_EXPR
, boolean_type_node
,
8039 operand
, TYPE_MIN_VALUE (gnu_type
)),
8040 build_unary_op (code
, gnu_type
, operand
),
8041 CE_Overflow_Check_Failed
, gnat_node
);
8044 /* Make a binary operation of kind CODE using build_binary_op, but guard
8045 the operation by an overflow check. CODE can be one of PLUS_EXPR,
8046 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
8047 Usually the operation is to be performed in that type. GNAT_NODE is
8048 the GNAT node conveying the source location for which the error should
8052 build_binary_op_trapv (enum tree_code code
, tree gnu_type
, tree left
,
8053 tree right
, Node_Id gnat_node
)
8055 tree lhs
= gnat_protect_expr (left
);
8056 tree rhs
= gnat_protect_expr (right
);
8057 tree type_max
= TYPE_MAX_VALUE (gnu_type
);
8058 tree type_min
= TYPE_MIN_VALUE (gnu_type
);
8061 tree zero
= convert (gnu_type
, integer_zero_node
);
8066 int precision
= TYPE_PRECISION (gnu_type
);
8068 gcc_assert (!(precision
& (precision
- 1))); /* ensure power of 2 */
8070 /* Prefer a constant or known-positive rhs to simplify checks. */
8071 if (!TREE_CONSTANT (rhs
)
8072 && commutative_tree_code (code
)
8073 && (TREE_CONSTANT (lhs
) || (!tree_expr_nonnegative_p (rhs
)
8074 && tree_expr_nonnegative_p (lhs
))))
8081 rhs_lt_zero
= tree_expr_nonnegative_p (rhs
)
8082 ? boolean_false_node
8083 : build_binary_op (LT_EXPR
, boolean_type_node
, rhs
, zero
);
8085 /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
8087 /* Try a few strategies that may be cheaper than the general
8088 code at the end of the function, if the rhs is not known.
8090 - Call library function for 64-bit multiplication (complex)
8091 - Widen, if input arguments are sufficiently small
8092 - Determine overflow using wrapped result for addition/subtraction. */
8094 if (!TREE_CONSTANT (rhs
))
8096 /* Even for add/subtract double size to get another base type. */
8097 int needed_precision
= precision
* 2;
8099 if (code
== MULT_EXPR
&& precision
== 64)
8101 tree int_64
= gnat_type_for_size (64, 0);
8103 return convert (gnu_type
, build_call_n_expr (mulv64_decl
, 2,
8104 convert (int_64
, lhs
),
8105 convert (int_64
, rhs
)));
8108 else if (needed_precision
<= BITS_PER_WORD
8109 || (code
== MULT_EXPR
8110 && needed_precision
<= LONG_LONG_TYPE_SIZE
))
8112 tree wide_type
= gnat_type_for_size (needed_precision
, 0);
8114 tree wide_result
= build_binary_op (code
, wide_type
,
8115 convert (wide_type
, lhs
),
8116 convert (wide_type
, rhs
));
8118 tree check
= build_binary_op
8119 (TRUTH_ORIF_EXPR
, boolean_type_node
,
8120 build_binary_op (LT_EXPR
, boolean_type_node
, wide_result
,
8121 convert (wide_type
, type_min
)),
8122 build_binary_op (GT_EXPR
, boolean_type_node
, wide_result
,
8123 convert (wide_type
, type_max
)));
8125 tree result
= convert (gnu_type
, wide_result
);
8128 emit_check (check
, result
, CE_Overflow_Check_Failed
, gnat_node
);
8131 else if (code
== PLUS_EXPR
|| code
== MINUS_EXPR
)
8133 tree unsigned_type
= gnat_type_for_size (precision
, 1);
8134 tree wrapped_expr
= convert
8135 (gnu_type
, build_binary_op (code
, unsigned_type
,
8136 convert (unsigned_type
, lhs
),
8137 convert (unsigned_type
, rhs
)));
8139 tree result
= convert
8140 (gnu_type
, build_binary_op (code
, gnu_type
, lhs
, rhs
));
8142 /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
8143 or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */
8144 tree check
= build_binary_op
8145 (TRUTH_XOR_EXPR
, boolean_type_node
, rhs_lt_zero
,
8146 build_binary_op (code
== PLUS_EXPR
? LT_EXPR
: GT_EXPR
,
8147 boolean_type_node
, wrapped_expr
, lhs
));
8150 emit_check (check
, result
, CE_Overflow_Check_Failed
, gnat_node
);
8157 /* When rhs >= 0, overflow when lhs > type_max - rhs. */
8158 check_pos
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
8159 build_binary_op (MINUS_EXPR
, gnu_type
,
8162 /* When rhs < 0, overflow when lhs < type_min - rhs. */
8163 check_neg
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
8164 build_binary_op (MINUS_EXPR
, gnu_type
,
8169 /* When rhs >= 0, overflow when lhs < type_min + rhs. */
8170 check_pos
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
8171 build_binary_op (PLUS_EXPR
, gnu_type
,
8174 /* When rhs < 0, overflow when lhs > type_max + rhs. */
8175 check_neg
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
8176 build_binary_op (PLUS_EXPR
, gnu_type
,
8181 /* The check here is designed to be efficient if the rhs is constant,
8182 but it will work for any rhs by using integer division.
8183 Four different check expressions determine whether X * C overflows,
8186 C > 0 => X > type_max / C || X < type_min / C
8187 C == -1 => X == type_min
8188 C < -1 => X > type_min / C || X < type_max / C */
8190 tmp1
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
8191 tmp2
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
8194 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
8195 build_binary_op (NE_EXPR
, boolean_type_node
, zero
,
8197 build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
8198 build_binary_op (GT_EXPR
,
8201 build_binary_op (LT_EXPR
,
8206 = fold_build3 (COND_EXPR
, boolean_type_node
,
8207 build_binary_op (EQ_EXPR
, boolean_type_node
, rhs
,
8208 build_int_cst (gnu_type
, -1)),
8209 build_binary_op (EQ_EXPR
, boolean_type_node
, lhs
,
8211 build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
8212 build_binary_op (GT_EXPR
,
8215 build_binary_op (LT_EXPR
,
8224 gnu_expr
= build_binary_op (code
, gnu_type
, lhs
, rhs
);
8226 /* If we can fold the expression to a constant, just return it.
8227 The caller will deal with overflow, no need to generate a check. */
8228 if (TREE_CONSTANT (gnu_expr
))
8231 check
= fold_build3 (COND_EXPR
, boolean_type_node
, rhs_lt_zero
, check_neg
,
8234 return emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
8237 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
8238 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
8239 which we have to check. GNAT_NODE is the GNAT node conveying the source
8240 location for which the error should be signaled. */
8243 emit_range_check (tree gnu_expr
, Entity_Id gnat_range_type
, Node_Id gnat_node
)
8245 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
8246 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
8248 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
8249 This can for example happen when translating 'Val or 'Value. */
8250 if (gnu_compare_type
== gnu_range_type
)
8253 /* Range checks can only be applied to types with ranges. */
8254 gcc_assert (INTEGRAL_TYPE_P (gnu_range_type
)
8255 || SCALAR_FLOAT_TYPE_P (gnu_range_type
));
8257 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
8258 we can't do anything since we might be truncating the bounds. No
8259 check is needed in this case. */
8260 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
8261 && (TYPE_PRECISION (gnu_compare_type
)
8262 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
8265 /* Checked expressions must be evaluated only once. */
8266 gnu_expr
= gnat_protect_expr (gnu_expr
);
8268 /* Note that the form of the check is
8269 (not (expr >= lo)) or (not (expr <= hi))
8270 the reason for this slightly convoluted form is that NaNs
8271 are not considered to be in range in the float case. */
8273 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
8275 (build_binary_op (GE_EXPR
, boolean_type_node
,
8276 convert (gnu_compare_type
, gnu_expr
),
8277 convert (gnu_compare_type
,
8279 (gnu_range_type
)))),
8281 (build_binary_op (LE_EXPR
, boolean_type_node
,
8282 convert (gnu_compare_type
, gnu_expr
),
8283 convert (gnu_compare_type
,
8285 (gnu_range_type
))))),
8286 gnu_expr
, CE_Range_Check_Failed
, gnat_node
);
8289 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which
8290 we are about to index, GNU_EXPR is the index expression to be checked,
8291 GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
8292 has to be checked. Note that for index checking we cannot simply use the
8293 emit_range_check function (although very similar code needs to be generated
8294 in both cases) since for index checking the array type against which we are
8295 checking the indices may be unconstrained and consequently we need to get
8296 the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
8297 The place where we need to do that is in subprograms having unconstrained
8298 array formal parameters. GNAT_NODE is the GNAT node conveying the source
8299 location for which the error should be signaled. */
8302 emit_index_check (tree gnu_array_object
, tree gnu_expr
, tree gnu_low
,
8303 tree gnu_high
, Node_Id gnat_node
)
8305 tree gnu_expr_check
;
8307 /* Checked expressions must be evaluated only once. */
8308 gnu_expr
= gnat_protect_expr (gnu_expr
);
8310 /* Must do this computation in the base type in case the expression's
8311 type is an unsigned subtypes. */
8312 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
8314 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
8315 the object we are handling. */
8316 gnu_low
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low
, gnu_array_object
);
8317 gnu_high
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high
, gnu_array_object
);
8320 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
8321 build_binary_op (LT_EXPR
, boolean_type_node
,
8323 convert (TREE_TYPE (gnu_expr_check
),
8325 build_binary_op (GT_EXPR
, boolean_type_node
,
8327 convert (TREE_TYPE (gnu_expr_check
),
8329 gnu_expr
, CE_Index_Check_Failed
, gnat_node
);
8332 /* GNU_COND contains the condition corresponding to an access, discriminant or
8333 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
8334 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
8335 REASON is the code that says why the exception was raised. GNAT_NODE is
8336 the GNAT node conveying the source location for which the error should be
8340 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
, Node_Id gnat_node
)
8343 = build_call_raise (reason
, gnat_node
, N_Raise_Constraint_Error
);
8345 = fold_build3 (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
8346 build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_call
,
8347 convert (TREE_TYPE (gnu_expr
), integer_zero_node
)),
8350 /* GNU_RESULT has side effects if and only if GNU_EXPR has:
8351 we don't need to evaluate it just for the check. */
8352 TREE_SIDE_EFFECTS (gnu_result
) = TREE_SIDE_EFFECTS (gnu_expr
);
8357 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
8358 checks if OVERFLOW_P is true and range checks if RANGE_P is true.
8359 GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
8360 float to integer conversion with truncation; otherwise round.
8361 GNAT_NODE is the GNAT node conveying the source location for which the
8362 error should be signaled. */
8365 convert_with_check (Entity_Id gnat_type
, tree gnu_expr
, bool overflowp
,
8366 bool rangep
, bool truncatep
, Node_Id gnat_node
)
8368 tree gnu_type
= get_unpadded_type (gnat_type
);
8369 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
8370 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
8371 tree gnu_base_type
= get_base_type (gnu_type
);
8372 tree gnu_result
= gnu_expr
;
8374 /* If we are not doing any checks, the output is an integral type, and
8375 the input is not a floating type, just do the conversion. This
8376 shortcut is required to avoid problems with packed array types
8377 and simplifies code in all cases anyway. */
8378 if (!rangep
&& !overflowp
&& INTEGRAL_TYPE_P (gnu_base_type
)
8379 && !FLOAT_TYPE_P (gnu_in_type
))
8380 return convert (gnu_type
, gnu_expr
);
8382 /* First convert the expression to its base type. This
8383 will never generate code, but makes the tests below much simpler.
8384 But don't do this if converting from an integer type to an unconstrained
8385 array type since then we need to get the bounds from the original
8387 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
8388 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
8390 /* If overflow checks are requested, we need to be sure the result will
8391 fit in the output base type. But don't do this if the input
8392 is integer and the output floating-point. */
8394 && !(FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
8396 /* Ensure GNU_EXPR only gets evaluated once. */
8397 tree gnu_input
= gnat_protect_expr (gnu_result
);
8398 tree gnu_cond
= boolean_false_node
;
8399 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
8400 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
8401 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
8402 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
8404 /* Convert the lower bounds to signed types, so we're sure we're
8405 comparing them properly. Likewise, convert the upper bounds
8406 to unsigned types. */
8407 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TYPE_UNSIGNED (gnu_in_basetype
))
8408 gnu_in_lb
= convert (gnat_signed_type (gnu_in_basetype
), gnu_in_lb
);
8410 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
8411 && !TYPE_UNSIGNED (gnu_in_basetype
))
8412 gnu_in_ub
= convert (gnat_unsigned_type (gnu_in_basetype
), gnu_in_ub
);
8414 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
8415 gnu_out_lb
= convert (gnat_signed_type (gnu_base_type
), gnu_out_lb
);
8417 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
8418 gnu_out_ub
= convert (gnat_unsigned_type (gnu_base_type
), gnu_out_ub
);
8420 /* Check each bound separately and only if the result bound
8421 is tighter than the bound on the input type. Note that all the
8422 types are base types, so the bounds must be constant. Also,
8423 the comparison is done in the base type of the input, which
8424 always has the proper signedness. First check for input
8425 integer (which means output integer), output float (which means
8426 both float), or mixed, in which case we always compare.
8427 Note that we have to do the comparison which would *fail* in the
8428 case of an error since if it's an FP comparison and one of the
8429 values is a NaN or Inf, the comparison will fail. */
8430 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
8431 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
8432 : (FLOAT_TYPE_P (gnu_base_type
)
8433 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
8434 TREE_REAL_CST (gnu_out_lb
))
8438 (build_binary_op (GE_EXPR
, boolean_type_node
,
8439 gnu_input
, convert (gnu_in_basetype
,
8442 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
8443 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
8444 : (FLOAT_TYPE_P (gnu_base_type
)
8445 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
8446 TREE_REAL_CST (gnu_in_lb
))
8449 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, gnu_cond
,
8451 (build_binary_op (LE_EXPR
, boolean_type_node
,
8453 convert (gnu_in_basetype
,
8456 if (!integer_zerop (gnu_cond
))
8457 gnu_result
= emit_check (gnu_cond
, gnu_input
,
8458 CE_Overflow_Check_Failed
, gnat_node
);
8461 /* Now convert to the result base type. If this is a non-truncating
8462 float-to-integer conversion, round. */
8463 if (INTEGRAL_TYPE_P (gnu_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
8466 REAL_VALUE_TYPE half_minus_pred_half
, pred_half
;
8467 tree gnu_conv
, gnu_zero
, gnu_comp
, calc_type
;
8468 tree gnu_pred_half
, gnu_add_pred_half
, gnu_subtract_pred_half
;
8469 const struct real_format
*fmt
;
8471 /* The following calculations depend on proper rounding to even
8472 of each arithmetic operation. In order to prevent excess
8473 precision from spoiling this property, use the widest hardware
8474 floating-point type if FP_ARITH_MAY_WIDEN is true. */
8476 = FP_ARITH_MAY_WIDEN
? longest_float_type_node
: gnu_in_basetype
;
8478 /* FIXME: Should not have padding in the first place. */
8479 if (TYPE_IS_PADDING_P (calc_type
))
8480 calc_type
= TREE_TYPE (TYPE_FIELDS (calc_type
));
8482 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
8483 fmt
= REAL_MODE_FORMAT (TYPE_MODE (calc_type
));
8484 real_2expN (&half_minus_pred_half
, -(fmt
->p
) - 1, TYPE_MODE (calc_type
));
8485 REAL_ARITHMETIC (pred_half
, MINUS_EXPR
, dconsthalf
,
8486 half_minus_pred_half
);
8487 gnu_pred_half
= build_real (calc_type
, pred_half
);
8489 /* If the input is strictly negative, subtract this value
8490 and otherwise add it from the input. For 0.5, the result
8491 is exactly between 1.0 and the machine number preceding 1.0
8492 (for calc_type). Since the last bit of 1.0 is even, this 0.5
8493 will round to 1.0, while all other number with an absolute
8494 value less than 0.5 round to 0.0. For larger numbers exactly
8495 halfway between integers, rounding will always be correct as
8496 the true mathematical result will be closer to the higher
8497 integer compared to the lower one. So, this constant works
8498 for all floating-point numbers.
8500 The reason to use the same constant with subtract/add instead
8501 of a positive and negative constant is to allow the comparison
8502 to be scheduled in parallel with retrieval of the constant and
8503 conversion of the input to the calc_type (if necessary). */
8505 gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
8506 gnu_result
= gnat_protect_expr (gnu_result
);
8507 gnu_conv
= convert (calc_type
, gnu_result
);
8509 = fold_build2 (GE_EXPR
, boolean_type_node
, gnu_result
, gnu_zero
);
8511 = fold_build2 (PLUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
8512 gnu_subtract_pred_half
8513 = fold_build2 (MINUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
8514 gnu_result
= fold_build3 (COND_EXPR
, calc_type
, gnu_comp
,
8515 gnu_add_pred_half
, gnu_subtract_pred_half
);
8518 if (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
8519 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type
)
8520 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
8521 gnu_result
= unchecked_convert (gnu_base_type
, gnu_result
, false);
8523 gnu_result
= convert (gnu_base_type
, gnu_result
);
8525 /* Finally, do the range check if requested. Note that if the result type
8526 is a modular type, the range check is actually an overflow check. */
8528 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
8529 && TYPE_MODULAR_P (gnu_base_type
) && overflowp
))
8530 gnu_result
= emit_range_check (gnu_result
, gnat_type
, gnat_node
);
8532 return convert (gnu_type
, gnu_result
);
8535 /* Return true if GNU_EXPR can be directly addressed. This is the case
8536 unless it is an expression involving computation or if it involves a
8537 reference to a bitfield or to an object not sufficiently aligned for
8538 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
8539 be directly addressed as an object of this type.
8541 *** Notes on addressability issues in the Ada compiler ***
8543 This predicate is necessary in order to bridge the gap between Gigi
8544 and the middle-end about addressability of GENERIC trees. A tree
8545 is said to be addressable if it can be directly addressed, i.e. if
8546 its address can be taken, is a multiple of the type's alignment on
8547 strict-alignment architectures and returns the first storage unit
8548 assigned to the object represented by the tree.
8550 In the C family of languages, everything is in practice addressable
8551 at the language level, except for bit-fields. This means that these
8552 compilers will take the address of any tree that doesn't represent
8553 a bit-field reference and expect the result to be the first storage
8554 unit assigned to the object. Even in cases where this will result
8555 in unaligned accesses at run time, nothing is supposed to be done
8556 and the program is considered as erroneous instead (see PR c/18287).
8558 The implicit assumptions made in the middle-end are in keeping with
8559 the C viewpoint described above:
8560 - the address of a bit-field reference is supposed to be never
8561 taken; the compiler (generally) will stop on such a construct,
8562 - any other tree is addressable if it is formally addressable,
8563 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
8565 In Ada, the viewpoint is the opposite one: nothing is addressable
8566 at the language level unless explicitly declared so. This means
8567 that the compiler will both make sure that the trees representing
8568 references to addressable ("aliased" in Ada parlance) objects are
8569 addressable and make no real attempts at ensuring that the trees
8570 representing references to non-addressable objects are addressable.
8572 In the first case, Ada is effectively equivalent to C and handing
8573 down the direct result of applying ADDR_EXPR to these trees to the
8574 middle-end works flawlessly. In the second case, Ada cannot afford
8575 to consider the program as erroneous if the address of trees that
8576 are not addressable is requested for technical reasons, unlike C;
8577 as a consequence, the Ada compiler must arrange for either making
8578 sure that this address is not requested in the middle-end or for
8579 compensating by inserting temporaries if it is requested in Gigi.
8581 The first goal can be achieved because the middle-end should not
8582 request the address of non-addressable trees on its own; the only
8583 exception is for the invocation of low-level block operations like
8584 memcpy, for which the addressability requirements are lower since
8585 the type's alignment can be disregarded. In practice, this means
8586 that Gigi must make sure that such operations cannot be applied to
8587 non-BLKmode bit-fields.
8589 The second goal is achieved by means of the addressable_p predicate,
8590 which computes whether a temporary must be inserted by Gigi when the
8591 address of a tree is requested; if so, the address of the temporary
8592 will be used in lieu of that of the original tree and some glue code
8593 generated to connect everything together. */
8596 addressable_p (tree gnu_expr
, tree gnu_type
)
8598 /* For an integral type, the size of the actual type of the object may not
8599 be greater than that of the expected type, otherwise an indirect access
8600 in the latter type wouldn't correctly set all the bits of the object. */
8602 && INTEGRAL_TYPE_P (gnu_type
)
8603 && smaller_form_type_p (gnu_type
, TREE_TYPE (gnu_expr
)))
8606 /* The size of the actual type of the object may not be smaller than that
8607 of the expected type, otherwise an indirect access in the latter type
8608 would be larger than the object. But only record types need to be
8609 considered in practice for this case. */
8611 && TREE_CODE (gnu_type
) == RECORD_TYPE
8612 && smaller_form_type_p (TREE_TYPE (gnu_expr
), gnu_type
))
8615 switch (TREE_CODE (gnu_expr
))
8621 /* All DECLs are addressable: if they are in a register, we can force
8625 case UNCONSTRAINED_ARRAY_REF
:
8627 /* Taking the address of a dereference yields the original pointer. */
8632 /* Taking the address yields a pointer to the constant pool. */
8636 /* Taking the address of a static constructor yields a pointer to the
8637 tree constant pool. */
8638 return TREE_STATIC (gnu_expr
) ? true : false;
8649 /* All rvalues are deemed addressable since taking their address will
8650 force a temporary to be created by the middle-end. */
8654 /* The address of a compound expression is that of its 2nd operand. */
8655 return addressable_p (TREE_OPERAND (gnu_expr
, 1), gnu_type
);
8658 /* We accept &COND_EXPR as soon as both operands are addressable and
8659 expect the outcome to be the address of the selected operand. */
8660 return (addressable_p (TREE_OPERAND (gnu_expr
, 1), NULL_TREE
)
8661 && addressable_p (TREE_OPERAND (gnu_expr
, 2), NULL_TREE
));
8664 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
8665 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
8666 the field is sufficiently aligned, in case it is subject
8667 to a pragma Component_Alignment. But we don't need to
8668 check the alignment of the containing record, as it is
8669 guaranteed to be not smaller than that of its most
8670 aligned field that is not a bit-field. */
8671 && (!STRICT_ALIGNMENT
8672 || DECL_ALIGN (TREE_OPERAND (gnu_expr
, 1))
8673 >= TYPE_ALIGN (TREE_TYPE (gnu_expr
))))
8674 /* The field of a padding record is always addressable. */
8675 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
8676 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
8678 case ARRAY_REF
: case ARRAY_RANGE_REF
:
8679 case REALPART_EXPR
: case IMAGPART_EXPR
:
8681 return addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
);
8684 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
8685 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
8687 case VIEW_CONVERT_EXPR
:
8689 /* This is addressable if we can avoid a copy. */
8690 tree type
= TREE_TYPE (gnu_expr
);
8691 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
8692 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
8693 && (!STRICT_ALIGNMENT
8694 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
8695 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
8696 || ((TYPE_MODE (type
) == BLKmode
8697 || TYPE_MODE (inner_type
) == BLKmode
)
8698 && (!STRICT_ALIGNMENT
8699 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
8700 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
8701 || TYPE_ALIGN_OK (type
)
8702 || TYPE_ALIGN_OK (inner_type
))))
8703 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
8711 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
8712 a separate Freeze node exists, delay the bulk of the processing. Otherwise
8713 make a GCC type for GNAT_ENTITY and set up the correspondence. */
8716 process_type (Entity_Id gnat_entity
)
8719 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
8722 /* If we are to delay elaboration of this type, just do any
8723 elaborations needed for expressions within the declaration and
8724 make a dummy type entry for this node and its Full_View (if
8725 any) in case something points to it. Don't do this if it
8726 has already been done (the only way that can happen is if
8727 the private completion is also delayed). */
8728 if (Present (Freeze_Node (gnat_entity
))
8729 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
8730 && Present (Full_View (gnat_entity
))
8731 && Present (Freeze_Node (Full_View (gnat_entity
)))
8732 && !present_gnu_tree (Full_View (gnat_entity
))))
8734 elaborate_entity (gnat_entity
);
8738 tree gnu_decl
= TYPE_STUB_DECL (make_dummy_type (gnat_entity
));
8739 save_gnu_tree (gnat_entity
, gnu_decl
, false);
8740 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
8741 && Present (Full_View (gnat_entity
)))
8743 if (Has_Completion_In_Body (gnat_entity
))
8744 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
8745 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, false);
8752 /* If we saved away a dummy type for this node it means that this
8753 made the type that corresponds to the full type of an incomplete
8754 type. Clear that type for now and then update the type in the
8758 gcc_assert (TREE_CODE (gnu_old
) == TYPE_DECL
8759 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)));
8761 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
8764 /* Now fully elaborate the type. */
8765 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
8766 gcc_assert (TREE_CODE (gnu_new
) == TYPE_DECL
);
8768 /* If we have an old type and we've made pointers to this type, update those
8769 pointers. If this is a Taft amendment type in the main unit, we need to
8770 mark the type as used since other units referencing it don't see the full
8771 declaration and, therefore, cannot mark it as used themselves. */
8774 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
8775 TREE_TYPE (gnu_new
));
8776 if (DECL_TAFT_TYPE_P (gnu_old
))
8777 used_types_insert (TREE_TYPE (gnu_new
));
8780 /* If this is a record type corresponding to a task or protected type
8781 that is a completion of an incomplete type, perform a similar update
8782 on the type. ??? Including protected types here is a guess. */
8783 if (IN (Ekind (gnat_entity
), Record_Kind
)
8784 && Is_Concurrent_Record_Type (gnat_entity
)
8785 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
8788 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
8790 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
8792 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
8795 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
8796 TREE_TYPE (gnu_new
));
8800 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
8801 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
8802 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
8805 assoc_to_constructor (Entity_Id gnat_entity
, Node_Id gnat_assoc
, tree gnu_type
)
8807 tree gnu_list
= NULL_TREE
, gnu_result
;
8809 /* We test for GNU_FIELD being empty in the case where a variant
8810 was the last thing since we don't take things off GNAT_ASSOC in
8811 that case. We check GNAT_ASSOC in case we have a variant, but it
8814 for (; Present (gnat_assoc
); gnat_assoc
= Next (gnat_assoc
))
8816 Node_Id gnat_field
= First (Choices (gnat_assoc
));
8817 tree gnu_field
= gnat_to_gnu_field_decl (Entity (gnat_field
));
8818 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
8820 /* The expander is supposed to put a single component selector name
8821 in every record component association. */
8822 gcc_assert (No (Next (gnat_field
)));
8824 /* Ignore fields that have Corresponding_Discriminants since we'll
8825 be setting that field in the parent. */
8826 if (Present (Corresponding_Discriminant (Entity (gnat_field
)))
8827 && Is_Tagged_Type (Scope (Entity (gnat_field
))))
8830 /* Also ignore discriminants of Unchecked_Unions. */
8831 if (Is_Unchecked_Union (gnat_entity
)
8832 && Ekind (Entity (gnat_field
)) == E_Discriminant
)
8835 /* Before assigning a value in an aggregate make sure range checks
8836 are done if required. Then convert to the type of the field. */
8837 if (Do_Range_Check (Expression (gnat_assoc
)))
8838 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
), Empty
);
8840 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
8842 /* Add the field and expression to the list. */
8843 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
8846 gnu_result
= extract_values (gnu_list
, gnu_type
);
8848 #ifdef ENABLE_CHECKING
8849 /* Verify that every entry in GNU_LIST was used. */
8850 for (; gnu_list
; gnu_list
= TREE_CHAIN (gnu_list
))
8851 gcc_assert (TREE_ADDRESSABLE (gnu_list
));
8857 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
8858 the first element of an array aggregate. It may itself be an aggregate.
8859 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
8860 GNAT_COMPONENT_TYPE is the type of the array component; it is needed
8861 for range checking. */
8864 pos_to_constructor (Node_Id gnat_expr
, tree gnu_array_type
,
8865 Entity_Id gnat_component_type
)
8867 tree gnu_index
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type
));
8869 vec
<constructor_elt
, va_gc
> *gnu_expr_vec
= NULL
;
8871 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
8873 /* If the expression is itself an array aggregate then first build the
8874 innermost constructor if it is part of our array (multi-dimensional
8876 if (Nkind (gnat_expr
) == N_Aggregate
8877 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
8878 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
8879 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
8880 TREE_TYPE (gnu_array_type
),
8881 gnat_component_type
);
8884 gnu_expr
= gnat_to_gnu (gnat_expr
);
8886 /* Before assigning the element to the array, make sure it is
8888 if (Do_Range_Check (gnat_expr
))
8889 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
, Empty
);
8892 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec
, gnu_index
,
8893 convert (TREE_TYPE (gnu_array_type
), gnu_expr
));
8895 gnu_index
= int_const_binop (PLUS_EXPR
, gnu_index
, integer_one_node
);
8898 return gnat_build_constructor (gnu_array_type
, gnu_expr_vec
);
8901 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
8902 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
8903 of the associations that are from RECORD_TYPE. If we see an internal
8904 record, make a recursive call to fill it in as well. */
8907 extract_values (tree values
, tree record_type
)
8910 vec
<constructor_elt
, va_gc
> *v
= NULL
;
8912 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
8916 /* _Parent is an internal field, but may have values in the aggregate,
8917 so check for values first. */
8918 if ((tem
= purpose_member (field
, values
)))
8920 value
= TREE_VALUE (tem
);
8921 TREE_ADDRESSABLE (tem
) = 1;
8924 else if (DECL_INTERNAL_P (field
))
8926 value
= extract_values (values
, TREE_TYPE (field
));
8927 if (TREE_CODE (value
) == CONSTRUCTOR
8928 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value
)))
8932 /* If we have a record subtype, the names will match, but not the
8933 actual FIELD_DECLs. */
8934 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
8935 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
8937 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
8938 TREE_ADDRESSABLE (tem
) = 1;
8944 CONSTRUCTOR_APPEND_ELT (v
, field
, value
);
8947 return gnat_build_constructor (record_type
, v
);
8950 /* Process a N_Validate_Unchecked_Conversion node. */
8953 validate_unchecked_conversion (Node_Id gnat_node
)
8955 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
8956 tree gnu_target_type
= gnat_to_gnu_type (Target_Type (gnat_node
));
8958 /* If the target is a pointer type, see if we are either converting from a
8959 non-pointer or from a pointer to a type with a different alias set and
8960 warn if so, unless the pointer has been marked to alias everything. */
8961 if (POINTER_TYPE_P (gnu_target_type
)
8962 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type
))
8964 tree gnu_source_desig_type
= POINTER_TYPE_P (gnu_source_type
)
8965 ? TREE_TYPE (gnu_source_type
)
8967 tree gnu_target_desig_type
= TREE_TYPE (gnu_target_type
);
8968 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
8970 if (target_alias_set
!= 0
8971 && (!POINTER_TYPE_P (gnu_source_type
)
8972 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
8975 post_error_ne ("?possible aliasing problem for type&",
8976 gnat_node
, Target_Type (gnat_node
));
8977 post_error ("\\?use -fno-strict-aliasing switch for references",
8979 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
8980 gnat_node
, Target_Type (gnat_node
));
8984 /* Likewise if the target is a fat pointer type, but we have no mechanism to
8985 mitigate the problem in this case, so we unconditionally warn. */
8986 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type
))
8988 tree gnu_source_desig_type
8989 = TYPE_IS_FAT_POINTER_P (gnu_source_type
)
8990 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type
)))
8992 tree gnu_target_desig_type
8993 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type
)));
8994 alias_set_type target_alias_set
= get_alias_set (gnu_target_desig_type
);
8996 if (target_alias_set
!= 0
8997 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type
)
8998 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type
),
9001 post_error_ne ("?possible aliasing problem for type&",
9002 gnat_node
, Target_Type (gnat_node
));
9003 post_error ("\\?use -fno-strict-aliasing switch for references",
9009 /* EXP is to be treated as an array or record. Handle the cases when it is
9010 an access object and perform the required dereferences. */
9013 maybe_implicit_deref (tree exp
)
9015 /* If the type is a pointer, dereference it. */
9016 if (POINTER_TYPE_P (TREE_TYPE (exp
))
9017 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp
)))
9018 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
9020 /* If we got a padded type, remove it too. */
9021 if (TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
9022 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
9027 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
9028 location and false if it doesn't. In the former case, set the Gigi global
9029 variable REF_FILENAME to the simple debug file name as given by sinput. */
9032 Sloc_to_locus (Source_Ptr Sloc
, location_t
*locus
)
9034 if (Sloc
== No_Location
)
9037 if (Sloc
<= Standard_Location
)
9039 *locus
= BUILTINS_LOCATION
;
9044 Source_File_Index file
= Get_Source_File_Index (Sloc
);
9045 Logical_Line_Number line
= Get_Logical_Line_Number (Sloc
);
9046 Column_Number column
= Get_Column_Number (Sloc
);
9047 struct line_map
*map
= LINEMAPS_ORDINARY_MAP_AT (line_table
, file
- 1);
9049 /* We can have zero if pragma Source_Reference is in effect. */
9053 /* Translate the location. */
9054 *locus
= linemap_position_for_line_and_column (map
, line
, column
);
9058 = IDENTIFIER_POINTER
9060 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc
)))));;
9065 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
9066 don't do anything if it doesn't correspond to a source location. */
9069 set_expr_location_from_node (tree node
, Node_Id gnat_node
)
9073 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
))
9076 SET_EXPR_LOCATION (node
, locus
);
9079 /* More elaborate version of set_expr_location_from_node to be used in more
9080 general contexts, for example the result of the translation of a generic
9084 set_gnu_expr_location_from_node (tree node
, Node_Id gnat_node
)
9086 /* Set the location information on the node if it is a real expression.
9087 References can be reused for multiple GNAT nodes and they would get
9088 the location information of their last use. Also make sure not to
9089 overwrite an existing location as it is probably more precise. */
9091 switch (TREE_CODE (node
))
9094 case NON_LVALUE_EXPR
:
9098 if (EXPR_P (TREE_OPERAND (node
, 1)))
9099 set_gnu_expr_location_from_node (TREE_OPERAND (node
, 1), gnat_node
);
9101 /* ... fall through ... */
9104 if (!REFERENCE_CLASS_P (node
) && !EXPR_HAS_LOCATION (node
))
9106 set_expr_location_from_node (node
, gnat_node
);
9107 set_end_locus_from_node (node
, gnat_node
);
9113 /* Return a colon-separated list of encodings contained in encoded Ada
9117 extract_encoding (const char *name
)
9119 char *encoding
= (char *) ggc_alloc_atomic (strlen (name
));
9120 get_encoding (name
, encoding
);
9124 /* Extract the Ada name from an encoded name. */
9127 decode_name (const char *name
)
9129 char *decoded
= (char *) ggc_alloc_atomic (strlen (name
) * 2 + 60);
9130 __gnat_decode (name
, decoded
, 0);
9134 /* Post an error message. MSG is the error message, properly annotated.
9135 NODE is the node at which to post the error and the node to use for the
9136 '&' substitution. */
9139 post_error (const char *msg
, Node_Id node
)
9141 String_Template temp
;
9144 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
9145 fp
.Array
= msg
, fp
.Bounds
= &temp
;
9147 Error_Msg_N (fp
, node
);
9150 /* Similar to post_error, but NODE is the node at which to post the error and
9151 ENT is the node to use for the '&' substitution. */
9154 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
9156 String_Template temp
;
9159 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
9160 fp
.Array
= msg
, fp
.Bounds
= &temp
;
9162 Error_Msg_NE (fp
, node
, ent
);
9165 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
9168 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int num
)
9170 Error_Msg_Uint_1
= UI_From_Int (num
);
9171 post_error_ne (msg
, node
, ent
);
9174 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
9175 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
9176 most sense. Return true if a sensible assignment was performed. */
9179 set_end_locus_from_node (tree gnu_node
, Node_Id gnat_node
)
9181 Node_Id gnat_end_label
= Empty
;
9182 location_t end_locus
;
9184 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
9185 end_locus when there is one. We consider only GNAT nodes with a possible
9186 End_Label attached. If the End_Label actually was unassigned, fallback
9187 on the orginal node. We'd better assign an explicit sloc associated with
9188 the outer construct in any case. */
9190 switch (Nkind (gnat_node
))
9192 case N_Package_Body
:
9193 case N_Subprogram_Body
:
9194 case N_Block_Statement
:
9195 gnat_end_label
= End_Label (Handled_Statement_Sequence (gnat_node
));
9198 case N_Package_Declaration
:
9199 gnat_end_label
= End_Label (Specification (gnat_node
));
9206 gnat_node
= Present (gnat_end_label
) ? gnat_end_label
: gnat_node
;
9208 /* Some expanded subprograms have neither an End_Label nor a Sloc
9209 attached. Notify that to callers. */
9211 if (!Sloc_to_locus (Sloc (gnat_node
), &end_locus
))
9214 switch (TREE_CODE (gnu_node
))
9217 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node
)) = end_locus
;
9221 DECL_STRUCT_FUNCTION (gnu_node
)->function_end_locus
= end_locus
;
9229 /* Similar to post_error_ne, but T is a GCC tree representing the number to
9230 write. If T represents a constant, the text inside curly brackets in
9231 MSG will be output (presumably including a '^'). Otherwise it will not
9232 be output and the text inside square brackets will be output instead. */
9235 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
9237 char *new_msg
= XALLOCAVEC (char, strlen (msg
) + 1);
9238 char start_yes
, end_yes
, start_no
, end_no
;
9242 if (TREE_CODE (t
) == INTEGER_CST
)
9244 Error_Msg_Uint_1
= UI_From_gnu (t
);
9245 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
9248 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
9250 for (p
= msg
, q
= new_msg
; *p
; p
++)
9252 if (*p
== start_yes
)
9253 for (p
++; *p
!= end_yes
; p
++)
9255 else if (*p
== start_no
)
9256 for (p
++; *p
!= end_no
; p
++)
9264 post_error_ne (new_msg
, node
, ent
);
9267 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
9270 post_error_ne_tree_2 (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
,
9273 Error_Msg_Uint_2
= UI_From_Int (num
);
9274 post_error_ne_tree (msg
, node
, ent
, t
);
9277 /* Initialize the table that maps GNAT codes to GCC codes for simple
9278 binary and unary operations. */
9281 init_code_table (void)
9283 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
9284 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
9286 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
9287 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
9288 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
9289 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
9290 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
9291 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
9292 gnu_codes
[N_Op_Le
] = LE_EXPR
;
9293 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
9294 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
9295 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
9296 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
9297 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
9298 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
9299 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
9300 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
9301 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
9302 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
9303 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
9304 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
9305 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
9306 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
9307 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
9310 /* Return a label to branch to for the exception type in KIND or NULL_TREE
9314 get_exception_label (char kind
)
9316 if (kind
== N_Raise_Constraint_Error
)
9317 return gnu_constraint_error_label_stack
->last ();
9318 else if (kind
== N_Raise_Storage_Error
)
9319 return gnu_storage_error_label_stack
->last ();
9320 else if (kind
== N_Raise_Program_Error
)
9321 return gnu_program_error_label_stack
->last ();
9326 /* Return the decl for the current elaboration procedure. */
9329 get_elaboration_procedure (void)
9331 return gnu_elab_proc_stack
->last ();
9334 #include "gt-ada-trans.h"