1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2011, 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"
41 #include "adadecode.h"
58 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
59 for fear of running out of stack space. If we need more, we use xmalloc
61 #define ALLOCA_THRESHOLD 1000
63 /* Let code below know whether we are targetting VMS without need of
64 intrusive preprocessor directives. */
65 #ifndef TARGET_ABI_OPEN_VMS
66 #define TARGET_ABI_OPEN_VMS 0
69 /* In configurations where blocks have no end_locus attached, just
70 sink assignments into a dummy global. */
71 #ifndef BLOCK_SOURCE_END_LOCATION
72 static location_t block_end_locus_sink
;
73 #define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink
76 /* For efficient float-to-int rounding, it is necessary to know whether
77 floating-point arithmetic may use wider intermediate results. When
78 FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
79 that arithmetic does not widen if double precision is emulated. */
80 #ifndef FP_ARITH_MAY_WIDEN
81 #if defined(HAVE_extendsfdf2)
82 #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
84 #define FP_ARITH_MAY_WIDEN 0
88 /* Pointers to front-end tables accessed through macros. */
89 struct Node
*Nodes_Ptr
;
90 Node_Id
*Next_Node_Ptr
;
91 Node_Id
*Prev_Node_Ptr
;
92 struct Elist_Header
*Elists_Ptr
;
93 struct Elmt_Item
*Elmts_Ptr
;
94 struct String_Entry
*Strings_Ptr
;
95 Char_Code
*String_Chars_Ptr
;
96 struct List_Header
*List_Headers_Ptr
;
98 /* Highest number in the front-end node table. */
101 /* Current node being treated, in case abort called. */
102 Node_Id error_gnat_node
;
104 /* True when gigi is being called on an analyzed but unexpanded
105 tree, and the only purpose of the call is to properly annotate
106 types with representation information. */
107 bool type_annotate_only
;
109 /* Current filename without path. */
110 const char *ref_filename
;
112 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
113 of unconstrained array IN parameters to avoid emitting a great deal of
114 redundant instructions to recompute them each time. */
115 struct GTY (()) parm_attr_d
{
116 int id
; /* GTY doesn't like Entity_Id. */
123 typedef struct parm_attr_d
*parm_attr
;
125 DEF_VEC_P(parm_attr
);
126 DEF_VEC_ALLOC_P(parm_attr
,gc
);
128 struct GTY(()) language_function
{
129 VEC(parm_attr
,gc
) *parm_attr_cache
;
130 bitmap named_ret_val
;
131 VEC(tree
,gc
) *other_ret_val
;
134 #define f_parm_attr_cache \
135 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
137 #define f_named_ret_val \
138 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
140 #define f_other_ret_val \
141 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
143 /* A structure used to gather together information about a statement group.
144 We use this to gather related statements, for example the "then" part
145 of a IF. In the case where it represents a lexical scope, we may also
146 have a BLOCK node corresponding to it and/or cleanups. */
148 struct GTY((chain_next ("%h.previous"))) stmt_group
{
149 struct stmt_group
*previous
; /* Previous code group. */
150 tree stmt_list
; /* List of statements for this code group. */
151 tree block
; /* BLOCK for this code group, if any. */
152 tree cleanups
; /* Cleanups for this code group, if any. */
155 static GTY(()) struct stmt_group
*current_stmt_group
;
157 /* List of unused struct stmt_group nodes. */
158 static GTY((deletable
)) struct stmt_group
*stmt_group_free_list
;
160 /* A structure used to record information on elaboration procedures
161 we've made and need to process.
163 ??? gnat_node should be Node_Id, but gengtype gets confused. */
165 struct GTY((chain_next ("%h.next"))) elab_info
{
166 struct elab_info
*next
; /* Pointer to next in chain. */
167 tree elab_proc
; /* Elaboration procedure. */
168 int gnat_node
; /* The N_Compilation_Unit. */
171 static GTY(()) struct elab_info
*elab_info_list
;
173 /* Stack of exception pointer variables. Each entry is the VAR_DECL
174 that stores the address of the raised exception. Nonzero means we
175 are in an exception handler. Not used in the zero-cost case. */
176 static GTY(()) VEC(tree
,gc
) *gnu_except_ptr_stack
;
178 /* In ZCX case, current exception pointer. Used to re-raise it. */
179 static GTY(()) tree gnu_incoming_exc_ptr
;
181 /* Stack for storing the current elaboration procedure decl. */
182 static GTY(()) VEC(tree
,gc
) *gnu_elab_proc_stack
;
184 /* Stack of labels to be used as a goto target instead of a return in
185 some functions. See processing for N_Subprogram_Body. */
186 static GTY(()) VEC(tree
,gc
) *gnu_return_label_stack
;
188 /* Stack of variable for the return value of a function with copy-in/copy-out
189 parameters. See processing for N_Subprogram_Body. */
190 static GTY(()) VEC(tree
,gc
) *gnu_return_var_stack
;
192 /* Structure used to record information for a range check. */
193 struct GTY(()) range_check_info_d
{
200 typedef struct range_check_info_d
*range_check_info
;
202 DEF_VEC_P(range_check_info
);
203 DEF_VEC_ALLOC_P(range_check_info
,gc
);
205 /* Structure used to record information for a loop. */
206 struct GTY(()) loop_info_d
{
209 VEC(range_check_info
,gc
) *checks
;
212 typedef struct loop_info_d
*loop_info
;
214 DEF_VEC_P(loop_info
);
215 DEF_VEC_ALLOC_P(loop_info
,gc
);
217 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
218 static GTY(()) VEC(loop_info
,gc
) *gnu_loop_stack
;
220 /* The stacks for N_{Push,Pop}_*_Label. */
221 static GTY(()) VEC(tree
,gc
) *gnu_constraint_error_label_stack
;
222 static GTY(()) VEC(tree
,gc
) *gnu_storage_error_label_stack
;
223 static GTY(()) VEC(tree
,gc
) *gnu_program_error_label_stack
;
225 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
226 static enum tree_code gnu_codes
[Number_Node_Kinds
];
228 static void init_code_table (void);
229 static void Compilation_Unit_to_gnu (Node_Id
);
230 static void record_code_position (Node_Id
);
231 static void insert_code_for (Node_Id
);
232 static void add_cleanup (tree
, Node_Id
);
233 static void add_stmt_list (List_Id
);
234 static void push_exception_label_stack (VEC(tree
,gc
) **, Entity_Id
);
235 static tree
build_stmt_group (List_Id
, bool);
236 static enum gimplify_status
gnat_gimplify_stmt (tree
*);
237 static void elaborate_all_entities (Node_Id
);
238 static void process_freeze_entity (Node_Id
);
239 static void process_decls (List_Id
, List_Id
, Node_Id
, bool, bool);
240 static tree
emit_range_check (tree
, Node_Id
, Node_Id
);
241 static tree
emit_index_check (tree
, tree
, tree
, tree
, Node_Id
);
242 static tree
emit_check (tree
, tree
, int, Node_Id
);
243 static tree
build_unary_op_trapv (enum tree_code
, tree
, tree
, Node_Id
);
244 static tree
build_binary_op_trapv (enum tree_code
, tree
, tree
, tree
, Node_Id
);
245 static tree
convert_with_check (Entity_Id
, tree
, bool, bool, bool, Node_Id
);
246 static bool addressable_p (tree
, tree
);
247 static tree
assoc_to_constructor (Entity_Id
, Node_Id
, tree
);
248 static tree
extract_values (tree
, tree
);
249 static tree
pos_to_constructor (Node_Id
, tree
, Entity_Id
);
250 static tree
maybe_implicit_deref (tree
);
251 static void set_expr_location_from_node (tree
, Node_Id
);
252 static bool set_end_locus_from_node (tree
, Node_Id
);
253 static void set_gnu_expr_location_from_node (tree
, Node_Id
);
254 static int lvalue_required_p (Node_Id
, tree
, bool, bool, bool);
255 static tree
build_raise_check (int, enum exception_info_kind
);
256 static tree
create_init_temporary (const char *, tree
, tree
*, Node_Id
);
258 /* Hooks for debug info back-ends, only supported and used in a restricted set
259 of configurations. */
260 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED
;
261 static const char *decode_name (const char *) ATTRIBUTE_UNUSED
;
263 /* This is the main program of the back-end. It sets up all the table
264 structures and then generates code. */
267 gigi (Node_Id gnat_root
, int max_gnat_node
, int number_name ATTRIBUTE_UNUSED
,
268 struct Node
*nodes_ptr
, Node_Id
*next_node_ptr
, Node_Id
*prev_node_ptr
,
269 struct Elist_Header
*elists_ptr
, struct Elmt_Item
*elmts_ptr
,
270 struct String_Entry
*strings_ptr
, Char_Code
*string_chars_ptr
,
271 struct List_Header
*list_headers_ptr
, Nat number_file
,
272 struct File_Info_Type
*file_info_ptr
,
273 Entity_Id standard_boolean
, Entity_Id standard_integer
,
274 Entity_Id standard_character
, Entity_Id standard_long_long_float
,
275 Entity_Id standard_exception_type
, Int gigi_operating_mode
)
277 Entity_Id gnat_literal
;
278 tree long_long_float_type
, exception_type
, t
, ftype
;
279 tree int64_type
= gnat_type_for_size (64, 0);
280 struct elab_info
*info
;
283 max_gnat_nodes
= max_gnat_node
;
285 Nodes_Ptr
= nodes_ptr
;
286 Next_Node_Ptr
= next_node_ptr
;
287 Prev_Node_Ptr
= prev_node_ptr
;
288 Elists_Ptr
= elists_ptr
;
289 Elmts_Ptr
= elmts_ptr
;
290 Strings_Ptr
= strings_ptr
;
291 String_Chars_Ptr
= string_chars_ptr
;
292 List_Headers_Ptr
= list_headers_ptr
;
294 type_annotate_only
= (gigi_operating_mode
== 1);
296 gcc_assert (Nkind (gnat_root
) == N_Compilation_Unit
);
298 /* Declare the name of the compilation unit as the first global
299 name in order to make the middle-end fully deterministic. */
300 t
= create_concat_name (Defining_Entity (Unit (gnat_root
)), NULL
);
301 first_global_object_name
= ggc_strdup (IDENTIFIER_POINTER (t
));
303 for (i
= 0; i
< number_file
; i
++)
305 /* Use the identifier table to make a permanent copy of the filename as
306 the name table gets reallocated after Gigi returns but before all the
307 debugging information is output. The __gnat_to_canonical_file_spec
308 call translates filenames from pragmas Source_Reference that contain
309 host style syntax not understood by gdb. */
313 (__gnat_to_canonical_file_spec
314 (Get_Name_String (file_info_ptr
[i
].File_Name
))));
316 /* We rely on the order isomorphism between files and line maps. */
317 gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table
) == i
);
319 /* We create the line map for a source file at once, with a fixed number
320 of columns chosen to avoid jumping over the next power of 2. */
321 linemap_add (line_table
, LC_ENTER
, 0, filename
, 1);
322 linemap_line_start (line_table
, file_info_ptr
[i
].Num_Source_Lines
, 252);
323 linemap_position_for_column (line_table
, 252 - 1);
324 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
327 /* Initialize ourselves. */
332 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
334 if (type_annotate_only
)
336 TYPE_SIZE (void_type_node
) = bitsize_zero_node
;
337 TYPE_SIZE_UNIT (void_type_node
) = size_zero_node
;
340 /* Enable GNAT stack checking method if needed */
341 if (!Stack_Check_Probes_On_Target
)
342 set_stack_check_libfunc ("_gnat_stack_check");
344 /* Retrieve alignment settings. */
345 double_float_alignment
= get_target_double_float_alignment ();
346 double_scalar_alignment
= get_target_double_scalar_alignment ();
348 /* Record the builtin types. Define `integer' and `character' first so that
349 dbx will output them first. */
350 record_builtin_type ("integer", integer_type_node
, false);
351 record_builtin_type ("character", unsigned_char_type_node
, false);
352 record_builtin_type ("boolean", boolean_type_node
, false);
353 record_builtin_type ("void", void_type_node
, false);
355 /* Save the type we made for integer as the type for Standard.Integer. */
356 save_gnu_tree (Base_Type (standard_integer
),
357 TYPE_NAME (integer_type_node
),
360 /* Likewise for character as the type for Standard.Character. */
361 save_gnu_tree (Base_Type (standard_character
),
362 TYPE_NAME (unsigned_char_type_node
),
365 /* Likewise for boolean as the type for Standard.Boolean. */
366 save_gnu_tree (Base_Type (standard_boolean
),
367 TYPE_NAME (boolean_type_node
),
369 gnat_literal
= First_Literal (Base_Type (standard_boolean
));
370 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
371 gcc_assert (t
== boolean_false_node
);
372 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
373 boolean_type_node
, t
, true, false, false, false,
375 DECL_IGNORED_P (t
) = 1;
376 save_gnu_tree (gnat_literal
, t
, false);
377 gnat_literal
= Next_Literal (gnat_literal
);
378 t
= UI_To_gnu (Enumeration_Rep (gnat_literal
), boolean_type_node
);
379 gcc_assert (t
== boolean_true_node
);
380 t
= create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
381 boolean_type_node
, t
, true, false, false, false,
383 DECL_IGNORED_P (t
) = 1;
384 save_gnu_tree (gnat_literal
, t
, false);
386 void_ftype
= build_function_type_list (void_type_node
, NULL_TREE
);
387 ptr_void_ftype
= build_pointer_type (void_ftype
);
389 /* Now declare run-time functions. */
390 ftype
= build_function_type_list (ptr_void_type_node
, sizetype
, NULL_TREE
);
392 /* malloc is a function declaration tree for a function to allocate
395 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE
,
396 ftype
, NULL_TREE
, false, true, true, true, NULL
,
398 DECL_IS_MALLOC (malloc_decl
) = 1;
400 /* malloc32 is a function declaration tree for a function to allocate
401 32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */
403 = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE
,
404 ftype
, NULL_TREE
, false, true, true, true, NULL
,
406 DECL_IS_MALLOC (malloc32_decl
) = 1;
408 /* free is a function declaration tree for a function to free memory. */
410 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
411 build_function_type_list (void_type_node
,
414 NULL_TREE
, false, true, true, true, NULL
, Empty
);
416 /* This is used for 64-bit multiplication with overflow checking. */
418 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE
,
419 build_function_type_list (int64_type
, int64_type
,
420 int64_type
, NULL_TREE
),
421 NULL_TREE
, false, true, true, true, NULL
, Empty
);
423 /* Name of the _Parent field in tagged record types. */
424 parent_name_id
= get_identifier (Get_Name_String (Name_uParent
));
426 /* Name of the Exception_Data type defined in System.Standard_Library. */
427 exception_data_name_id
428 = get_identifier ("system__standard_library__exception_data");
430 /* Make the types and functions used for exception processing. */
432 = build_array_type (gnat_type_for_mode (Pmode
, 0),
433 build_index_type (size_int (5)));
434 record_builtin_type ("JMPBUF_T", jmpbuf_type
, true);
435 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
437 /* Functions to get and set the jumpbuf pointer for the current thread. */
439 = create_subprog_decl
440 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
441 NULL_TREE
, build_function_type_list (jmpbuf_ptr_type
, NULL_TREE
),
442 NULL_TREE
, false, true, true, true, NULL
, Empty
);
443 DECL_IGNORED_P (get_jmpbuf_decl
) = 1;
446 = create_subprog_decl
447 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
448 NULL_TREE
, build_function_type_list (void_type_node
, jmpbuf_ptr_type
,
450 NULL_TREE
, false, true, true, true, NULL
, Empty
);
451 DECL_IGNORED_P (set_jmpbuf_decl
) = 1;
453 /* setjmp returns an integer and has one operand, which is a pointer to
456 = create_subprog_decl
457 (get_identifier ("__builtin_setjmp"), NULL_TREE
,
458 build_function_type_list (integer_type_node
, jmpbuf_ptr_type
,
460 NULL_TREE
, false, true, true, true, NULL
, Empty
);
461 DECL_BUILT_IN_CLASS (setjmp_decl
) = BUILT_IN_NORMAL
;
462 DECL_FUNCTION_CODE (setjmp_decl
) = BUILT_IN_SETJMP
;
464 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
466 update_setjmp_buf_decl
467 = create_subprog_decl
468 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE
,
469 build_function_type_list (void_type_node
, jmpbuf_ptr_type
, NULL_TREE
),
470 NULL_TREE
, false, true, true, true, NULL
, Empty
);
471 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl
) = BUILT_IN_NORMAL
;
472 DECL_FUNCTION_CODE (update_setjmp_buf_decl
) = BUILT_IN_UPDATE_SETJMP_BUF
;
474 /* Hooks to call when entering/leaving an exception handler. */
476 = build_function_type_list (void_type_node
, ptr_void_type_node
, NULL_TREE
);
479 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE
,
480 ftype
, NULL_TREE
, false, true, true, true, NULL
,
482 DECL_IGNORED_P (begin_handler_decl
) = 1;
485 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE
,
486 ftype
, NULL_TREE
, false, true, true, true, NULL
,
488 DECL_IGNORED_P (end_handler_decl
) = 1;
491 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE
,
492 ftype
, NULL_TREE
, false, true, true, true, NULL
,
494 DECL_IGNORED_P (reraise_zcx_decl
) = 1;
496 /* If in no exception handlers mode, all raise statements are redirected to
497 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
498 this procedure will never be called in this mode. */
499 if (No_Exception_Handlers_Set ())
502 = create_subprog_decl
503 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
,
504 build_function_type_list (void_type_node
,
506 (unsigned_char_type_node
),
507 integer_type_node
, NULL_TREE
),
508 NULL_TREE
, false, true, true, true, NULL
, Empty
);
509 TREE_THIS_VOLATILE (decl
) = 1;
510 TREE_SIDE_EFFECTS (decl
) = 1;
512 = build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
513 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
514 gnat_raise_decls
[i
] = decl
;
518 /* Otherwise, make one decl for each exception reason. */
519 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls
); i
++)
520 gnat_raise_decls
[i
] = build_raise_check (i
, exception_simple
);
521 for (i
= 0; i
< (int) ARRAY_SIZE (gnat_raise_decls_ext
); i
++)
522 gnat_raise_decls_ext
[i
]
523 = build_raise_check (i
,
524 i
== CE_Index_Check_Failed
525 || i
== CE_Range_Check_Failed
526 || i
== CE_Invalid_Data
527 ? exception_range
: exception_column
);
530 /* Set the types that GCC and Gigi use from the front end. */
532 = gnat_to_gnu_entity (Base_Type (standard_exception_type
), NULL_TREE
, 0);
533 except_type_node
= TREE_TYPE (exception_type
);
535 /* Make other functions used for exception processing. */
537 = create_subprog_decl
538 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE
,
539 build_function_type_list (build_pointer_type (except_type_node
),
541 NULL_TREE
, false, true, true, true, NULL
, Empty
);
544 = create_subprog_decl
545 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
,
546 build_function_type_list (void_type_node
,
547 build_pointer_type (except_type_node
),
549 NULL_TREE
, false, true, true, true, NULL
, Empty
);
551 /* Indicate that it never returns. */
552 TREE_THIS_VOLATILE (raise_nodefer_decl
) = 1;
553 TREE_SIDE_EFFECTS (raise_nodefer_decl
) = 1;
554 TREE_TYPE (raise_nodefer_decl
)
555 = build_qualified_type (TREE_TYPE (raise_nodefer_decl
),
558 /* Build the special descriptor type and its null node if needed. */
559 if (TARGET_VTABLE_USES_DESCRIPTORS
)
561 tree null_node
= fold_convert (ptr_void_ftype
, null_pointer_node
);
562 tree field_list
= NULL_TREE
;
564 VEC(constructor_elt
,gc
) *null_vec
= NULL
;
565 constructor_elt
*elt
;
567 fdesc_type_node
= make_node (RECORD_TYPE
);
568 VEC_safe_grow (constructor_elt
, gc
, null_vec
,
569 TARGET_VTABLE_USES_DESCRIPTORS
);
570 elt
= (VEC_address (constructor_elt
,null_vec
)
571 + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
573 for (j
= 0; j
< TARGET_VTABLE_USES_DESCRIPTORS
; j
++)
576 = create_field_decl (NULL_TREE
, ptr_void_ftype
, fdesc_type_node
,
577 NULL_TREE
, NULL_TREE
, 0, 1);
578 DECL_CHAIN (field
) = field_list
;
581 elt
->value
= null_node
;
585 finish_record_type (fdesc_type_node
, nreverse (field_list
), 0, false);
586 record_builtin_type ("descriptor", fdesc_type_node
, true);
587 null_fdesc_node
= gnat_build_constructor (fdesc_type_node
, null_vec
);
591 = gnat_to_gnu_entity (Base_Type (standard_long_long_float
), NULL_TREE
, 0);
593 if (TREE_CODE (TREE_TYPE (long_long_float_type
)) == INTEGER_TYPE
)
595 /* In this case, the builtin floating point types are VAX float,
596 so make up a type for use. */
597 longest_float_type_node
= make_node (REAL_TYPE
);
598 TYPE_PRECISION (longest_float_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
599 layout_type (longest_float_type_node
);
600 record_builtin_type ("longest float type", longest_float_type_node
,
604 longest_float_type_node
= TREE_TYPE (long_long_float_type
);
606 /* Dummy objects to materialize "others" and "all others" in the exception
607 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
610 = create_var_decl (get_identifier ("OTHERS"),
611 get_identifier ("__gnat_others_value"),
612 integer_type_node
, NULL_TREE
, true, false, true, false,
616 = create_var_decl (get_identifier ("ALL_OTHERS"),
617 get_identifier ("__gnat_all_others_value"),
618 integer_type_node
, NULL_TREE
, true, false, true, false,
621 main_identifier_node
= get_identifier ("main");
623 /* Install the builtins we might need, either internally or as
624 user available facilities for Intrinsic imports. */
625 gnat_install_builtins ();
627 VEC_safe_push (tree
, gc
, gnu_except_ptr_stack
, NULL_TREE
);
628 VEC_safe_push (tree
, gc
, gnu_constraint_error_label_stack
, NULL_TREE
);
629 VEC_safe_push (tree
, gc
, gnu_storage_error_label_stack
, NULL_TREE
);
630 VEC_safe_push (tree
, gc
, gnu_program_error_label_stack
, NULL_TREE
);
632 /* Process any Pragma Ident for the main unit. */
633 #ifdef ASM_OUTPUT_IDENT
634 if (Present (Ident_String (Main_Unit
)))
637 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
640 /* If we are using the GCC exception mechanism, let GCC know. */
641 if (Exception_Mechanism
== Back_End_Exceptions
)
644 /* Now translate the compilation unit proper. */
645 Compilation_Unit_to_gnu (gnat_root
);
647 /* Finally see if we have any elaboration procedures to deal with. */
648 for (info
= elab_info_list
; info
; info
= info
->next
)
650 tree gnu_body
= DECL_SAVED_TREE (info
->elab_proc
), gnu_stmts
;
652 /* We should have a BIND_EXPR but it may not have any statements in it.
653 If it doesn't have any, we have nothing to do except for setting the
654 flag on the GNAT node. Otherwise, process the function as others. */
655 gnu_stmts
= gnu_body
;
656 if (TREE_CODE (gnu_stmts
) == BIND_EXPR
)
657 gnu_stmts
= BIND_EXPR_BODY (gnu_stmts
);
658 if (!gnu_stmts
|| !STATEMENT_LIST_HEAD (gnu_stmts
))
659 Set_Has_No_Elaboration_Code (info
->gnat_node
, 1);
662 begin_subprog_body (info
->elab_proc
);
663 end_subprog_body (gnu_body
);
664 rest_of_subprog_body_compilation (info
->elab_proc
);
668 /* We cannot track the location of errors past this point. */
669 error_gnat_node
= Empty
;
672 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
673 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
676 build_raise_check (int check
, enum exception_info_kind kind
)
681 if (kind
== exception_simple
)
683 sprintf (name
, "__gnat_rcheck_%.2d", check
);
685 = build_function_type_list (void_type_node
,
687 (unsigned_char_type_node
),
688 integer_type_node
, NULL_TREE
);
692 tree t
= (kind
== exception_column
? NULL_TREE
: integer_type_node
);
693 sprintf (name
, "__gnat_rcheck_%.2d_ext", check
);
695 = build_function_type_list (void_type_node
,
697 (unsigned_char_type_node
),
698 integer_type_node
, integer_type_node
,
703 = create_subprog_decl (get_identifier (name
), NULL_TREE
, ftype
, NULL_TREE
,
704 false, true, true, true, NULL
, Empty
);
706 /* Indicate that it never returns. */
707 TREE_THIS_VOLATILE (result
) = 1;
708 TREE_SIDE_EFFECTS (result
) = 1;
710 = build_qualified_type (TREE_TYPE (result
), TYPE_QUAL_VOLATILE
);
715 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
716 an N_Attribute_Reference. */
719 lvalue_required_for_attribute_p (Node_Id gnat_node
)
721 switch (Get_Attribute_Id (Attribute_Name (gnat_node
)))
729 case Attr_Range_Length
:
731 case Attr_Object_Size
:
732 case Attr_Value_Size
:
733 case Attr_Component_Size
:
734 case Attr_Max_Size_In_Storage_Elements
:
737 case Attr_Null_Parameter
:
738 case Attr_Passed_By_Reference
:
739 case Attr_Mechanism_Code
:
744 case Attr_Unchecked_Access
:
745 case Attr_Unrestricted_Access
:
746 case Attr_Code_Address
:
747 case Attr_Pool_Address
:
750 case Attr_Bit_Position
:
756 case Attr_Asm_Output
:
762 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
763 is the type that will be used for GNAT_NODE in the translated GNU tree.
764 CONSTANT indicates whether the underlying object represented by GNAT_NODE
765 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
766 whether its value is the address of a constant and ALIASED whether it is
767 aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
769 The function climbs up the GNAT tree starting from the node and returns 1
770 upon encountering a node that effectively requires an lvalue downstream.
771 It returns int instead of bool to facilitate usage in non-purely binary
775 lvalue_required_p (Node_Id gnat_node
, tree gnu_type
, bool constant
,
776 bool address_of_constant
, bool aliased
)
778 Node_Id gnat_parent
= Parent (gnat_node
), gnat_temp
;
780 switch (Nkind (gnat_parent
))
785 case N_Attribute_Reference
:
786 return lvalue_required_for_attribute_p (gnat_parent
);
788 case N_Parameter_Association
:
789 case N_Function_Call
:
790 case N_Procedure_Call_Statement
:
791 /* If the parameter is by reference, an lvalue is required. */
793 || must_pass_by_ref (gnu_type
)
794 || default_pass_by_ref (gnu_type
));
796 case N_Indexed_Component
:
797 /* Only the array expression can require an lvalue. */
798 if (Prefix (gnat_parent
) != gnat_node
)
801 /* ??? Consider that referencing an indexed component with a
802 non-constant index forces the whole aggregate to memory.
803 Note that N_Integer_Literal is conservative, any static
804 expression in the RM sense could probably be accepted. */
805 for (gnat_temp
= First (Expressions (gnat_parent
));
807 gnat_temp
= Next (gnat_temp
))
808 if (Nkind (gnat_temp
) != N_Integer_Literal
)
811 /* ... fall through ... */
814 /* Only the array expression can require an lvalue. */
815 if (Prefix (gnat_parent
) != gnat_node
)
818 aliased
|= Has_Aliased_Components (Etype (gnat_node
));
819 return lvalue_required_p (gnat_parent
, gnu_type
, constant
,
820 address_of_constant
, aliased
);
822 case N_Selected_Component
:
823 aliased
|= Is_Aliased (Entity (Selector_Name (gnat_parent
)));
824 return lvalue_required_p (gnat_parent
, gnu_type
, constant
,
825 address_of_constant
, aliased
);
827 case N_Object_Renaming_Declaration
:
828 /* We need to make a real renaming only if the constant object is
829 aliased or if we may use a renaming pointer; otherwise we can
830 optimize and return the rvalue. We make an exception if the object
831 is an identifier since in this case the rvalue can be propagated
832 attached to the CONST_DECL. */
835 /* This should match the constant case of the renaming code. */
837 (Underlying_Type (Etype (Name (gnat_parent
))))
838 || Nkind (Name (gnat_parent
)) == N_Identifier
);
840 case N_Object_Declaration
:
841 /* We cannot use a constructor if this is an atomic object because
842 the actual assignment might end up being done component-wise. */
844 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
845 && Is_Atomic (Defining_Entity (gnat_parent
)))
846 /* We don't use a constructor if this is a class-wide object
847 because the effective type of the object is the equivalent
848 type of the class-wide subtype and it smashes most of the
849 data into an array of bytes to which we cannot convert. */
850 || Ekind ((Etype (Defining_Entity (gnat_parent
))))
851 == E_Class_Wide_Subtype
);
853 case N_Assignment_Statement
:
854 /* We cannot use a constructor if the LHS is an atomic object because
855 the actual assignment might end up being done component-wise. */
857 || Name (gnat_parent
) == gnat_node
858 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node
)))
859 && Is_Atomic (Entity (Name (gnat_parent
)))));
861 case N_Unchecked_Type_Conversion
:
865 /* ... fall through ... */
867 case N_Type_Conversion
:
868 case N_Qualified_Expression
:
869 /* We must look through all conversions because we may need to bypass
870 an intermediate conversion that is meant to be purely formal. */
871 return lvalue_required_p (gnat_parent
,
872 get_unpadded_type (Etype (gnat_parent
)),
873 constant
, address_of_constant
, aliased
);
876 /* We should only reach here through the N_Qualified_Expression case.
877 Force an lvalue for composite types since a block-copy to the newly
878 allocated area of memory is made. */
879 return Is_Composite_Type (Underlying_Type (Etype (gnat_node
)));
881 case N_Explicit_Dereference
:
882 /* We look through dereferences for address of constant because we need
883 to handle the special cases listed above. */
884 if (constant
&& address_of_constant
)
885 return lvalue_required_p (gnat_parent
,
886 get_unpadded_type (Etype (gnat_parent
)),
889 /* ... fall through ... */
898 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
899 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
900 to where we should place the result type. */
903 Identifier_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
905 Node_Id gnat_temp
, gnat_temp_type
;
906 tree gnu_result
, gnu_result_type
;
908 /* Whether we should require an lvalue for GNAT_NODE. Needed in
909 specific circumstances only, so evaluated lazily. < 0 means
910 unknown, > 0 means known true, 0 means known false. */
911 int require_lvalue
= -1;
913 /* If GNAT_NODE is a constant, whether we should use the initialization
914 value instead of the constant entity, typically for scalars with an
915 address clause when the parent doesn't require an lvalue. */
916 bool use_constant_initializer
= false;
918 /* If the Etype of this node does not equal the Etype of the Entity,
919 something is wrong with the entity map, probably in generic
920 instantiation. However, this does not apply to types. Since we sometime
921 have strange Ekind's, just do this test for objects. Also, if the Etype of
922 the Entity is private, the Etype of the N_Identifier is allowed to be the
923 full type and also we consider a packed array type to be the same as the
924 original type. Similarly, a class-wide type is equivalent to a subtype of
925 itself. Finally, if the types are Itypes, one may be a copy of the other,
926 which is also legal. */
927 gnat_temp
= (Nkind (gnat_node
) == N_Defining_Identifier
928 ? gnat_node
: Entity (gnat_node
));
929 gnat_temp_type
= Etype (gnat_temp
);
931 gcc_assert (Etype (gnat_node
) == gnat_temp_type
932 || (Is_Packed (gnat_temp_type
)
933 && Etype (gnat_node
) == Packed_Array_Type (gnat_temp_type
))
934 || (Is_Class_Wide_Type (Etype (gnat_node
)))
935 || (IN (Ekind (gnat_temp_type
), Private_Kind
)
936 && Present (Full_View (gnat_temp_type
))
937 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
938 || (Is_Packed (Full_View (gnat_temp_type
))
939 && (Etype (gnat_node
)
940 == Packed_Array_Type (Full_View
941 (gnat_temp_type
))))))
942 || (Is_Itype (Etype (gnat_node
)) && Is_Itype (gnat_temp_type
))
943 || !(Ekind (gnat_temp
) == E_Variable
944 || Ekind (gnat_temp
) == E_Component
945 || Ekind (gnat_temp
) == E_Constant
946 || Ekind (gnat_temp
) == E_Loop_Parameter
947 || IN (Ekind (gnat_temp
), Formal_Kind
)));
949 /* If this is a reference to a deferred constant whose partial view is an
950 unconstrained private type, the proper type is on the full view of the
951 constant, not on the full view of the type, which may be unconstrained.
953 This may be a reference to a type, for example in the prefix of the
954 attribute Position, generated for dispatching code (see Make_DT in
955 exp_disp,adb). In that case we need the type itself, not is parent,
956 in particular if it is a derived type */
957 if (Ekind (gnat_temp
) == E_Constant
958 && Is_Private_Type (gnat_temp_type
)
959 && (Has_Unknown_Discriminants (gnat_temp_type
)
960 || (Present (Full_View (gnat_temp_type
))
961 && Has_Discriminants (Full_View (gnat_temp_type
))))
962 && Present (Full_View (gnat_temp
)))
964 gnat_temp
= Full_View (gnat_temp
);
965 gnat_temp_type
= Etype (gnat_temp
);
969 /* We want to use the Actual_Subtype if it has already been elaborated,
970 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
972 if ((Ekind (gnat_temp
) == E_Constant
973 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
974 && !(Is_Array_Type (Etype (gnat_temp
))
975 && Present (Packed_Array_Type (Etype (gnat_temp
))))
976 && Present (Actual_Subtype (gnat_temp
))
977 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
978 gnat_temp_type
= Actual_Subtype (gnat_temp
);
980 gnat_temp_type
= Etype (gnat_node
);
983 /* Expand the type of this identifier first, in case it is an enumeral
984 literal, which only get made when the type is expanded. There is no
985 order-of-elaboration issue here. */
986 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
988 /* If this is a non-imported scalar constant with an address clause,
989 retrieve the value instead of a pointer to be dereferenced unless
990 an lvalue is required. This is generally more efficient and actually
991 required if this is a static expression because it might be used
992 in a context where a dereference is inappropriate, such as a case
993 statement alternative or a record discriminant. There is no possible
994 volatile-ness short-circuit here since Volatile constants must be
996 if (Ekind (gnat_temp
) == E_Constant
997 && Is_Scalar_Type (gnat_temp_type
)
998 && !Is_Imported (gnat_temp
)
999 && Present (Address_Clause (gnat_temp
)))
1001 require_lvalue
= lvalue_required_p (gnat_node
, gnu_result_type
, true,
1002 false, Is_Aliased (gnat_temp
));
1003 use_constant_initializer
= !require_lvalue
;
1006 if (use_constant_initializer
)
1008 /* If this is a deferred constant, the initializer is attached to
1010 if (Present (Full_View (gnat_temp
)))
1011 gnat_temp
= Full_View (gnat_temp
);
1013 gnu_result
= gnat_to_gnu (Expression (Declaration_Node (gnat_temp
)));
1016 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0);
1018 /* Some objects (such as parameters passed by reference, globals of
1019 variable size, and renamed objects) actually represent the address
1020 of the object. In that case, we must do the dereference. Likewise,
1021 deal with parameters to foreign convention subprograms. */
1022 if (DECL_P (gnu_result
)
1023 && (DECL_BY_REF_P (gnu_result
)
1024 || (TREE_CODE (gnu_result
) == PARM_DECL
1025 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
1027 const bool read_only
= DECL_POINTS_TO_READONLY_P (gnu_result
);
1029 /* First do the first dereference if needed. */
1030 if (TREE_CODE (gnu_result
) == PARM_DECL
1031 && DECL_BY_DOUBLE_REF_P (gnu_result
))
1033 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
1034 if (TREE_CODE (gnu_result
) == INDIRECT_REF
)
1035 TREE_THIS_NOTRAP (gnu_result
) = 1;
1038 TREE_READONLY (gnu_result
) = 1;
1041 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1042 if (TREE_CODE (gnu_result
) == PARM_DECL
1043 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
1045 = convert (build_pointer_type (gnu_result_type
), gnu_result
);
1047 /* If it's a CONST_DECL, return the underlying constant like below. */
1048 else if (TREE_CODE (gnu_result
) == CONST_DECL
)
1049 gnu_result
= DECL_INITIAL (gnu_result
);
1051 /* If it's a renaming pointer and we are at the right binding level,
1052 we can reference the renamed object directly, since the renamed
1053 expression has been protected against multiple evaluations. */
1054 if (TREE_CODE (gnu_result
) == VAR_DECL
1055 && !DECL_LOOP_PARM_P (gnu_result
)
1056 && DECL_RENAMED_OBJECT (gnu_result
)
1057 && (!DECL_RENAMING_GLOBAL_P (gnu_result
) || global_bindings_p ()))
1058 gnu_result
= DECL_RENAMED_OBJECT (gnu_result
);
1060 /* Otherwise, do the final dereference. */
1063 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
1065 if ((TREE_CODE (gnu_result
) == INDIRECT_REF
1066 || TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
1067 && No (Address_Clause (gnat_temp
)))
1068 TREE_THIS_NOTRAP (gnu_result
) = 1;
1071 TREE_READONLY (gnu_result
) = 1;
1075 /* The GNAT tree has the type of a function as the type of its result. Also
1076 use the type of the result if the Etype is a subtype which is nominally
1077 unconstrained. But remove any padding from the resulting type. */
1078 if (TREE_CODE (TREE_TYPE (gnu_result
)) == FUNCTION_TYPE
1079 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
))
1081 gnu_result_type
= TREE_TYPE (gnu_result
);
1082 if (TYPE_IS_PADDING_P (gnu_result_type
))
1083 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
1086 /* If we have a constant declaration and its initializer, try to return the
1087 latter to avoid the need to call fold in lots of places and the need for
1088 elaboration code if this identifier is used as an initializer itself.
1089 Don't do it for aggregate types that contain a placeholder since their
1090 initializers cannot be manipulated easily. */
1091 if (TREE_CONSTANT (gnu_result
)
1092 && DECL_P (gnu_result
)
1093 && DECL_INITIAL (gnu_result
)
1094 && !(AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))
1095 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_result
))
1096 && type_contains_placeholder_p (TREE_TYPE (gnu_result
))))
1098 bool constant_only
= (TREE_CODE (gnu_result
) == CONST_DECL
1099 && !DECL_CONST_CORRESPONDING_VAR (gnu_result
));
1100 bool address_of_constant
= (TREE_CODE (gnu_result
) == CONST_DECL
1101 && DECL_CONST_ADDRESS_P (gnu_result
));
1103 /* If there is a (corresponding) variable or this is the address of a
1104 constant, we only want to return the initializer if an lvalue isn't
1105 required. Evaluate this now if we have not already done so. */
1106 if ((!constant_only
|| address_of_constant
) && require_lvalue
< 0)
1108 = lvalue_required_p (gnat_node
, gnu_result_type
, true,
1109 address_of_constant
, Is_Aliased (gnat_temp
));
1111 /* ??? We need to unshare the initializer if the object is external
1112 as such objects are not marked for unsharing if we are not at the
1113 global level. This should be fixed in add_decl_expr. */
1114 if ((constant_only
&& !address_of_constant
) || !require_lvalue
)
1115 gnu_result
= unshare_expr (DECL_INITIAL (gnu_result
));
1118 *gnu_result_type_p
= gnu_result_type
;
1123 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1124 any statements we generate. */
1127 Pragma_to_gnu (Node_Id gnat_node
)
1130 tree gnu_result
= alloc_stmt_list ();
1132 /* Check for (and ignore) unrecognized pragma and do nothing if we are just
1133 annotating types. */
1134 if (type_annotate_only
1135 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node
))))
1138 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
))))
1140 case Pragma_Inspection_Point
:
1141 /* Do nothing at top level: all such variables are already viewable. */
1142 if (global_bindings_p ())
1145 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
1146 Present (gnat_temp
);
1147 gnat_temp
= Next (gnat_temp
))
1149 Node_Id gnat_expr
= Expression (gnat_temp
);
1150 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
1152 enum machine_mode mode
;
1153 tree asm_constraint
= NULL_TREE
;
1154 #ifdef ASM_COMMENT_START
1158 if (TREE_CODE (gnu_expr
) == UNCONSTRAINED_ARRAY_REF
)
1159 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1161 /* Use the value only if it fits into a normal register,
1162 otherwise use the address. */
1163 mode
= TYPE_MODE (TREE_TYPE (gnu_expr
));
1164 use_address
= ((GET_MODE_CLASS (mode
) != MODE_INT
1165 && GET_MODE_CLASS (mode
) != MODE_PARTIAL_INT
)
1166 || GET_MODE_SIZE (mode
) > UNITS_PER_WORD
);
1169 gnu_expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
1171 #ifdef ASM_COMMENT_START
1172 comment
= concat (ASM_COMMENT_START
,
1173 " inspection point: ",
1174 Get_Name_String (Chars (gnat_expr
)),
1175 use_address
? " address" : "",
1178 asm_constraint
= build_string (strlen (comment
), comment
);
1181 gnu_expr
= build5 (ASM_EXPR
, void_type_node
,
1185 (build_tree_list (NULL_TREE
,
1186 build_string (1, "g")),
1187 gnu_expr
, NULL_TREE
),
1188 NULL_TREE
, NULL_TREE
);
1189 ASM_VOLATILE_P (gnu_expr
) = 1;
1190 set_expr_location_from_node (gnu_expr
, gnat_node
);
1191 append_to_statement_list (gnu_expr
, &gnu_result
);
1195 case Pragma_Optimize
:
1196 switch (Chars (Expression
1197 (First (Pragma_Argument_Associations (gnat_node
)))))
1199 case Name_Time
: case Name_Space
:
1201 post_error ("insufficient -O value?", gnat_node
);
1206 post_error ("must specify -O0?", gnat_node
);
1214 case Pragma_Reviewable
:
1215 if (write_symbols
== NO_DEBUG
)
1216 post_error ("must specify -g?", gnat_node
);
1223 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1224 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1225 where we should place the result type. ATTRIBUTE is the attribute ID. */
1228 Attribute_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, int attribute
)
1230 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1231 tree gnu_type
= TREE_TYPE (gnu_prefix
);
1232 tree gnu_expr
, gnu_result_type
, gnu_result
= error_mark_node
;
1233 bool prefix_unused
= false;
1235 /* If the input is a NULL_EXPR, make a new one. */
1236 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1238 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1239 *gnu_result_type_p
= gnu_result_type
;
1240 return build1 (NULL_EXPR
, gnu_result_type
, TREE_OPERAND (gnu_prefix
, 0));
1247 /* These are just conversions since representation clauses for
1248 enumeration types are handled in the front-end. */
1250 bool checkp
= Do_Range_Check (First (Expressions (gnat_node
)));
1251 gnu_result
= gnat_to_gnu (First (Expressions (gnat_node
)));
1252 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1253 gnu_result
= convert_with_check (Etype (gnat_node
), gnu_result
,
1254 checkp
, checkp
, true, gnat_node
);
1260 /* These just add or subtract the constant 1 since representation
1261 clauses for enumeration types are handled in the front-end. */
1262 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1263 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1265 if (Do_Range_Check (First (Expressions (gnat_node
))))
1267 gnu_expr
= gnat_protect_expr (gnu_expr
);
1270 (build_binary_op (EQ_EXPR
, boolean_type_node
,
1272 attribute
== Attr_Pred
1273 ? TYPE_MIN_VALUE (gnu_result_type
)
1274 : TYPE_MAX_VALUE (gnu_result_type
)),
1275 gnu_expr
, CE_Range_Check_Failed
, gnat_node
);
1279 = build_binary_op (attribute
== Attr_Pred
? MINUS_EXPR
: PLUS_EXPR
,
1280 gnu_result_type
, gnu_expr
,
1281 convert (gnu_result_type
, integer_one_node
));
1285 case Attr_Unrestricted_Access
:
1286 /* Conversions don't change addresses but can cause us to miss the
1287 COMPONENT_REF case below, so strip them off. */
1288 gnu_prefix
= remove_conversions (gnu_prefix
,
1289 !Must_Be_Byte_Aligned (gnat_node
));
1291 /* If we are taking 'Address of an unconstrained object, this is the
1292 pointer to the underlying array. */
1293 if (attribute
== Attr_Address
)
1294 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1296 /* If we are building a static dispatch table, we have to honor
1297 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1298 with the C++ ABI. We do it in the non-static case as well,
1299 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1300 else if (TARGET_VTABLE_USES_DESCRIPTORS
1301 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
1304 /* Descriptors can only be built here for top-level functions. */
1305 bool build_descriptor
= (global_bindings_p () != 0);
1307 VEC(constructor_elt
,gc
) *gnu_vec
= NULL
;
1308 constructor_elt
*elt
;
1310 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1312 /* If we're not going to build the descriptor, we have to retrieve
1313 the one which will be built by the linker (or by the compiler
1314 later if a static chain is requested). */
1315 if (!build_descriptor
)
1317 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_prefix
);
1318 gnu_result
= fold_convert (build_pointer_type (gnu_result_type
),
1320 gnu_result
= build1 (INDIRECT_REF
, gnu_result_type
, gnu_result
);
1323 VEC_safe_grow (constructor_elt
, gc
, gnu_vec
,
1324 TARGET_VTABLE_USES_DESCRIPTORS
);
1325 elt
= (VEC_address (constructor_elt
, gnu_vec
)
1326 + TARGET_VTABLE_USES_DESCRIPTORS
- 1);
1327 for (gnu_field
= TYPE_FIELDS (gnu_result_type
), i
= 0;
1328 i
< TARGET_VTABLE_USES_DESCRIPTORS
;
1329 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
1331 if (build_descriptor
)
1333 t
= build2 (FDESC_EXPR
, TREE_TYPE (gnu_field
), gnu_prefix
,
1334 build_int_cst (NULL_TREE
, i
));
1335 TREE_CONSTANT (t
) = 1;
1338 t
= build3 (COMPONENT_REF
, ptr_void_ftype
, gnu_result
,
1339 gnu_field
, NULL_TREE
);
1341 elt
->index
= gnu_field
;
1346 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
1350 /* ... fall through ... */
1353 case Attr_Unchecked_Access
:
1354 case Attr_Code_Address
:
1355 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1357 = build_unary_op (((attribute
== Attr_Address
1358 || attribute
== Attr_Unrestricted_Access
)
1359 && !Must_Be_Byte_Aligned (gnat_node
))
1360 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1361 gnu_result_type
, gnu_prefix
);
1363 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1364 don't try to build a trampoline. */
1365 if (attribute
== Attr_Code_Address
)
1367 gnu_expr
= remove_conversions (gnu_result
, false);
1369 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1370 TREE_NO_TRAMPOLINE (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1373 /* For other address attributes applied to a nested function,
1374 find an inner ADDR_EXPR and annotate it so that we can issue
1375 a useful warning with -Wtrampolines. */
1376 else if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == FUNCTION_TYPE
)
1378 gnu_expr
= remove_conversions (gnu_result
, false);
1380 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
1381 && decl_function_context (TREE_OPERAND (gnu_expr
, 0)))
1383 set_expr_location_from_node (gnu_expr
, gnat_node
);
1385 /* Check that we're not violating the No_Implicit_Dynamic_Code
1386 restriction. Be conservative if we don't know anything
1387 about the trampoline strategy for the target. */
1388 Check_Implicit_Dynamic_Code_Allowed (gnat_node
);
1393 case Attr_Pool_Address
:
1396 tree gnu_ptr
= gnu_prefix
;
1398 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1400 /* If this is an unconstrained array, we know the object has been
1401 allocated with the template in front of the object. So compute
1402 the template address. */
1403 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
1405 = convert (build_pointer_type
1406 (TYPE_OBJECT_RECORD_TYPE
1407 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
1410 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
1411 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
1412 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
1414 tree gnu_char_ptr_type
1415 = build_pointer_type (unsigned_char_type_node
);
1416 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
1417 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
1418 gnu_ptr
= build_binary_op (POINTER_PLUS_EXPR
, gnu_char_ptr_type
,
1422 gnu_result
= convert (gnu_result_type
, gnu_ptr
);
1427 case Attr_Object_Size
:
1428 case Attr_Value_Size
:
1429 case Attr_Max_Size_In_Storage_Elements
:
1430 gnu_expr
= gnu_prefix
;
1432 /* Remove NOPs and conversions between original and packable version
1433 from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
1434 to see if a COMPONENT_REF was involved. */
1435 while (TREE_CODE (gnu_expr
) == NOP_EXPR
1436 || (TREE_CODE (gnu_expr
) == VIEW_CONVERT_EXPR
1437 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
1438 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
1440 && TYPE_NAME (TREE_TYPE (gnu_expr
))
1441 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))))
1442 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1444 gnu_prefix
= remove_conversions (gnu_prefix
, true);
1445 prefix_unused
= true;
1446 gnu_type
= TREE_TYPE (gnu_prefix
);
1448 /* Replace an unconstrained array type with the type of the underlying
1449 array. We can't do this with a call to maybe_unconstrained_array
1450 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
1451 use the record type that will be used to allocate the object and its
1453 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1455 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1456 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1457 gnu_type
= TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)));
1460 /* If we're looking for the size of a field, return the field size.
1461 Otherwise, if the prefix is an object, or if we're looking for
1462 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1463 GCC size of the type. Otherwise, it is the RM size of the type. */
1464 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1465 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1466 else if (TREE_CODE (gnu_prefix
) != TYPE_DECL
1467 || attribute
== Attr_Object_Size
1468 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1470 /* If the prefix is an object of a padded type, the GCC size isn't
1471 relevant to the programmer. Normally what we want is the RM size,
1472 which was set from the specified size, but if it was not set, we
1473 want the size of the field. Using the MAX of those two produces
1474 the right result in all cases. Don't use the size of the field
1475 if it's self-referential, since that's never what's wanted. */
1476 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
1477 && TYPE_IS_PADDING_P (gnu_type
)
1478 && TREE_CODE (gnu_expr
) == COMPONENT_REF
)
1480 gnu_result
= rm_size (gnu_type
);
1481 if (!CONTAINS_PLACEHOLDER_P
1482 (DECL_SIZE (TREE_OPERAND (gnu_expr
, 1))))
1484 = size_binop (MAX_EXPR
, gnu_result
,
1485 DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)));
1487 else if (Nkind (Prefix (gnat_node
)) == N_Explicit_Dereference
)
1489 Node_Id gnat_deref
= Prefix (gnat_node
);
1490 Node_Id gnat_actual_subtype
1491 = Actual_Designated_Subtype (gnat_deref
);
1493 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref
)));
1495 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
)
1496 && Present (gnat_actual_subtype
))
1498 tree gnu_actual_obj_type
1499 = gnat_to_gnu_type (gnat_actual_subtype
);
1501 = build_unc_object_type_from_ptr (gnu_ptr_type
,
1502 gnu_actual_obj_type
,
1503 get_identifier ("SIZE"),
1507 gnu_result
= TYPE_SIZE (gnu_type
);
1510 gnu_result
= TYPE_SIZE (gnu_type
);
1513 gnu_result
= rm_size (gnu_type
);
1515 /* Deal with a self-referential size by returning the maximum size for
1516 a type and by qualifying the size with the object otherwise. */
1517 if (CONTAINS_PLACEHOLDER_P (gnu_result
))
1519 if (TREE_CODE (gnu_prefix
) == TYPE_DECL
)
1520 gnu_result
= max_size (gnu_result
, true);
1522 gnu_result
= substitute_placeholder_in_expr (gnu_result
, gnu_expr
);
1525 /* If the type contains a template, subtract its size. */
1526 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1527 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1528 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1529 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1531 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
1532 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1533 gnu_result
= size_binop (CEIL_DIV_EXPR
, gnu_result
, bitsize_unit_node
);
1535 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1538 case Attr_Alignment
:
1542 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1543 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
1544 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1546 gnu_type
= TREE_TYPE (gnu_prefix
);
1547 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1548 prefix_unused
= true;
1550 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1551 align
= DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)) / BITS_PER_UNIT
;
1554 Node_Id gnat_prefix
= Prefix (gnat_node
);
1555 Entity_Id gnat_type
= Etype (gnat_prefix
);
1556 unsigned int double_align
;
1557 bool is_capped_double
, align_clause
;
1559 /* If the default alignment of "double" or larger scalar types is
1560 specifically capped and there is an alignment clause neither
1561 on the type nor on the prefix itself, return the cap. */
1562 if ((double_align
= double_float_alignment
) > 0)
1564 = is_double_float_or_array (gnat_type
, &align_clause
);
1565 else if ((double_align
= double_scalar_alignment
) > 0)
1567 = is_double_scalar_or_array (gnat_type
, &align_clause
);
1569 is_capped_double
= align_clause
= false;
1571 if (is_capped_double
1572 && Nkind (gnat_prefix
) == N_Identifier
1573 && Present (Alignment_Clause (Entity (gnat_prefix
))))
1574 align_clause
= true;
1576 if (is_capped_double
&& !align_clause
)
1577 align
= double_align
;
1579 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
1582 gnu_result
= size_int (align
);
1588 case Attr_Range_Length
:
1589 prefix_unused
= true;
1591 if (INTEGRAL_TYPE_P (gnu_type
) || TREE_CODE (gnu_type
) == REAL_TYPE
)
1593 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1595 if (attribute
== Attr_First
)
1596 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
1597 else if (attribute
== Attr_Last
)
1598 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
1602 (MAX_EXPR
, get_base_type (gnu_result_type
),
1604 (PLUS_EXPR
, get_base_type (gnu_result_type
),
1605 build_binary_op (MINUS_EXPR
,
1606 get_base_type (gnu_result_type
),
1607 convert (gnu_result_type
,
1608 TYPE_MAX_VALUE (gnu_type
)),
1609 convert (gnu_result_type
,
1610 TYPE_MIN_VALUE (gnu_type
))),
1611 convert (gnu_result_type
, integer_one_node
)),
1612 convert (gnu_result_type
, integer_zero_node
));
1617 /* ... fall through ... */
1621 int Dimension
= (Present (Expressions (gnat_node
))
1622 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
1624 struct parm_attr_d
*pa
= NULL
;
1625 Entity_Id gnat_param
= Empty
;
1627 /* Make sure any implicit dereference gets done. */
1628 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1629 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1631 /* We treat unconstrained array In parameters specially. */
1632 if (!Is_Constrained (Etype (Prefix (gnat_node
))))
1634 Node_Id gnat_prefix
= Prefix (gnat_node
);
1636 /* This is the direct case. */
1637 if (Nkind (gnat_prefix
) == N_Identifier
1638 && Ekind (Entity (gnat_prefix
)) == E_In_Parameter
)
1639 gnat_param
= Entity (gnat_prefix
);
1641 /* This is the indirect case. Note that we need to be sure that
1642 the access value cannot be null as we'll hoist the load. */
1643 if (Nkind (gnat_prefix
) == N_Explicit_Dereference
1644 && Nkind (Prefix (gnat_prefix
)) == N_Identifier
1645 && Ekind (Entity (Prefix (gnat_prefix
))) == E_In_Parameter
1646 && Can_Never_Be_Null (Entity (Prefix (gnat_prefix
))))
1647 gnat_param
= Entity (Prefix (gnat_prefix
));
1650 gnu_type
= TREE_TYPE (gnu_prefix
);
1651 prefix_unused
= true;
1652 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1654 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
1659 for (ndim
= 1, gnu_type_temp
= gnu_type
;
1660 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
1661 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
1662 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
1665 Dimension
= ndim
+ 1 - Dimension
;
1668 for (i
= 1; i
< Dimension
; i
++)
1669 gnu_type
= TREE_TYPE (gnu_type
);
1671 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
1673 /* When not optimizing, look up the slot associated with the parameter
1674 and the dimension in the cache and create a new one on failure. */
1675 if (!optimize
&& Present (gnat_param
))
1677 FOR_EACH_VEC_ELT (parm_attr
, f_parm_attr_cache
, i
, pa
)
1678 if (pa
->id
== gnat_param
&& pa
->dim
== Dimension
)
1683 pa
= ggc_alloc_cleared_parm_attr_d ();
1684 pa
->id
= gnat_param
;
1685 pa
->dim
= Dimension
;
1686 VEC_safe_push (parm_attr
, gc
, f_parm_attr_cache
, pa
);
1690 /* Return the cached expression or build a new one. */
1691 if (attribute
== Attr_First
)
1693 if (pa
&& pa
->first
)
1695 gnu_result
= pa
->first
;
1700 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1703 else if (attribute
== Attr_Last
)
1707 gnu_result
= pa
->last
;
1712 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1715 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
1717 if (pa
&& pa
->length
)
1719 gnu_result
= pa
->length
;
1724 /* We used to compute the length as max (hb - lb + 1, 0),
1725 which could overflow for some cases of empty arrays, e.g.
1726 when lb == index_type'first. We now compute the length as
1727 (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1728 much rarer cases, for extremely large arrays we expect
1729 never to encounter in practice. In addition, the former
1730 computation required the use of potentially constraining
1731 signed arithmetic while the latter doesn't. Note that
1732 the comparison must be done in the original index type,
1733 to avoid any overflow during the conversion. */
1734 tree comp_type
= get_base_type (gnu_result_type
);
1735 tree index_type
= TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
));
1736 tree lb
= TYPE_MIN_VALUE (index_type
);
1737 tree hb
= TYPE_MAX_VALUE (index_type
);
1739 = build_binary_op (PLUS_EXPR
, comp_type
,
1740 build_binary_op (MINUS_EXPR
,
1742 convert (comp_type
, hb
),
1743 convert (comp_type
, lb
)),
1744 convert (comp_type
, integer_one_node
));
1746 = build_cond_expr (comp_type
,
1747 build_binary_op (GE_EXPR
,
1751 convert (comp_type
, integer_zero_node
));
1755 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1756 handling. Note that these attributes could not have been used on
1757 an unconstrained array type. */
1758 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
1760 /* Cache the expression we have just computed. Since we want to do it
1761 at run time, we force the use of a SAVE_EXPR and let the gimplifier
1762 create the temporary in the outermost binding level. We will make
1763 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
1764 paths by forcing its evaluation on entry of the function. */
1768 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
1769 if (attribute
== Attr_First
)
1770 pa
->first
= gnu_result
;
1771 else if (attribute
== Attr_Last
)
1772 pa
->last
= gnu_result
;
1774 pa
->length
= gnu_result
;
1777 /* Set the source location onto the predicate of the condition in the
1778 'Length case but do not do it if the expression is cached to avoid
1779 messing up the debug info. */
1780 else if ((attribute
== Attr_Range_Length
|| attribute
== Attr_Length
)
1781 && TREE_CODE (gnu_result
) == COND_EXPR
1782 && EXPR_P (TREE_OPERAND (gnu_result
, 0)))
1783 set_expr_location_from_node (TREE_OPERAND (gnu_result
, 0),
1789 case Attr_Bit_Position
:
1791 case Attr_First_Bit
:
1795 HOST_WIDE_INT bitsize
;
1796 HOST_WIDE_INT bitpos
;
1798 tree gnu_field_bitpos
;
1799 tree gnu_field_offset
;
1801 enum machine_mode mode
;
1802 int unsignedp
, volatilep
;
1804 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1805 gnu_prefix
= remove_conversions (gnu_prefix
, true);
1806 prefix_unused
= true;
1808 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1809 the result is 0. Don't allow 'Bit on a bare component, though. */
1810 if (attribute
== Attr_Bit
1811 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
1812 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
1814 gnu_result
= integer_zero_node
;
1819 gcc_assert (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1820 || (attribute
== Attr_Bit_Position
1821 && TREE_CODE (gnu_prefix
) == FIELD_DECL
));
1823 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
1824 &mode
, &unsignedp
, &volatilep
, false);
1826 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1828 gnu_field_bitpos
= bit_position (TREE_OPERAND (gnu_prefix
, 1));
1829 gnu_field_offset
= byte_position (TREE_OPERAND (gnu_prefix
, 1));
1831 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
1832 TREE_CODE (gnu_inner
) == COMPONENT_REF
1833 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
1834 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
1837 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
1838 bit_position (TREE_OPERAND (gnu_inner
, 1)));
1840 = size_binop (PLUS_EXPR
, gnu_field_offset
,
1841 byte_position (TREE_OPERAND (gnu_inner
, 1)));
1844 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
1846 gnu_field_bitpos
= bit_position (gnu_prefix
);
1847 gnu_field_offset
= byte_position (gnu_prefix
);
1851 gnu_field_bitpos
= bitsize_zero_node
;
1852 gnu_field_offset
= size_zero_node
;
1858 gnu_result
= gnu_field_offset
;
1861 case Attr_First_Bit
:
1863 gnu_result
= size_int (bitpos
% BITS_PER_UNIT
);
1867 gnu_result
= bitsize_int (bitpos
% BITS_PER_UNIT
);
1868 gnu_result
= size_binop (PLUS_EXPR
, gnu_result
,
1869 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
1870 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1874 case Attr_Bit_Position
:
1875 gnu_result
= gnu_field_bitpos
;
1879 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1881 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
1888 tree gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
1889 tree gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1891 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1892 gnu_result
= build_binary_op (attribute
== Attr_Min
1893 ? MIN_EXPR
: MAX_EXPR
,
1894 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1898 case Attr_Passed_By_Reference
:
1899 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
1900 || must_pass_by_ref (gnu_type
));
1901 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1904 case Attr_Component_Size
:
1905 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1906 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0))))
1907 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1909 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1910 gnu_type
= TREE_TYPE (gnu_prefix
);
1912 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1913 gnu_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
1915 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
1916 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
1917 gnu_type
= TREE_TYPE (gnu_type
);
1919 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
1921 /* Note this size cannot be self-referential. */
1922 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
1923 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1924 prefix_unused
= true;
1927 case Attr_Descriptor_Size
:
1928 gnu_type
= TREE_TYPE (gnu_prefix
);
1929 gcc_assert (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
);
1931 /* What we want is the offset of the ARRAY field in the record that the
1932 thin pointer designates, but the components have been shifted so this
1933 is actually the opposite of the offset of the BOUNDS field. */
1934 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1935 gnu_result
= size_binop (MINUS_EXPR
, bitsize_zero_node
,
1936 bit_position (TYPE_FIELDS (gnu_type
)));
1937 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1938 prefix_unused
= true;
1941 case Attr_Null_Parameter
:
1942 /* This is just a zero cast to the pointer type for our prefix and
1944 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1946 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1947 convert (build_pointer_type (gnu_result_type
),
1948 integer_zero_node
));
1949 TREE_PRIVATE (gnu_result
) = 1;
1952 case Attr_Mechanism_Code
:
1955 Entity_Id gnat_obj
= Entity (Prefix (gnat_node
));
1957 prefix_unused
= true;
1958 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1959 if (Present (Expressions (gnat_node
)))
1961 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
1963 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
1964 i
--, gnat_obj
= Next_Formal (gnat_obj
))
1968 code
= Mechanism (gnat_obj
);
1969 if (code
== Default
)
1970 code
= ((present_gnu_tree (gnat_obj
)
1971 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
1972 || ((TREE_CODE (get_gnu_tree (gnat_obj
))
1974 && (DECL_BY_COMPONENT_PTR_P
1975 (get_gnu_tree (gnat_obj
))))))
1976 ? By_Reference
: By_Copy
);
1977 gnu_result
= convert (gnu_result_type
, size_int (- code
));
1982 /* Say we have an unimplemented attribute. Then set the value to be
1983 returned to be a zero and hope that's something we can convert to
1984 the type of this attribute. */
1985 post_error ("unimplemented attribute", gnat_node
);
1986 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1987 gnu_result
= integer_zero_node
;
1991 /* If this is an attribute where the prefix was unused, force a use of it if
1992 it has a side-effect. But don't do it if the prefix is just an entity
1993 name. However, if an access check is needed, we must do it. See second
1994 example in AARM 11.6(5.e). */
1995 if (prefix_unused
&& TREE_SIDE_EFFECTS (gnu_prefix
)
1996 && !Is_Entity_Name (Prefix (gnat_node
)))
1997 gnu_result
= build_compound_expr (TREE_TYPE (gnu_result
), gnu_prefix
,
2000 *gnu_result_type_p
= gnu_result_type
;
2004 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2005 to a GCC tree, which is returned. */
2008 Case_Statement_to_gnu (Node_Id gnat_node
)
2010 tree gnu_result
, gnu_expr
, gnu_label
;
2012 location_t end_locus
;
2013 bool may_fallthru
= false;
2015 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2016 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2018 /* The range of values in a case statement is determined by the rules in
2019 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
2020 of the expression. One exception arises in the case of a simple name that
2021 is parenthesized. This still has the Etype of the name, but since it is
2022 not a name, para 7 does not apply, and we need to go to the base type.
2023 This is the only case where parenthesization affects the dynamic
2024 semantics (i.e. the range of possible values at run time that is covered
2025 by the others alternative).
2027 Another exception is if the subtype of the expression is non-static. In
2028 that case, we also have to use the base type. */
2029 if (Paren_Count (Expression (gnat_node
)) != 0
2030 || !Is_OK_Static_Subtype (Underlying_Type
2031 (Etype (Expression (gnat_node
)))))
2032 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2034 /* We build a SWITCH_EXPR that contains the code with interspersed
2035 CASE_LABEL_EXPRs for each label. */
2036 if (!Sloc_to_locus (Sloc (gnat_node
) + UI_To_Int (End_Span (gnat_node
)),
2038 end_locus
= input_location
;
2039 gnu_label
= create_artificial_label (end_locus
);
2040 start_stmt_group ();
2042 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2043 Present (gnat_when
);
2044 gnat_when
= Next_Non_Pragma (gnat_when
))
2046 bool choices_added_p
= false;
2047 Node_Id gnat_choice
;
2049 /* First compile all the different case choices for the current WHEN
2051 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2052 Present (gnat_choice
); gnat_choice
= Next (gnat_choice
))
2054 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2056 switch (Nkind (gnat_choice
))
2059 gnu_low
= gnat_to_gnu (Low_Bound (gnat_choice
));
2060 gnu_high
= gnat_to_gnu (High_Bound (gnat_choice
));
2063 case N_Subtype_Indication
:
2064 gnu_low
= gnat_to_gnu (Low_Bound (Range_Expression
2065 (Constraint (gnat_choice
))));
2066 gnu_high
= gnat_to_gnu (High_Bound (Range_Expression
2067 (Constraint (gnat_choice
))));
2071 case N_Expanded_Name
:
2072 /* This represents either a subtype range or a static value of
2073 some kind; Ekind says which. */
2074 if (IN (Ekind (Entity (gnat_choice
)), Type_Kind
))
2076 tree gnu_type
= get_unpadded_type (Entity (gnat_choice
));
2078 gnu_low
= fold (TYPE_MIN_VALUE (gnu_type
));
2079 gnu_high
= fold (TYPE_MAX_VALUE (gnu_type
));
2083 /* ... fall through ... */
2085 case N_Character_Literal
:
2086 case N_Integer_Literal
:
2087 gnu_low
= gnat_to_gnu (gnat_choice
);
2090 case N_Others_Choice
:
2097 /* If the case value is a subtype that raises Constraint_Error at
2098 run time because of a wrong bound, then gnu_low or gnu_high is
2099 not translated into an INTEGER_CST. In such a case, we need
2100 to ensure that the when statement is not added in the tree,
2101 otherwise it will crash the gimplifier. */
2102 if ((!gnu_low
|| TREE_CODE (gnu_low
) == INTEGER_CST
)
2103 && (!gnu_high
|| TREE_CODE (gnu_high
) == INTEGER_CST
))
2105 add_stmt_with_node (build_case_label
2107 create_artificial_label (input_location
)),
2109 choices_added_p
= true;
2113 /* Push a binding level here in case variables are declared as we want
2114 them to be local to this set of statements instead of to the block
2115 containing the Case statement. */
2116 if (choices_added_p
)
2118 tree group
= build_stmt_group (Statements (gnat_when
), true);
2119 bool group_may_fallthru
= block_may_fallthru (group
);
2121 if (group_may_fallthru
)
2123 tree stmt
= build1 (GOTO_EXPR
, void_type_node
, gnu_label
);
2124 SET_EXPR_LOCATION (stmt
, end_locus
);
2126 may_fallthru
= true;
2131 /* Now emit a definition of the label the cases branch to, if any. */
2133 add_stmt (build1 (LABEL_EXPR
, void_type_node
, gnu_label
));
2134 gnu_result
= build3 (SWITCH_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
,
2135 end_stmt_group (), NULL_TREE
);
2140 /* Find out whether VAR is an iteration variable of an enclosing loop in the
2141 current function. If so, push a range_check_info structure onto the stack
2142 of this enclosing loop and return it. Otherwise, return NULL. */
2144 static struct range_check_info_d
*
2145 push_range_check_info (tree var
)
2147 struct loop_info_d
*iter
= NULL
;
2150 if (VEC_empty (loop_info
, gnu_loop_stack
))
2153 var
= remove_conversions (var
, false);
2155 if (TREE_CODE (var
) != VAR_DECL
)
2158 if (decl_function_context (var
) != current_function_decl
)
2161 for (i
= VEC_length (loop_info
, gnu_loop_stack
) - 1;
2162 VEC_iterate (loop_info
, gnu_loop_stack
, i
, iter
);
2164 if (var
== iter
->loop_var
)
2169 struct range_check_info_d
*rci
= ggc_alloc_range_check_info_d ();
2170 VEC_safe_push (range_check_info
, gc
, iter
->checks
, rci
);
2177 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2178 false, or the maximum value if MAX is true, of TYPE. */
2181 can_equal_min_or_max_val_p (tree val
, tree type
, bool max
)
2183 tree min_or_max_val
= (max
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
));
2185 if (TREE_CODE (min_or_max_val
) != INTEGER_CST
)
2188 if (TREE_CODE (val
) == NOP_EXPR
)
2190 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0)))
2191 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val
, 0))));
2193 if (TREE_CODE (val
) != INTEGER_CST
)
2196 return tree_int_cst_equal (val
, min_or_max_val
) == 1;
2199 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2200 If REVERSE is true, minimum value is taken as maximum value. */
2203 can_equal_min_val_p (tree val
, tree type
, bool reverse
)
2205 return can_equal_min_or_max_val_p (val
, type
, reverse
);
2208 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2209 If REVERSE is true, maximum value is taken as minimum value. */
2212 can_equal_max_val_p (tree val
, tree type
, bool reverse
)
2214 return can_equal_min_or_max_val_p (val
, type
, !reverse
);
2217 /* Return true if VAL1 can be lower than VAL2. */
2220 can_be_lower_p (tree val1
, tree val2
)
2222 if (TREE_CODE (val1
) == NOP_EXPR
)
2223 val1
= TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1
, 0)));
2225 if (TREE_CODE (val1
) != INTEGER_CST
)
2228 if (TREE_CODE (val2
) == NOP_EXPR
)
2229 val2
= TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2
, 0)));
2231 if (TREE_CODE (val2
) != INTEGER_CST
)
2234 return tree_int_cst_lt (val1
, val2
);
2237 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2238 to a GCC tree, which is returned. */
2241 Loop_Statement_to_gnu (Node_Id gnat_node
)
2243 const Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2244 struct loop_info_d
*gnu_loop_info
= ggc_alloc_cleared_loop_info_d ();
2245 tree gnu_loop_stmt
= build4 (LOOP_STMT
, void_type_node
, NULL_TREE
,
2246 NULL_TREE
, NULL_TREE
, NULL_TREE
);
2247 tree gnu_loop_label
= create_artificial_label (input_location
);
2248 tree gnu_cond_expr
= NULL_TREE
, gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
2251 /* Push the loop_info structure associated with the LOOP_STMT. */
2252 VEC_safe_push (loop_info
, gc
, gnu_loop_stack
, gnu_loop_info
);
2254 /* Set location information for statement and end label. */
2255 set_expr_location_from_node (gnu_loop_stmt
, gnat_node
);
2256 Sloc_to_locus (Sloc (End_Label (gnat_node
)),
2257 &DECL_SOURCE_LOCATION (gnu_loop_label
));
2258 LOOP_STMT_LABEL (gnu_loop_stmt
) = gnu_loop_label
;
2260 /* Save the label so that a corresponding N_Exit_Statement can find it. */
2261 gnu_loop_info
->label
= gnu_loop_label
;
2263 /* Set the condition under which the loop must keep going.
2264 For the case "LOOP .... END LOOP;" the condition is always true. */
2265 if (No (gnat_iter_scheme
))
2268 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2269 else if (Present (Condition (gnat_iter_scheme
)))
2270 LOOP_STMT_COND (gnu_loop_stmt
)
2271 = gnat_to_gnu (Condition (gnat_iter_scheme
));
2273 /* Otherwise we have an iteration scheme and the condition is given by the
2274 bounds of the subtype of the iteration variable. */
2277 Node_Id gnat_loop_spec
= Loop_Parameter_Specification (gnat_iter_scheme
);
2278 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2279 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2280 tree gnu_type
= get_unpadded_type (gnat_type
);
2281 tree gnu_base_type
= get_base_type (gnu_type
);
2282 tree gnu_one_node
= convert (gnu_base_type
, integer_one_node
);
2283 tree gnu_loop_var
, gnu_loop_iv
, gnu_first
, gnu_last
, gnu_stmt
;
2284 enum tree_code update_code
, test_code
, shift_code
;
2285 bool reverse
= Reverse_Present (gnat_loop_spec
), use_iv
= false;
2287 gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2288 gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2290 /* We must disable modulo reduction for the iteration variable, if any,
2291 in order for the loop comparison to be effective. */
2294 gnu_first
= gnu_high
;
2296 update_code
= MINUS_NOMOD_EXPR
;
2297 test_code
= GE_EXPR
;
2298 shift_code
= PLUS_NOMOD_EXPR
;
2302 gnu_first
= gnu_low
;
2303 gnu_last
= gnu_high
;
2304 update_code
= PLUS_NOMOD_EXPR
;
2305 test_code
= LE_EXPR
;
2306 shift_code
= MINUS_NOMOD_EXPR
;
2309 /* We use two different strategies to translate the loop, depending on
2310 whether optimization is enabled.
2312 If it is, we generate the canonical loop form expected by the loop
2313 optimizer and the loop vectorizer, which is the do-while form:
2322 This avoids an implicit dependency on loop header copying and makes
2323 it possible to turn BOTTOM_COND into an inequality test.
2325 If optimization is disabled, loop header copying doesn't come into
2326 play and we try to generate the loop form with the fewer conditional
2327 branches. First, the default form, which is:
2335 It should catch most loops with constant ending point. Then, if we
2336 cannot, we try to generate the shifted form:
2344 which should catch loops with constant starting point. Otherwise, if
2345 we cannot, we generate the fallback form:
2354 which works in all cases. */
2358 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
2360 if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
))
2363 /* Otherwise, use the do-while form with the help of a special
2364 induction variable in the unsigned version of the base type
2365 or the unsigned version of the size type, whichever is the
2366 largest, in order to have wrap-around arithmetics for it. */
2369 if (TYPE_PRECISION (gnu_base_type
)
2370 > TYPE_PRECISION (size_type_node
))
2371 gnu_base_type
= gnat_unsigned_type (gnu_base_type
);
2373 gnu_base_type
= size_type_node
;
2375 gnu_first
= convert (gnu_base_type
, gnu_first
);
2376 gnu_last
= convert (gnu_base_type
, gnu_last
);
2377 gnu_one_node
= convert (gnu_base_type
, integer_one_node
);
2382 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
2384 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
2385 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
2389 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
2390 if (!can_equal_max_val_p (gnu_last
, gnu_base_type
, reverse
))
2393 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2395 else if (!can_equal_min_val_p (gnu_first
, gnu_base_type
, reverse
)
2396 && !can_equal_min_val_p (gnu_last
, gnu_base_type
, reverse
))
2399 = build_binary_op (shift_code
, gnu_base_type
, gnu_first
,
2402 = build_binary_op (shift_code
, gnu_base_type
, gnu_last
,
2404 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt
) = 1;
2407 /* Otherwise, use the fallback form. */
2409 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
) = 1;
2412 /* If we use the BOTTOM_COND, we can turn the test into an inequality
2413 test but we may have to add ENTRY_COND to protect the empty loop. */
2414 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt
))
2416 test_code
= NE_EXPR
;
2417 if (can_be_lower_p (gnu_high
, gnu_low
))
2420 = build3 (COND_EXPR
, void_type_node
,
2421 build_binary_op (LE_EXPR
, boolean_type_node
,
2423 NULL_TREE
, alloc_stmt_list ());
2424 set_expr_location_from_node (gnu_cond_expr
, gnat_loop_spec
);
2428 /* Open a new nesting level that will surround the loop to declare the
2429 iteration variable. */
2430 start_stmt_group ();
2433 /* If we use the special induction variable, create it and set it to
2434 its initial value. Morever, the regular iteration variable cannot
2435 itself be initialized, lest the initial value wrapped around. */
2439 = create_init_temporary ("I", gnu_first
, &gnu_stmt
, gnat_loop_var
);
2440 add_stmt (gnu_stmt
);
2441 gnu_first
= NULL_TREE
;
2444 gnu_loop_iv
= NULL_TREE
;
2446 /* Declare the iteration variable and set it to its initial value. */
2447 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, 1);
2448 if (DECL_BY_REF_P (gnu_loop_var
))
2449 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_loop_var
);
2452 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var
));
2453 SET_DECL_INDUCTION_VAR (gnu_loop_var
, gnu_loop_iv
);
2455 gnu_loop_info
->loop_var
= gnu_loop_var
;
2457 /* Do all the arithmetics in the base type. */
2458 gnu_loop_var
= convert (gnu_base_type
, gnu_loop_var
);
2460 /* Set either the top or bottom exit condition. */
2462 LOOP_STMT_COND (gnu_loop_stmt
)
2463 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_iv
,
2466 LOOP_STMT_COND (gnu_loop_stmt
)
2467 = build_binary_op (test_code
, boolean_type_node
, gnu_loop_var
,
2470 /* Set either the top or bottom update statement and give it the source
2471 location of the iteration for better coverage info. */
2475 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_iv
,
2476 build_binary_op (update_code
, gnu_base_type
,
2477 gnu_loop_iv
, gnu_one_node
));
2478 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
2479 append_to_statement_list (gnu_stmt
,
2480 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
2482 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
2484 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
2485 append_to_statement_list (gnu_stmt
,
2486 &LOOP_STMT_UPDATE (gnu_loop_stmt
));
2491 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_loop_var
,
2492 build_binary_op (update_code
, gnu_base_type
,
2493 gnu_loop_var
, gnu_one_node
));
2494 set_expr_location_from_node (gnu_stmt
, gnat_iter_scheme
);
2495 LOOP_STMT_UPDATE (gnu_loop_stmt
) = gnu_stmt
;
2499 /* If the loop was named, have the name point to this loop. In this case,
2500 the association is not a DECL node, but the end label of the loop. */
2501 if (Present (Identifier (gnat_node
)))
2502 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_label
, true);
2504 /* Make the loop body into its own block, so any allocated storage will be
2505 released every iteration. This is needed for stack allocation. */
2506 LOOP_STMT_BODY (gnu_loop_stmt
)
2507 = build_stmt_group (Statements (gnat_node
), true);
2508 TREE_SIDE_EFFECTS (gnu_loop_stmt
) = 1;
2510 /* If we have an iteration scheme, then we are in a statement group. Add
2511 the LOOP_STMT to it, finish it and make it the "loop". */
2512 if (Present (gnat_iter_scheme
) && No (Condition (gnat_iter_scheme
)))
2514 struct range_check_info_d
*rci
;
2515 unsigned n_checks
= VEC_length (range_check_info
, gnu_loop_info
->checks
);
2518 /* First, if we have computed a small number of invariant conditions for
2519 range checks applied to the iteration variable, then initialize these
2520 conditions in front of the loop. Otherwise, leave them set to True.
2522 ??? The heuristics need to be improved, by taking into account the
2523 following datapoints:
2524 - loop unswitching is disabled for big loops. The cap is the
2525 parameter PARAM_MAX_UNSWITCH_INSNS (50).
2526 - loop unswitching can only be applied a small number of times
2527 to a given loop. The cap is PARAM_MAX_UNSWITCH_LEVEL (3).
2528 - the front-end quickly generates useless or redundant checks
2529 that can be entirely optimized away in the end. */
2530 if (1 <= n_checks
&& n_checks
<= 4)
2532 VEC_iterate (range_check_info
, gnu_loop_info
->checks
, i
, rci
);
2536 = build_binary_op (GE_EXPR
, boolean_type_node
,
2537 convert (rci
->type
, gnu_low
),
2540 = build_binary_op (LE_EXPR
, boolean_type_node
,
2541 convert (rci
->type
, gnu_high
),
2544 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
2547 TREE_OPERAND (rci
->invariant_cond
, 0)
2548 = build_unary_op (TRUTH_NOT_EXPR
, boolean_type_node
, range_ok
);
2550 add_stmt_with_node_force (rci
->invariant_cond
, gnat_node
);
2553 add_stmt (gnu_loop_stmt
);
2555 gnu_loop_stmt
= end_stmt_group ();
2558 /* If we have an outer COND_EXPR, that's our result and this loop is its
2559 "true" statement. Otherwise, the result is the LOOP_STMT. */
2562 COND_EXPR_THEN (gnu_cond_expr
) = gnu_loop_stmt
;
2563 gnu_result
= gnu_cond_expr
;
2564 recalculate_side_effects (gnu_cond_expr
);
2567 gnu_result
= gnu_loop_stmt
;
2569 VEC_pop (loop_info
, gnu_loop_stack
);
2574 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2575 handler for the current function. */
2577 /* This is implemented by issuing a call to the appropriate VMS specific
2578 builtin. To avoid having VMS specific sections in the global gigi decls
2579 array, we maintain the decls of interest here. We can't declare them
2580 inside the function because we must mark them never to be GC'd, which we
2581 can only do at the global level. */
2583 static GTY(()) tree vms_builtin_establish_handler_decl
= NULL_TREE
;
2584 static GTY(()) tree gnat_vms_condition_handler_decl
= NULL_TREE
;
2587 establish_gnat_vms_condition_handler (void)
2589 tree establish_stmt
;
2591 /* Elaborate the required decls on the first call. Check on the decl for
2592 the gnat condition handler to decide, as this is one we create so we are
2593 sure that it will be non null on subsequent calls. The builtin decl is
2594 looked up so remains null on targets where it is not implemented yet. */
2595 if (gnat_vms_condition_handler_decl
== NULL_TREE
)
2597 vms_builtin_establish_handler_decl
2599 (get_identifier ("__builtin_establish_vms_condition_handler"));
2601 gnat_vms_condition_handler_decl
2602 = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2604 build_function_type_list (boolean_type_node
,
2608 NULL_TREE
, false, true, true, true, NULL
,
2611 /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */
2612 DECL_CONTEXT (gnat_vms_condition_handler_decl
) = NULL_TREE
;
2615 /* Do nothing if the establish builtin is not available, which might happen
2616 on targets where the facility is not implemented. */
2617 if (vms_builtin_establish_handler_decl
== NULL_TREE
)
2621 = build_call_n_expr (vms_builtin_establish_handler_decl
, 1,
2623 (ADDR_EXPR
, NULL_TREE
,
2624 gnat_vms_condition_handler_decl
));
2626 add_stmt (establish_stmt
);
2629 /* This page implements a form of Named Return Value optimization modelled
2630 on the C++ optimization of the same name. The main difference is that
2631 we disregard any semantical considerations when applying it here, the
2632 counterpart being that we don't try to apply it to semantically loaded
2633 return types, i.e. types with the TREE_ADDRESSABLE flag set.
2635 We consider a function body of the following GENERIC form:
2639 RETURN_EXPR [<retval> = ...]
2641 RETURN_EXPR [<retval> = R1]
2645 RETURN_EXPR [<retval> = ...]
2647 RETURN_EXPR [<retval> = Ri]
2650 and we try to fulfill a simple criterion that would make it possible to
2651 replace one or several Ri variables with the RESULT_DECL of the function.
2653 The first observation is that RETURN_EXPRs that don't directly reference
2654 any of the Ri variables on the RHS of their assignment are transparent wrt
2655 the optimization. This is because the Ri variables aren't addressable so
2656 any transformation applied to them doesn't affect the RHS; moreover, the
2657 assignment writes the full <retval> object so existing values are entirely
2660 This property can be extended to some forms of RETURN_EXPRs that reference
2661 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
2662 case, in particular when function calls are involved.
2664 Therefore the algorithm is as follows:
2666 1. Collect the list of candidates for a Named Return Value (Ri variables
2667 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
2668 other expressions on the RHS of such assignments.
2670 2. Prune the members of the first list (candidates) that are referenced
2671 by a member of the second list (expressions).
2673 3. Extract a set of candidates with non-overlapping live ranges from the
2674 first list. These are the Named Return Values.
2676 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
2677 Named Return Values in the function with the RESULT_DECL. */
2683 struct pointer_set_t
*visited
;
2686 /* Return true if T is a Named Return Value. */
2689 is_nrv_p (bitmap nrv
, tree t
)
2691 return TREE_CODE (t
) == VAR_DECL
&& bitmap_bit_p (nrv
, DECL_UID (t
));
2694 /* Helper function for walk_tree, used by finalize_nrv below. */
2697 prune_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
2699 struct nrv_data
*dp
= (struct nrv_data
*)data
;
2702 /* No need to walk into types or decls. */
2703 if (IS_TYPE_OR_DECL_P (t
))
2706 if (is_nrv_p (dp
->nrv
, t
))
2707 bitmap_clear_bit (dp
->nrv
, DECL_UID (t
));
2712 /* Prune Named Return Values in BLOCK and return true if there is still a
2713 Named Return Value in BLOCK or one of its sub-blocks. */
2716 prune_nrv_in_block (bitmap nrv
, tree block
)
2718 bool has_nrv
= false;
2721 /* First recurse on the sub-blocks. */
2722 for (t
= BLOCK_SUBBLOCKS (block
); t
; t
= BLOCK_CHAIN (t
))
2723 has_nrv
|= prune_nrv_in_block (nrv
, t
);
2725 /* Then make sure to keep at most one NRV per block. */
2726 for (t
= BLOCK_VARS (block
); t
; t
= DECL_CHAIN (t
))
2727 if (is_nrv_p (nrv
, t
))
2730 bitmap_clear_bit (nrv
, DECL_UID (t
));
2738 /* Helper function for walk_tree, used by finalize_nrv below. */
2741 finalize_nrv_r (tree
*tp
, int *walk_subtrees
, void *data
)
2743 struct nrv_data
*dp
= (struct nrv_data
*)data
;
2746 /* No need to walk into types. */
2750 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
2751 nop, but differs from using NULL_TREE in that it indicates that we care
2752 about the value of the RESULT_DECL. */
2753 else if (TREE_CODE (t
) == RETURN_EXPR
2754 && TREE_CODE (TREE_OPERAND (t
, 0)) == MODIFY_EXPR
)
2756 tree ret_val
= TREE_OPERAND (TREE_OPERAND (t
, 0), 1), init_expr
;
2758 /* If this is the temporary created for a return value with variable
2759 size in call_to_gnu, we replace the RHS with the init expression. */
2760 if (TREE_CODE (ret_val
) == COMPOUND_EXPR
2761 && TREE_CODE (TREE_OPERAND (ret_val
, 0)) == INIT_EXPR
2762 && TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 0)
2763 == TREE_OPERAND (ret_val
, 1))
2765 init_expr
= TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 1);
2766 ret_val
= TREE_OPERAND (ret_val
, 1);
2769 init_expr
= NULL_TREE
;
2771 /* Strip useless conversions around the return value. */
2772 if (gnat_useless_type_conversion (ret_val
))
2773 ret_val
= TREE_OPERAND (ret_val
, 0);
2775 if (is_nrv_p (dp
->nrv
, ret_val
))
2778 TREE_OPERAND (TREE_OPERAND (t
, 0), 1) = init_expr
;
2780 TREE_OPERAND (t
, 0) = dp
->result
;
2784 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
2786 else if (TREE_CODE (t
) == DECL_EXPR
2787 && is_nrv_p (dp
->nrv
, DECL_EXPR_DECL (t
)))
2789 tree var
= DECL_EXPR_DECL (t
), init
;
2791 if (DECL_INITIAL (var
))
2793 init
= build_binary_op (INIT_EXPR
, NULL_TREE
, dp
->result
,
2794 DECL_INITIAL (var
));
2795 SET_EXPR_LOCATION (init
, EXPR_LOCATION (t
));
2796 DECL_INITIAL (var
) = NULL_TREE
;
2799 init
= build_empty_stmt (EXPR_LOCATION (t
));
2802 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
2803 SET_DECL_VALUE_EXPR (var
, dp
->result
);
2804 DECL_HAS_VALUE_EXPR_P (var
) = 1;
2805 /* ??? Kludge to avoid an assertion failure during inlining. */
2806 DECL_SIZE (var
) = bitsize_unit_node
;
2807 DECL_SIZE_UNIT (var
) = size_one_node
;
2810 /* And replace all uses of NRVs with the RESULT_DECL. */
2811 else if (is_nrv_p (dp
->nrv
, t
))
2812 *tp
= convert (TREE_TYPE (t
), dp
->result
);
2814 /* Avoid walking into the same tree more than once. Unfortunately, we
2815 can't just use walk_tree_without_duplicates because it would only call
2816 us for the first occurrence of NRVs in the function body. */
2817 if (pointer_set_insert (dp
->visited
, *tp
))
2823 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
2824 contains the candidates for Named Return Value and OTHER is a list of
2825 the other return values. */
2828 finalize_nrv (tree fndecl
, bitmap nrv
, VEC(tree
,gc
) *other
)
2830 struct cgraph_node
*node
;
2831 struct nrv_data data
;
2835 /* We shouldn't be applying the optimization to return types that we aren't
2836 allowed to manipulate freely. */
2837 gcc_assert (!TREE_ADDRESSABLE (TREE_TYPE (TREE_TYPE (fndecl
))));
2839 /* Prune the candidates that are referenced by other return values. */
2841 data
.result
= NULL_TREE
;
2842 data
.visited
= NULL
;
2843 for (i
= 0; VEC_iterate(tree
, other
, i
, iter
); i
++)
2844 walk_tree_without_duplicates (&iter
, prune_nrv_r
, &data
);
2845 if (bitmap_empty_p (nrv
))
2848 /* Prune also the candidates that are referenced by nested functions. */
2849 node
= cgraph_get_create_node (fndecl
);
2850 for (node
= node
->nested
; node
; node
= node
->next_nested
)
2851 walk_tree_without_duplicates (&DECL_SAVED_TREE (node
->decl
), prune_nrv_r
,
2853 if (bitmap_empty_p (nrv
))
2856 /* Extract a set of NRVs with non-overlapping live ranges. */
2857 if (!prune_nrv_in_block (nrv
, DECL_INITIAL (fndecl
)))
2860 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
2862 data
.result
= DECL_RESULT (fndecl
);
2863 data
.visited
= pointer_set_create ();
2864 walk_tree (&DECL_SAVED_TREE (fndecl
), finalize_nrv_r
, &data
, NULL
);
2865 pointer_set_destroy (data
.visited
);
2868 /* Return true if RET_VAL can be used as a Named Return Value for the
2869 anonymous return object RET_OBJ. */
2872 return_value_ok_for_nrv_p (tree ret_obj
, tree ret_val
)
2874 if (TREE_CODE (ret_val
) != VAR_DECL
)
2877 if (TREE_THIS_VOLATILE (ret_val
))
2880 if (DECL_CONTEXT (ret_val
) != current_function_decl
)
2883 if (TREE_STATIC (ret_val
))
2886 if (TREE_ADDRESSABLE (ret_val
))
2889 if (DECL_ALIGN (ret_val
) > DECL_ALIGN (ret_obj
))
2895 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
2896 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
2897 around RESULT_OBJ, which may be null in this case. */
2900 build_return_expr (tree ret_obj
, tree ret_val
)
2906 /* The gimplifier explicitly enforces the following invariant:
2915 As a consequence, type consistency dictates that we use the type
2916 of the RET_OBJ as the operation type. */
2917 tree operation_type
= TREE_TYPE (ret_obj
);
2919 /* Convert the right operand to the operation type. Note that it's the
2920 same transformation as in the MODIFY_EXPR case of build_binary_op,
2921 with the assumption that the type cannot involve a placeholder. */
2922 if (operation_type
!= TREE_TYPE (ret_val
))
2923 ret_val
= convert (operation_type
, ret_val
);
2925 result_expr
= build2 (MODIFY_EXPR
, void_type_node
, ret_obj
, ret_val
);
2927 /* If the function returns an aggregate type, find out whether this is
2928 a candidate for Named Return Value. If so, record it. Otherwise,
2929 if this is an expression of some kind, record it elsewhere. */
2931 && AGGREGATE_TYPE_P (operation_type
)
2932 && !TYPE_IS_FAT_POINTER_P (operation_type
)
2933 && aggregate_value_p (operation_type
, current_function_decl
))
2935 /* Recognize the temporary created for a return value with variable
2936 size in call_to_gnu. We want to eliminate it if possible. */
2937 if (TREE_CODE (ret_val
) == COMPOUND_EXPR
2938 && TREE_CODE (TREE_OPERAND (ret_val
, 0)) == INIT_EXPR
2939 && TREE_OPERAND (TREE_OPERAND (ret_val
, 0), 0)
2940 == TREE_OPERAND (ret_val
, 1))
2941 ret_val
= TREE_OPERAND (ret_val
, 1);
2943 /* Strip useless conversions around the return value. */
2944 if (gnat_useless_type_conversion (ret_val
))
2945 ret_val
= TREE_OPERAND (ret_val
, 0);
2947 /* Now apply the test to the return value. */
2948 if (return_value_ok_for_nrv_p (ret_obj
, ret_val
))
2950 if (!f_named_ret_val
)
2951 f_named_ret_val
= BITMAP_GGC_ALLOC ();
2952 bitmap_set_bit (f_named_ret_val
, DECL_UID (ret_val
));
2955 /* Note that we need not care about CONSTRUCTORs here, as they are
2956 totally transparent given the read-compose-write semantics of
2957 assignments from CONSTRUCTORs. */
2958 else if (EXPR_P (ret_val
))
2959 VEC_safe_push (tree
, gc
, f_other_ret_val
, ret_val
);
2963 result_expr
= ret_obj
;
2965 return build1 (RETURN_EXPR
, void_type_node
, result_expr
);
2968 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
2969 and the GNAT node GNAT_SUBPROG. */
2972 build_function_stub (tree gnu_subprog
, Entity_Id gnat_subprog
)
2974 tree gnu_subprog_type
, gnu_subprog_addr
, gnu_subprog_call
;
2975 tree gnu_subprog_param
, gnu_stub_param
, gnu_param
;
2976 tree gnu_stub_decl
= DECL_FUNCTION_STUB (gnu_subprog
);
2977 VEC(tree
,gc
) *gnu_param_vec
= NULL
;
2979 gnu_subprog_type
= TREE_TYPE (gnu_subprog
);
2981 /* Initialize the information structure for the function. */
2982 allocate_struct_function (gnu_stub_decl
, false);
2985 begin_subprog_body (gnu_stub_decl
);
2987 start_stmt_group ();
2990 /* Loop over the parameters of the stub and translate any of them
2991 passed by descriptor into a by reference one. */
2992 for (gnu_stub_param
= DECL_ARGUMENTS (gnu_stub_decl
),
2993 gnu_subprog_param
= DECL_ARGUMENTS (gnu_subprog
);
2995 gnu_stub_param
= DECL_CHAIN (gnu_stub_param
),
2996 gnu_subprog_param
= DECL_CHAIN (gnu_subprog_param
))
2998 if (DECL_BY_DESCRIPTOR_P (gnu_stub_param
))
3000 gcc_assert (DECL_BY_REF_P (gnu_subprog_param
));
3002 = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param
),
3004 DECL_PARM_ALT_TYPE (gnu_stub_param
),
3005 DECL_BY_DOUBLE_REF_P (gnu_subprog_param
),
3009 gnu_param
= gnu_stub_param
;
3011 VEC_safe_push (tree
, gc
, gnu_param_vec
, gnu_param
);
3014 /* Invoke the internal subprogram. */
3015 gnu_subprog_addr
= build1 (ADDR_EXPR
, build_pointer_type (gnu_subprog_type
),
3017 gnu_subprog_call
= build_call_vec (TREE_TYPE (gnu_subprog_type
),
3018 gnu_subprog_addr
, gnu_param_vec
);
3020 /* Propagate the return value, if any. */
3021 if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type
)))
3022 add_stmt (gnu_subprog_call
);
3024 add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl
),
3028 end_subprog_body (end_stmt_group ());
3029 rest_of_subprog_body_compilation (gnu_stub_decl
);
3032 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3033 don't return anything. */
3036 Subprogram_Body_to_gnu (Node_Id gnat_node
)
3038 /* Defining identifier of a parameter to the subprogram. */
3039 Entity_Id gnat_param
;
3040 /* The defining identifier for the subprogram body. Note that if a
3041 specification has appeared before for this body, then the identifier
3042 occurring in that specification will also be a defining identifier and all
3043 the calls to this subprogram will point to that specification. */
3044 Entity_Id gnat_subprog_id
3045 = (Present (Corresponding_Spec (gnat_node
))
3046 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
3047 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3048 tree gnu_subprog_decl
;
3049 /* Its RESULT_DECL node. */
3050 tree gnu_result_decl
;
3051 /* Its FUNCTION_TYPE node. */
3052 tree gnu_subprog_type
;
3053 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3055 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3056 tree gnu_return_var_elmt
= NULL_TREE
;
3058 struct language_function
*gnu_subprog_language
;
3059 VEC(parm_attr
,gc
) *cache
;
3061 /* If this is a generic object or if it has been eliminated,
3063 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
3064 || Ekind (gnat_subprog_id
) == E_Generic_Function
3065 || Is_Eliminated (gnat_subprog_id
))
3068 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3069 the already-elaborated tree node. However, if this subprogram had its
3070 elaboration deferred, we will already have made a tree node for it. So
3071 treat it as not being defined in that case. Such a subprogram cannot
3072 have an address clause or a freeze node, so this test is safe, though it
3073 does disable some otherwise-useful error checking. */
3075 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
3076 Acts_As_Spec (gnat_node
)
3077 && !present_gnu_tree (gnat_subprog_id
));
3078 gnu_result_decl
= DECL_RESULT (gnu_subprog_decl
);
3079 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
3080 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3082 gnu_return_var_elmt
= value_member (void_type_node
, gnu_cico_list
);
3084 /* If the function returns by invisible reference, make it explicit in the
3085 function body. See gnat_to_gnu_entity, E_Subprogram_Type case.
3086 Handle the explicit case here and the copy-in/copy-out case below. */
3087 if (TREE_ADDRESSABLE (gnu_subprog_type
) && !gnu_return_var_elmt
)
3089 TREE_TYPE (gnu_result_decl
)
3090 = build_reference_type (TREE_TYPE (gnu_result_decl
));
3091 relayout_decl (gnu_result_decl
);
3094 /* Set the line number in the decl to correspond to that of the body so that
3095 the line number notes are written correctly. */
3096 Sloc_to_locus (Sloc (gnat_node
), &DECL_SOURCE_LOCATION (gnu_subprog_decl
));
3098 /* Initialize the information structure for the function. */
3099 allocate_struct_function (gnu_subprog_decl
, false);
3100 gnu_subprog_language
= ggc_alloc_cleared_language_function ();
3101 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->language
= gnu_subprog_language
;
3104 begin_subprog_body (gnu_subprog_decl
);
3106 /* If there are In Out or Out parameters, we need to ensure that the return
3107 statement properly copies them out. We do this by making a new block and
3108 converting any return into a goto to a label at the end of the block. */
3111 tree gnu_return_var
= NULL_TREE
;
3113 VEC_safe_push (tree
, gc
, gnu_return_label_stack
,
3114 create_artificial_label (input_location
));
3116 start_stmt_group ();
3119 /* If this is a function with In Out or Out parameters, we also need a
3120 variable for the return value to be placed. */
3121 if (gnu_return_var_elmt
)
3123 tree gnu_return_type
3124 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt
));
3126 /* If the function returns by invisible reference, make it
3127 explicit in the function body. See gnat_to_gnu_entity,
3128 E_Subprogram_Type case. */
3129 if (TREE_ADDRESSABLE (gnu_subprog_type
))
3130 gnu_return_type
= build_reference_type (gnu_return_type
);
3133 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE
,
3134 gnu_return_type
, NULL_TREE
, false, false,
3135 false, false, NULL
, gnat_subprog_id
);
3136 TREE_VALUE (gnu_return_var_elmt
) = gnu_return_var
;
3139 VEC_safe_push (tree
, gc
, gnu_return_var_stack
, gnu_return_var
);
3141 /* See whether there are parameters for which we don't have a GCC tree
3142 yet. These must be Out parameters. Make a VAR_DECL for them and
3143 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3144 We can match up the entries because TYPE_CI_CO_LIST is in the order
3145 of the parameters. */
3146 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
3147 Present (gnat_param
);
3148 gnat_param
= Next_Formal_With_Extras (gnat_param
))
3149 if (!present_gnu_tree (gnat_param
))
3151 tree gnu_cico_entry
= gnu_cico_list
;
3153 /* Skip any entries that have been already filled in; they must
3154 correspond to In Out parameters. */
3155 while (gnu_cico_entry
&& TREE_VALUE (gnu_cico_entry
))
3156 gnu_cico_entry
= TREE_CHAIN (gnu_cico_entry
);
3158 /* Do any needed references for padded types. */
3159 TREE_VALUE (gnu_cico_entry
)
3160 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry
)),
3161 gnat_to_gnu_entity (gnat_param
, NULL_TREE
, 1));
3165 VEC_safe_push (tree
, gc
, gnu_return_label_stack
, NULL_TREE
);
3167 /* Get a tree corresponding to the code for the subprogram. */
3168 start_stmt_group ();
3171 /* On VMS, establish our condition handler to possibly turn a condition into
3172 the corresponding exception if the subprogram has a foreign convention or
3175 To ensure proper execution of local finalizations on condition instances,
3176 we must turn a condition into the corresponding exception even if there
3177 is no applicable Ada handler, and need at least one condition handler per
3178 possible call chain involving GNAT code. OTOH, establishing the handler
3179 has a cost so we want to minimize the number of subprograms into which
3180 this happens. The foreign or exported condition is expected to satisfy
3181 all the constraints. */
3182 if (TARGET_ABI_OPEN_VMS
3183 && (Has_Foreign_Convention (gnat_subprog_id
)
3184 || Is_Exported (gnat_subprog_id
)))
3185 establish_gnat_vms_condition_handler ();
3187 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
3189 /* Generate the code of the subprogram itself. A return statement will be
3190 present and any Out parameters will be handled there. */
3191 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
3193 gnu_result
= end_stmt_group ();
3195 /* If we populated the parameter attributes cache, we need to make sure that
3196 the cached expressions are evaluated on all the possible paths leading to
3197 their uses. So we force their evaluation on entry of the function. */
3198 cache
= gnu_subprog_language
->parm_attr_cache
;
3201 struct parm_attr_d
*pa
;
3204 start_stmt_group ();
3206 FOR_EACH_VEC_ELT (parm_attr
, cache
, i
, pa
)
3209 add_stmt_with_node_force (pa
->first
, gnat_node
);
3211 add_stmt_with_node_force (pa
->last
, gnat_node
);
3213 add_stmt_with_node_force (pa
->length
, gnat_node
);
3216 add_stmt (gnu_result
);
3217 gnu_result
= end_stmt_group ();
3219 gnu_subprog_language
->parm_attr_cache
= NULL
;
3222 /* If we are dealing with a return from an Ada procedure with parameters
3223 passed by copy-in/copy-out, we need to return a record containing the
3224 final values of these parameters. If the list contains only one entry,
3225 return just that entry though.
3227 For a full description of the copy-in/copy-out parameter mechanism, see
3228 the part of the gnat_to_gnu_entity routine dealing with the translation
3231 We need to make a block that contains the definition of that label and
3232 the copying of the return value. It first contains the function, then
3233 the label and copy statement. */
3238 add_stmt (gnu_result
);
3239 add_stmt (build1 (LABEL_EXPR
, void_type_node
,
3240 VEC_last (tree
, gnu_return_label_stack
)));
3242 if (list_length (gnu_cico_list
) == 1)
3243 gnu_retval
= TREE_VALUE (gnu_cico_list
);
3245 gnu_retval
= build_constructor_from_list (TREE_TYPE (gnu_subprog_type
),
3248 add_stmt_with_node (build_return_expr (gnu_result_decl
, gnu_retval
),
3249 End_Label (Handled_Statement_Sequence (gnat_node
)));
3251 gnu_result
= end_stmt_group ();
3254 VEC_pop (tree
, gnu_return_label_stack
);
3256 /* Attempt setting the end_locus of our GCC body tree, typically a
3257 BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
3258 declaration tree. */
3259 set_end_locus_from_node (gnu_result
, gnat_node
);
3260 set_end_locus_from_node (gnu_subprog_decl
, gnat_node
);
3262 end_subprog_body (gnu_result
);
3264 /* Finally annotate the parameters and disconnect the trees for parameters
3265 that we have turned into variables since they are now unusable. */
3266 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
3267 Present (gnat_param
);
3268 gnat_param
= Next_Formal_With_Extras (gnat_param
))
3270 tree gnu_param
= get_gnu_tree (gnat_param
);
3271 bool is_var_decl
= (TREE_CODE (gnu_param
) == VAR_DECL
);
3273 annotate_object (gnat_param
, TREE_TYPE (gnu_param
), NULL_TREE
,
3274 DECL_BY_REF_P (gnu_param
),
3275 !is_var_decl
&& DECL_BY_DOUBLE_REF_P (gnu_param
));
3278 save_gnu_tree (gnat_param
, NULL_TREE
, false);
3281 if (gnu_return_var_elmt
)
3282 TREE_VALUE (gnu_return_var_elmt
) = void_type_node
;
3284 /* If the function returns an aggregate type and we have candidates for
3285 a Named Return Value, finalize the optimization. */
3286 if (optimize
&& gnu_subprog_language
->named_ret_val
)
3288 finalize_nrv (gnu_subprog_decl
, gnu_subprog_language
->named_ret_val
,
3289 gnu_subprog_language
->other_ret_val
);
3290 gnu_subprog_language
->named_ret_val
= NULL
;
3291 gnu_subprog_language
->other_ret_val
= NULL
;
3294 rest_of_subprog_body_compilation (gnu_subprog_decl
);
3296 /* If there is a stub associated with the function, build it now. */
3297 if (DECL_FUNCTION_STUB (gnu_subprog_decl
))
3298 build_function_stub (gnu_subprog_decl
, gnat_subprog_id
);
3300 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node
)));
3303 /* Return true if GNAT_NODE requires atomic synchronization. */
3306 atomic_sync_required_p (Node_Id gnat_node
)
3308 const Node_Id gnat_parent
= Parent (gnat_node
);
3310 unsigned char attr_id
;
3312 /* First, scan the node to find the Atomic_Sync_Required flag. */
3313 kind
= Nkind (gnat_node
);
3314 if (kind
== N_Type_Conversion
|| kind
== N_Unchecked_Type_Conversion
)
3316 gnat_node
= Expression (gnat_node
);
3317 kind
= Nkind (gnat_node
);
3322 case N_Expanded_Name
:
3323 case N_Explicit_Dereference
:
3325 case N_Indexed_Component
:
3326 case N_Selected_Component
:
3327 if (!Atomic_Sync_Required (gnat_node
))
3335 /* Then, scan the parent to find out cases where the flag is irrelevant. */
3336 kind
= Nkind (gnat_parent
);
3339 case N_Attribute_Reference
:
3340 attr_id
= Get_Attribute_Id (Attribute_Name (gnat_parent
));
3341 /* Do not mess up machine code insertions. */
3342 if (attr_id
== Attr_Asm_Input
|| attr_id
== Attr_Asm_Output
)
3346 case N_Object_Renaming_Declaration
:
3347 /* Do not generate a function call as a renamed object. */
3357 /* Create a temporary variable with PREFIX and TYPE, and return it. */
3360 create_temporary (const char *prefix
, tree type
)
3362 tree gnu_temp
= create_var_decl (create_tmp_var_name (prefix
), NULL_TREE
,
3363 type
, NULL_TREE
, false, false, false, false,
3365 DECL_ARTIFICIAL (gnu_temp
) = 1;
3366 DECL_IGNORED_P (gnu_temp
) = 1;
3371 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
3372 Put the initialization statement into GNU_INIT_STMT and annotate it with
3373 the SLOC of GNAT_NODE. Return the temporary variable. */
3376 create_init_temporary (const char *prefix
, tree gnu_init
, tree
*gnu_init_stmt
,
3379 tree gnu_temp
= create_temporary (prefix
, TREE_TYPE (gnu_init
));
3381 *gnu_init_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_temp
, gnu_init
);
3382 set_expr_location_from_node (*gnu_init_stmt
, gnat_node
);
3387 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
3388 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
3389 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
3390 If GNU_TARGET is non-null, this must be a function call on the RHS of a
3391 N_Assignment_Statement and the result is to be placed into that object.
3392 If, in addition, ATOMIC_SYNC is true, then the assignment to GNU_TARGET
3393 requires atomic synchronization. */
3396 call_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, tree gnu_target
,
3399 const bool function_call
= (Nkind (gnat_node
) == N_Function_Call
);
3400 const bool returning_value
= (function_call
&& !gnu_target
);
3401 /* The GCC node corresponding to the GNAT subprogram name. This can either
3402 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
3403 or an indirect reference expression (an INDIRECT_REF node) pointing to a
3405 tree gnu_subprog
= gnat_to_gnu (Name (gnat_node
));
3406 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
3407 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog
);
3408 /* The return type of the FUNCTION_TYPE. */
3409 tree gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
3410 tree gnu_subprog_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog
);
3411 VEC(tree
,gc
) *gnu_actual_vec
= NULL
;
3412 tree gnu_name_list
= NULL_TREE
;
3413 tree gnu_stmt_list
= NULL_TREE
;
3414 tree gnu_after_list
= NULL_TREE
;
3415 tree gnu_retval
= NULL_TREE
;
3416 tree gnu_call
, gnu_result
;
3417 bool went_into_elab_proc
= false;
3418 bool pushed_binding_level
= false;
3419 Entity_Id gnat_formal
;
3420 Node_Id gnat_actual
;
3422 gcc_assert (TREE_CODE (gnu_subprog_type
) == FUNCTION_TYPE
);
3424 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
3425 all our args first. */
3426 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
&& DECL_STUBBED_P (gnu_subprog
))
3428 tree call_expr
= build_call_raise (PE_Stubbed_Subprogram_Called
,
3429 gnat_node
, N_Raise_Program_Error
);
3431 for (gnat_actual
= First_Actual (gnat_node
);
3432 Present (gnat_actual
);
3433 gnat_actual
= Next_Actual (gnat_actual
))
3434 add_stmt (gnat_to_gnu (gnat_actual
));
3436 if (returning_value
)
3438 *gnu_result_type_p
= gnu_result_type
;
3439 return build1 (NULL_EXPR
, gnu_result_type
, call_expr
);
3445 /* The only way we can be making a call via an access type is if Name is an
3446 explicit dereference. In that case, get the list of formal args from the
3447 type the access type is pointing to. Otherwise, get the formals from the
3448 entity being called. */
3449 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3450 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
3451 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
3452 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
3453 gnat_formal
= Empty
;
3455 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
3457 /* The lifetime of the temporaries created for the call ends right after the
3458 return value is copied, so we can give them the scope of the elaboration
3459 routine at top level. */
3460 if (!current_function_decl
)
3462 current_function_decl
= get_elaboration_procedure ();
3463 went_into_elab_proc
= true;
3466 /* First, create the temporary for the return value if we need it: for a
3467 variable-sized return type if there is no target or if this is slice,
3468 because the gimplifier doesn't support these cases; or for a function
3469 with copy-in/copy-out parameters if there is no target, because we'll
3470 need to preserve the return value before copying back the parameters.
3471 This must be done before we push a new binding level around the call
3472 as we will pop it before copying the return value. */
3474 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3475 && (!gnu_target
|| TREE_CODE (gnu_target
) == ARRAY_RANGE_REF
))
3476 || (!gnu_target
&& TYPE_CI_CO_LIST (gnu_subprog_type
))))
3477 gnu_retval
= create_temporary ("R", gnu_result_type
);
3479 /* Create the list of the actual parameters as GCC expects it, namely a
3480 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
3481 is an expression and the TREE_PURPOSE field is null. But skip Out
3482 parameters not passed by reference and that need not be copied in. */
3483 for (gnat_actual
= First_Actual (gnat_node
);
3484 Present (gnat_actual
);
3485 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3486 gnat_actual
= Next_Actual (gnat_actual
))
3488 tree gnu_formal
= present_gnu_tree (gnat_formal
)
3489 ? get_gnu_tree (gnat_formal
) : NULL_TREE
;
3490 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
3491 const bool is_true_formal_parm
3492 = gnu_formal
&& TREE_CODE (gnu_formal
) == PARM_DECL
;
3493 const bool is_by_ref_formal_parm
3494 = is_true_formal_parm
3495 && (DECL_BY_REF_P (gnu_formal
)
3496 || DECL_BY_COMPONENT_PTR_P (gnu_formal
)
3497 || DECL_BY_DESCRIPTOR_P (gnu_formal
));
3498 /* In the Out or In Out case, we must suppress conversions that yield
3499 an lvalue but can nevertheless cause the creation of a temporary,
3500 because we need the real object in this case, either to pass its
3501 address if it's passed by reference or as target of the back copy
3502 done after the call if it uses the copy-in/copy-out mechanism.
3503 We do it in the In case too, except for an unchecked conversion
3504 because it alone can cause the actual to be misaligned and the
3505 addressability test is applied to the real object. */
3506 const bool suppress_type_conversion
3507 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
3508 && Ekind (gnat_formal
) != E_In_Parameter
)
3509 || (Nkind (gnat_actual
) == N_Type_Conversion
3510 && Is_Composite_Type (Underlying_Type (Etype (gnat_formal
)))));
3511 Node_Id gnat_name
= suppress_type_conversion
3512 ? Expression (gnat_actual
) : gnat_actual
;
3513 tree gnu_name
= gnat_to_gnu (gnat_name
), gnu_name_type
;
3516 /* If it's possible we may need to use this expression twice, make sure
3517 that any side-effects are handled via SAVE_EXPRs; likewise if we need
3518 to force side-effects before the call.
3519 ??? This is more conservative than we need since we don't need to do
3520 this for pass-by-ref with no conversion. */
3521 if (Ekind (gnat_formal
) != E_In_Parameter
)
3522 gnu_name
= gnat_stabilize_reference (gnu_name
, true, NULL
);
3524 /* If we are passing a non-addressable parameter by reference, pass the
3525 address of a copy. In the Out or In Out case, set up to copy back
3526 out after the call. */
3527 if (is_by_ref_formal_parm
3528 && (gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
)))
3529 && !addressable_p (gnu_name
, gnu_name_type
))
3531 bool in_param
= (Ekind (gnat_formal
) == E_In_Parameter
);
3532 tree gnu_orig
= gnu_name
, gnu_temp
, gnu_stmt
;
3534 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
3535 but sort of an instantiation for them. */
3536 if (TREE_CODE (gnu_name
) == CONSTRUCTOR
)
3539 /* If the type is passed by reference, a copy is not allowed. */
3540 else if (TREE_ADDRESSABLE (gnu_formal_type
))
3541 post_error ("misaligned actual cannot be passed by reference",
3544 /* For users of Starlet we issue a warning because the interface
3545 apparently assumes that by-ref parameters outlive the procedure
3546 invocation. The code still will not work as intended, but we
3547 cannot do much better since low-level parts of the back-end
3548 would allocate temporaries at will because of the misalignment
3549 if we did not do so here. */
3550 else if (Is_Valued_Procedure (Entity (Name (gnat_node
))))
3553 ("?possible violation of implicit assumption", gnat_actual
);
3555 ("?made by pragma Import_Valued_Procedure on &", gnat_actual
,
3556 Entity (Name (gnat_node
)));
3557 post_error_ne ("?because of misalignment of &", gnat_actual
,
3561 /* If the actual type of the object is already the nominal type,
3562 we have nothing to do, except if the size is self-referential
3563 in which case we'll remove the unpadding below. */
3564 if (TREE_TYPE (gnu_name
) == gnu_name_type
3565 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type
)))
3568 /* Otherwise remove the unpadding from all the objects. */
3569 else if (TREE_CODE (gnu_name
) == COMPONENT_REF
3570 && TYPE_IS_PADDING_P
3571 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))
3572 gnu_orig
= gnu_name
= TREE_OPERAND (gnu_name
, 0);
3574 /* Otherwise convert to the nominal type of the object if needed.
3575 There are several cases in which we need to make the temporary
3576 using this type instead of the actual type of the object when
3577 they are distinct, because the expectations of the callee would
3578 otherwise not be met:
3579 - if it's a justified modular type,
3580 - if the actual type is a smaller form of it,
3581 - if it's a smaller form of the actual type. */
3582 else if ((TREE_CODE (gnu_name_type
) == RECORD_TYPE
3583 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type
)
3584 || smaller_form_type_p (TREE_TYPE (gnu_name
),
3586 || (INTEGRAL_TYPE_P (gnu_name_type
)
3587 && smaller_form_type_p (gnu_name_type
,
3588 TREE_TYPE (gnu_name
))))
3589 gnu_name
= convert (gnu_name_type
, gnu_name
);
3591 /* If this is an In Out or Out parameter and we're returning a value,
3592 we need to create a temporary for the return value because we must
3593 preserve it before copying back at the very end. */
3594 if (!in_param
&& returning_value
&& !gnu_retval
)
3595 gnu_retval
= create_temporary ("R", gnu_result_type
);
3597 /* If we haven't pushed a binding level, push a new one. This will
3598 narrow the lifetime of the temporary we are about to make as much
3599 as possible. The drawback is that we'd need to create a temporary
3600 for the return value, if any (see comment before the loop). So do
3601 it only when this temporary was already created just above. */
3602 if (!pushed_binding_level
&& !(in_param
&& returning_value
))
3604 start_stmt_group ();
3606 pushed_binding_level
= true;
3609 /* Create an explicit temporary holding the copy. */
3611 = create_init_temporary ("A", gnu_name
, &gnu_stmt
, gnat_actual
);
3613 /* But initialize it on the fly like for an implicit temporary as
3614 we aren't necessarily having a statement list. */
3615 gnu_name
= build_compound_expr (TREE_TYPE (gnu_name
), gnu_stmt
,
3618 /* Set up to move the copy back to the original if needed. */
3621 gnu_stmt
= build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_orig
,
3623 set_expr_location_from_node (gnu_stmt
, gnat_node
);
3624 append_to_statement_list (gnu_stmt
, &gnu_after_list
);
3628 /* Start from the real object and build the actual. */
3629 gnu_actual
= gnu_name
;
3631 /* If this is an atomic access of an In or In Out parameter for which
3632 synchronization is required, build the atomic load. */
3633 if (is_true_formal_parm
3634 && !is_by_ref_formal_parm
3635 && Ekind (gnat_formal
) != E_Out_Parameter
3636 && atomic_sync_required_p (gnat_actual
))
3637 gnu_actual
= build_atomic_load (gnu_actual
);
3639 /* If this was a procedure call, we may not have removed any padding.
3640 So do it here for the part we will use as an input, if any. */
3641 if (Ekind (gnat_formal
) != E_Out_Parameter
3642 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
3644 = convert (get_unpadded_type (Etype (gnat_actual
)), gnu_actual
);
3646 /* Put back the conversion we suppressed above in the computation of the
3647 real object. And even if we didn't suppress any conversion there, we
3648 may have suppressed a conversion to the Etype of the actual earlier,
3649 since the parent is a procedure call, so put it back here. */
3650 if (suppress_type_conversion
3651 && Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
3653 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
3654 gnu_actual
, No_Truncation (gnat_actual
));
3657 = convert (gnat_to_gnu_type (Etype (gnat_actual
)), gnu_actual
);
3659 /* Make sure that the actual is in range of the formal's type. */
3660 if (Ekind (gnat_formal
) != E_Out_Parameter
3661 && Do_Range_Check (gnat_actual
))
3663 = emit_range_check (gnu_actual
, Etype (gnat_formal
), gnat_actual
);
3665 /* Unless this is an In parameter, we must remove any justified modular
3666 building from GNU_NAME to get an lvalue. */
3667 if (Ekind (gnat_formal
) != E_In_Parameter
3668 && TREE_CODE (gnu_name
) == CONSTRUCTOR
3669 && TREE_CODE (TREE_TYPE (gnu_name
)) == RECORD_TYPE
3670 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name
)))
3672 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name
))), gnu_name
);
3674 /* If we have not saved a GCC object for the formal, it means it is an
3675 Out parameter not passed by reference and that need not be copied in.
3676 Otherwise, first see if the parameter is passed by reference. */
3677 if (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
))
3679 if (Ekind (gnat_formal
) != E_In_Parameter
)
3681 /* In Out or Out parameters passed by reference don't use the
3682 copy-in/copy-out mechanism so the address of the real object
3683 must be passed to the function. */
3684 gnu_actual
= gnu_name
;
3686 /* If we have a padded type, be sure we've removed padding. */
3687 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
3688 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
3691 /* If we have the constructed subtype of an aliased object
3692 with an unconstrained nominal subtype, the type of the
3693 actual includes the template, although it is formally
3694 constrained. So we need to convert it back to the real
3695 constructed subtype to retrieve the constrained part
3696 and takes its address. */
3697 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
3698 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual
))
3699 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual
))
3700 && Is_Array_Type (Etype (gnat_actual
)))
3701 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
3705 /* There is no need to convert the actual to the formal's type before
3706 taking its address. The only exception is for unconstrained array
3707 types because of the way we build fat pointers. */
3708 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
3710 /* Put back a view conversion for In Out or Out parameters. */
3711 if (Ekind (gnat_formal
) != E_In_Parameter
)
3712 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
3714 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3717 /* The symmetry of the paths to the type of an entity is broken here
3718 since arguments don't know that they will be passed by ref. */
3719 gnu_formal_type
= TREE_TYPE (gnu_formal
);
3721 if (DECL_BY_DOUBLE_REF_P (gnu_formal
))
3723 = build_unary_op (ADDR_EXPR
, TREE_TYPE (gnu_formal_type
),
3726 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
3728 else if (is_true_formal_parm
&& DECL_BY_COMPONENT_PTR_P (gnu_formal
))
3730 gnu_formal_type
= TREE_TYPE (gnu_formal
);
3731 gnu_actual
= maybe_implicit_deref (gnu_actual
);
3732 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
3734 if (TYPE_IS_PADDING_P (gnu_formal_type
))
3736 gnu_formal_type
= TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
3737 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3740 /* Take the address of the object and convert to the proper pointer
3741 type. We'd like to actually compute the address of the beginning
3742 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
3743 possibility that the ARRAY_REF might return a constant and we'd be
3744 getting the wrong address. Neither approach is exactly correct,
3745 but this is the most likely to work in all cases. */
3746 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
3748 else if (is_true_formal_parm
&& DECL_BY_DESCRIPTOR_P (gnu_formal
))
3750 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3752 /* If this is 'Null_Parameter, pass a zero descriptor. */
3753 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
3754 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
3755 && TREE_PRIVATE (gnu_actual
))
3757 = convert (DECL_ARG_TYPE (gnu_formal
), integer_zero_node
);
3759 gnu_actual
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
3761 (TREE_TYPE (TREE_TYPE (gnu_formal
)),
3762 gnu_actual
, gnat_actual
));
3768 if (Ekind (gnat_formal
) != E_In_Parameter
)
3769 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
3771 if (!is_true_formal_parm
)
3773 /* Make sure side-effects are evaluated before the call. */
3774 if (TREE_SIDE_EFFECTS (gnu_name
))
3775 append_to_statement_list (gnu_name
, &gnu_stmt_list
);
3779 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3781 /* If this is 'Null_Parameter, pass a zero even though we are
3782 dereferencing it. */
3783 if (TREE_CODE (gnu_actual
) == INDIRECT_REF
3784 && TREE_PRIVATE (gnu_actual
)
3785 && (gnu_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
)))
3786 && TREE_CODE (gnu_size
) == INTEGER_CST
3787 && compare_tree_int (gnu_size
, BITS_PER_WORD
) <= 0)
3789 = unchecked_convert (DECL_ARG_TYPE (gnu_formal
),
3790 convert (gnat_type_for_size
3791 (TREE_INT_CST_LOW (gnu_size
), 1),
3795 gnu_actual
= convert (DECL_ARG_TYPE (gnu_formal
), gnu_actual
);
3798 VEC_safe_push (tree
, gc
, gnu_actual_vec
, gnu_actual
);
3802 = build_call_vec (gnu_result_type
, gnu_subprog_addr
, gnu_actual_vec
);
3803 set_expr_location_from_node (gnu_call
, gnat_node
);
3805 /* If we have created a temporary for the return value, initialize it. */
3809 = build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_retval
, gnu_call
);
3810 set_expr_location_from_node (gnu_stmt
, gnat_node
);
3811 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
3812 gnu_call
= gnu_retval
;
3815 /* If this is a subprogram with copy-in/copy-out parameters, we need to
3816 unpack the valued returned from the function into the In Out or Out
3817 parameters. We deal with the function return (if this is an Ada
3819 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
3821 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
3822 copy-out parameters. */
3823 tree gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3824 const int length
= list_length (gnu_cico_list
);
3826 /* The call sequence must contain one and only one call, even though the
3827 function is pure. Save the result into a temporary if needed. */
3833 /* If we haven't pushed a binding level, push a new one. This
3834 will narrow the lifetime of the temporary we are about to
3835 make as much as possible. */
3836 if (!pushed_binding_level
)
3838 start_stmt_group ();
3840 pushed_binding_level
= true;
3843 = create_init_temporary ("P", gnu_call
, &gnu_stmt
, gnat_node
);
3844 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
3847 gnu_name_list
= nreverse (gnu_name_list
);
3850 /* The first entry is for the actual return value if this is a
3851 function, so skip it. */
3852 if (TREE_VALUE (gnu_cico_list
) == void_type_node
)
3853 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
3855 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3856 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
3858 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
3860 for (gnat_actual
= First_Actual (gnat_node
);
3861 Present (gnat_actual
);
3862 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3863 gnat_actual
= Next_Actual (gnat_actual
))
3864 /* If we are dealing with a copy-in/copy-out parameter, we must
3865 retrieve its value from the record returned in the call. */
3866 if (!(present_gnu_tree (gnat_formal
)
3867 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3868 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
3869 || (TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3870 && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))
3871 || (DECL_BY_DESCRIPTOR_P
3872 (get_gnu_tree (gnat_formal
))))))))
3873 && Ekind (gnat_formal
) != E_In_Parameter
)
3875 /* Get the value to assign to this Out or In Out parameter. It is
3876 either the result of the function if there is only a single such
3877 parameter or the appropriate field from the record returned. */
3881 : build_component_ref (gnu_call
, NULL_TREE
,
3882 TREE_PURPOSE (gnu_cico_list
), false);
3884 /* If the actual is a conversion, get the inner expression, which
3885 will be the real destination, and convert the result to the
3886 type of the actual parameter. */
3888 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
3890 /* If the result is a padded type, remove the padding. */
3891 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3893 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
3896 /* If the actual is a type conversion, the real target object is
3897 denoted by the inner Expression and we need to convert the
3898 result to the associated type.
3899 We also need to convert our gnu assignment target to this type
3900 if the corresponding GNU_NAME was constructed from the GNAT
3901 conversion node and not from the inner Expression. */
3902 if (Nkind (gnat_actual
) == N_Type_Conversion
)
3905 = convert_with_check
3906 (Etype (Expression (gnat_actual
)), gnu_result
,
3907 Do_Overflow_Check (gnat_actual
),
3908 Do_Range_Check (Expression (gnat_actual
)),
3909 Float_Truncate (gnat_actual
), gnat_actual
);
3911 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal
))))
3912 gnu_actual
= convert (TREE_TYPE (gnu_result
), gnu_actual
);
3915 /* Unchecked conversions as actuals for Out parameters are not
3916 allowed in user code because they are not variables, but do
3917 occur in front-end expansions. The associated GNU_NAME is
3918 always obtained from the inner expression in such cases. */
3919 else if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
3920 gnu_result
= unchecked_convert (TREE_TYPE (gnu_actual
),
3922 No_Truncation (gnat_actual
));
3925 if (Do_Range_Check (gnat_actual
))
3927 = emit_range_check (gnu_result
, Etype (gnat_actual
),
3930 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
3931 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
3932 gnu_result
= convert (TREE_TYPE (gnu_actual
), gnu_result
);
3935 if (atomic_sync_required_p (gnat_actual
))
3936 gnu_result
= build_atomic_store (gnu_actual
, gnu_result
);
3938 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3939 gnu_actual
, gnu_result
);
3940 set_expr_location_from_node (gnu_result
, gnat_node
);
3941 append_to_statement_list (gnu_result
, &gnu_stmt_list
);
3942 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
3943 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
3947 /* If this is a function call, the result is the call expression unless a
3948 target is specified, in which case we copy the result into the target
3949 and return the assignment statement. */
3952 /* If this is a function with copy-in/copy-out parameters, extract the
3953 return value from it and update the return type. */
3954 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
3956 tree gnu_elmt
= value_member (void_type_node
,
3957 TYPE_CI_CO_LIST (gnu_subprog_type
));
3958 gnu_call
= build_component_ref (gnu_call
, NULL_TREE
,
3959 TREE_PURPOSE (gnu_elmt
), false);
3960 gnu_result_type
= TREE_TYPE (gnu_call
);
3963 /* If the function returns an unconstrained array or by direct reference,
3964 we have to dereference the pointer. */
3965 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
)
3966 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
))
3967 gnu_call
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_call
);
3971 Node_Id gnat_parent
= Parent (gnat_node
);
3972 enum tree_code op_code
;
3974 /* If range check is needed, emit code to generate it. */
3975 if (Do_Range_Check (gnat_node
))
3977 = emit_range_check (gnu_call
, Etype (Name (gnat_parent
)),
3980 /* ??? If the return type has variable size, then force the return
3981 slot optimization as we would not be able to create a temporary.
3982 Likewise if it was unconstrained as we would copy too much data.
3983 That's what has been done historically. */
3984 if (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3985 || (TYPE_IS_PADDING_P (gnu_result_type
)
3986 && CONTAINS_PLACEHOLDER_P
3987 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type
))))))
3988 op_code
= INIT_EXPR
;
3990 op_code
= MODIFY_EXPR
;
3993 gnu_call
= build_atomic_store (gnu_target
, gnu_call
);
3996 = build_binary_op (op_code
, NULL_TREE
, gnu_target
, gnu_call
);
3997 set_expr_location_from_node (gnu_call
, gnat_parent
);
3998 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
4001 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
4004 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
4005 parameters, the result is just the call statement. */
4006 else if (!TYPE_CI_CO_LIST (gnu_subprog_type
))
4007 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
4009 /* Finally, add the copy back statements, if any. */
4010 append_to_statement_list (gnu_after_list
, &gnu_stmt_list
);
4012 if (went_into_elab_proc
)
4013 current_function_decl
= NULL_TREE
;
4015 /* If we have pushed a binding level, pop it and finish up the enclosing
4017 if (pushed_binding_level
)
4019 add_stmt (gnu_stmt_list
);
4021 gnu_result
= end_stmt_group ();
4024 /* Otherwise, retrieve the statement list, if any. */
4025 else if (gnu_stmt_list
)
4026 gnu_result
= gnu_stmt_list
;
4028 /* Otherwise, just return the call expression. */
4032 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
4033 But first simplify if we have only one statement in the list. */
4034 if (returning_value
)
4036 tree first
= expr_first (gnu_result
), last
= expr_last (gnu_result
);
4040 = build_compound_expr (TREE_TYPE (gnu_call
), gnu_result
, gnu_call
);
4046 /* Subroutine of gnat_to_gnu to translate gnat_node, an
4047 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
4050 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node
)
4052 tree gnu_jmpsave_decl
= NULL_TREE
;
4053 tree gnu_jmpbuf_decl
= NULL_TREE
;
4054 /* If just annotating, ignore all EH and cleanups. */
4055 bool gcc_zcx
= (!type_annotate_only
4056 && Present (Exception_Handlers (gnat_node
))
4057 && Exception_Mechanism
== Back_End_Exceptions
);
4059 = (!type_annotate_only
&& Present (Exception_Handlers (gnat_node
))
4060 && Exception_Mechanism
== Setjmp_Longjmp
);
4061 bool at_end
= !type_annotate_only
&& Present (At_End_Proc (gnat_node
));
4062 bool binding_for_block
= (at_end
|| gcc_zcx
|| setjmp_longjmp
);
4063 tree gnu_inner_block
; /* The statement(s) for the block itself. */
4068 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
4069 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
4070 add_cleanup, and when we leave the binding, end_stmt_group will create
4071 the TRY_FINALLY_EXPR.
4073 ??? The region level calls down there have been specifically put in place
4074 for a ZCX context and currently the order in which things are emitted
4075 (region/handlers) is different from the SJLJ case. Instead of putting
4076 other calls with different conditions at other places for the SJLJ case,
4077 it seems cleaner to reorder things for the SJLJ case and generalize the
4078 condition to make it not ZCX specific.
4080 If there are any exceptions or cleanup processing involved, we need an
4081 outer statement group (for Setjmp_Longjmp) and binding level. */
4082 if (binding_for_block
)
4084 start_stmt_group ();
4088 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
4089 area for address of previous buffer. Do this first since we need to have
4090 the setjmp buf known for any decls in this block. */
4094 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
4096 build_call_n_expr (get_jmpbuf_decl
, 0),
4097 false, false, false, false, NULL
, gnat_node
);
4098 DECL_ARTIFICIAL (gnu_jmpsave_decl
) = 1;
4100 /* The __builtin_setjmp receivers will immediately reinstall it. Now
4101 because of the unstructured form of EH used by setjmp_longjmp, there
4102 might be forward edges going to __builtin_setjmp receivers on which
4103 it is uninitialized, although they will never be actually taken. */
4104 TREE_NO_WARNING (gnu_jmpsave_decl
) = 1;
4106 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE
,
4109 false, false, false, false, NULL
, gnat_node
);
4110 DECL_ARTIFICIAL (gnu_jmpbuf_decl
) = 1;
4112 set_block_jmpbuf_decl (gnu_jmpbuf_decl
);
4114 /* When we exit this block, restore the saved value. */
4115 add_cleanup (build_call_n_expr (set_jmpbuf_decl
, 1, gnu_jmpsave_decl
),
4116 End_Label (gnat_node
));
4119 /* If we are to call a function when exiting this block, add a cleanup
4120 to the binding level we made above. Note that add_cleanup is FIFO
4121 so we must register this cleanup after the EH cleanup just above. */
4123 add_cleanup (build_call_n_expr (gnat_to_gnu (At_End_Proc (gnat_node
)), 0),
4124 End_Label (gnat_node
));
4126 /* Now build the tree for the declarations and statements inside this block.
4127 If this is SJLJ, set our jmp_buf as the current buffer. */
4128 start_stmt_group ();
4131 add_stmt (build_call_n_expr (set_jmpbuf_decl
, 1,
4132 build_unary_op (ADDR_EXPR
, NULL_TREE
,
4135 if (Present (First_Real_Statement (gnat_node
)))
4136 process_decls (Statements (gnat_node
), Empty
,
4137 First_Real_Statement (gnat_node
), true, true);
4139 /* Generate code for each statement in the block. */
4140 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
4141 ? First_Real_Statement (gnat_node
)
4142 : First (Statements (gnat_node
)));
4143 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
4144 add_stmt (gnat_to_gnu (gnat_temp
));
4145 gnu_inner_block
= end_stmt_group ();
4147 /* Now generate code for the two exception models, if either is relevant for
4151 tree
*gnu_else_ptr
= 0;
4154 /* Make a binding level for the exception handling declarations and code
4155 and set up gnu_except_ptr_stack for the handlers to use. */
4156 start_stmt_group ();
4159 VEC_safe_push (tree
, gc
, gnu_except_ptr_stack
,
4160 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
4161 build_pointer_type (except_type_node
),
4162 build_call_n_expr (get_excptr_decl
, 0),
4163 false, false, false, false,
4166 /* Generate code for each handler. The N_Exception_Handler case does the
4167 real work and returns a COND_EXPR for each handler, which we chain
4169 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
4170 Present (gnat_temp
); gnat_temp
= Next_Non_Pragma (gnat_temp
))
4172 gnu_expr
= gnat_to_gnu (gnat_temp
);
4174 /* If this is the first one, set it as the outer one. Otherwise,
4175 point the "else" part of the previous handler to us. Then point
4176 to our "else" part. */
4178 add_stmt (gnu_expr
);
4180 *gnu_else_ptr
= gnu_expr
;
4182 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
4185 /* If none of the exception handlers did anything, re-raise but do not
4187 gnu_expr
= build_call_n_expr (raise_nodefer_decl
, 1,
4188 VEC_last (tree
, gnu_except_ptr_stack
));
4189 set_expr_location_from_node
4191 Present (End_Label (gnat_node
)) ? End_Label (gnat_node
) : gnat_node
);
4194 *gnu_else_ptr
= gnu_expr
;
4196 add_stmt (gnu_expr
);
4198 /* End the binding level dedicated to the exception handlers and get the
4199 whole statement group. */
4200 VEC_pop (tree
, gnu_except_ptr_stack
);
4202 gnu_handler
= end_stmt_group ();
4204 /* If the setjmp returns 1, we restore our incoming longjmp value and
4205 then check the handlers. */
4206 start_stmt_group ();
4207 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl
, 1,
4210 add_stmt (gnu_handler
);
4211 gnu_handler
= end_stmt_group ();
4213 /* This block is now "if (setjmp) ... <handlers> else <block>". */
4214 gnu_result
= build3 (COND_EXPR
, void_type_node
,
4217 build_unary_op (ADDR_EXPR
, NULL_TREE
,
4219 gnu_handler
, gnu_inner_block
);
4225 /* First make a block containing the handlers. */
4226 start_stmt_group ();
4227 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
4228 Present (gnat_temp
);
4229 gnat_temp
= Next_Non_Pragma (gnat_temp
))
4230 add_stmt (gnat_to_gnu (gnat_temp
));
4231 gnu_handlers
= end_stmt_group ();
4233 /* Now make the TRY_CATCH_EXPR for the block. */
4234 gnu_result
= build2 (TRY_CATCH_EXPR
, void_type_node
,
4235 gnu_inner_block
, gnu_handlers
);
4238 gnu_result
= gnu_inner_block
;
4240 /* Now close our outer block, if we had to make one. */
4241 if (binding_for_block
)
4243 add_stmt (gnu_result
);
4245 gnu_result
= end_stmt_group ();
4251 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4252 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
4253 exception handling. */
4256 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node
)
4258 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
4259 an "if" statement to select the proper exceptions. For "Others", exclude
4260 exceptions where Handled_By_Others is nonzero unless the All_Others flag
4261 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
4262 tree gnu_choice
= boolean_false_node
;
4263 tree gnu_body
= build_stmt_group (Statements (gnat_node
), false);
4266 for (gnat_temp
= First (Exception_Choices (gnat_node
));
4267 gnat_temp
; gnat_temp
= Next (gnat_temp
))
4271 if (Nkind (gnat_temp
) == N_Others_Choice
)
4273 if (All_Others (gnat_temp
))
4274 this_choice
= boolean_true_node
;
4278 (EQ_EXPR
, boolean_type_node
,
4283 (INDIRECT_REF
, NULL_TREE
,
4284 VEC_last (tree
, gnu_except_ptr_stack
)),
4285 get_identifier ("not_handled_by_others"), NULL_TREE
,
4290 else if (Nkind (gnat_temp
) == N_Identifier
4291 || Nkind (gnat_temp
) == N_Expanded_Name
)
4293 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
4296 /* Exception may be a renaming. Recover original exception which is
4297 the one elaborated and registered. */
4298 if (Present (Renamed_Object (gnat_ex_id
)))
4299 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
4301 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
4305 (EQ_EXPR
, boolean_type_node
,
4306 VEC_last (tree
, gnu_except_ptr_stack
),
4307 convert (TREE_TYPE (VEC_last (tree
, gnu_except_ptr_stack
)),
4308 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
4310 /* If this is the distinguished exception "Non_Ada_Error" (and we are
4311 in VMS mode), also allow a non-Ada exception (a VMS condition) t
4313 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
4316 = build_component_ref
4317 (build_unary_op (INDIRECT_REF
, NULL_TREE
,
4318 VEC_last (tree
, gnu_except_ptr_stack
)),
4319 get_identifier ("lang"), NULL_TREE
, false);
4323 (TRUTH_ORIF_EXPR
, boolean_type_node
,
4324 build_binary_op (EQ_EXPR
, boolean_type_node
, gnu_comp
,
4325 build_int_cst (TREE_TYPE (gnu_comp
), 'V')),
4332 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
4333 gnu_choice
, this_choice
);
4336 return build3 (COND_EXPR
, void_type_node
, gnu_choice
, gnu_body
, NULL_TREE
);
4339 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4340 to a GCC tree, which is returned. This is the variant for ZCX. */
4343 Exception_Handler_to_gnu_zcx (Node_Id gnat_node
)
4345 tree gnu_etypes_list
= NULL_TREE
;
4348 tree gnu_current_exc_ptr
;
4349 tree prev_gnu_incoming_exc_ptr
;
4352 /* We build a TREE_LIST of nodes representing what exception types this
4353 handler can catch, with special cases for others and all others cases.
4355 Each exception type is actually identified by a pointer to the exception
4356 id, or to a dummy object for "others" and "all others". */
4357 for (gnat_temp
= First (Exception_Choices (gnat_node
));
4358 gnat_temp
; gnat_temp
= Next (gnat_temp
))
4360 if (Nkind (gnat_temp
) == N_Others_Choice
)
4363 = All_Others (gnat_temp
) ? all_others_decl
: others_decl
;
4366 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
4368 else if (Nkind (gnat_temp
) == N_Identifier
4369 || Nkind (gnat_temp
) == N_Expanded_Name
)
4371 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
4373 /* Exception may be a renaming. Recover original exception which is
4374 the one elaborated and registered. */
4375 if (Present (Renamed_Object (gnat_ex_id
)))
4376 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
4378 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
4379 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
4381 /* The Non_Ada_Error case for VMS exceptions is handled
4382 by the personality routine. */
4387 /* The GCC interface expects NULL to be passed for catch all handlers, so
4388 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
4389 is integer_zero_node. It would not work, however, because GCC's
4390 notion of "catch all" is stronger than our notion of "others". Until
4391 we correctly use the cleanup interface as well, doing that would
4392 prevent the "all others" handlers from being seen, because nothing
4393 can be caught beyond a catch all from GCC's point of view. */
4394 gnu_etypes_list
= tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
4397 start_stmt_group ();
4400 /* Expand a call to the begin_handler hook at the beginning of the handler,
4401 and arrange for a call to the end_handler hook to occur on every possible
4404 The hooks expect a pointer to the low level occurrence. This is required
4405 for our stack management scheme because a raise inside the handler pushes
4406 a new occurrence on top of the stack, which means that this top does not
4407 necessarily match the occurrence this handler was dealing with.
4409 __builtin_eh_pointer references the exception occurrence being
4410 propagated. Upon handler entry, this is the exception for which the
4411 handler is triggered. This might not be the case upon handler exit,
4412 however, as we might have a new occurrence propagated by the handler's
4413 body, and the end_handler hook called as a cleanup in this context.
4415 We use a local variable to retrieve the incoming value at handler entry
4416 time, and reuse it to feed the end_handler hook's argument at exit. */
4419 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
4420 1, integer_zero_node
);
4421 prev_gnu_incoming_exc_ptr
= gnu_incoming_exc_ptr
;
4422 gnu_incoming_exc_ptr
= create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
4423 ptr_type_node
, gnu_current_exc_ptr
,
4424 false, false, false, false,
4427 add_stmt_with_node (build_call_n_expr (begin_handler_decl
, 1,
4428 gnu_incoming_exc_ptr
),
4430 /* ??? We don't seem to have an End_Label at hand to set the location. */
4431 add_cleanup (build_call_n_expr (end_handler_decl
, 1, gnu_incoming_exc_ptr
),
4433 add_stmt_list (Statements (gnat_node
));
4436 gnu_incoming_exc_ptr
= prev_gnu_incoming_exc_ptr
;
4438 return build2 (CATCH_EXPR
, void_type_node
, gnu_etypes_list
,
4442 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
4445 Compilation_Unit_to_gnu (Node_Id gnat_node
)
4447 const Node_Id gnat_unit
= Unit (gnat_node
);
4448 const bool body_p
= (Nkind (gnat_unit
) == N_Package_Body
4449 || Nkind (gnat_unit
) == N_Subprogram_Body
);
4450 const Entity_Id gnat_unit_entity
= Defining_Entity (gnat_unit
);
4451 /* Make the decl for the elaboration procedure. */
4452 tree gnu_elab_proc_decl
4453 = create_subprog_decl
4454 (create_concat_name (gnat_unit_entity
, body_p
? "elabb" : "elabs"),
4455 NULL_TREE
, void_ftype
, NULL_TREE
, false, true, false, true, NULL
,
4457 struct elab_info
*info
;
4459 VEC_safe_push (tree
, gc
, gnu_elab_proc_stack
, gnu_elab_proc_decl
);
4460 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl
) = 1;
4462 /* Initialize the information structure for the function. */
4463 allocate_struct_function (gnu_elab_proc_decl
, false);
4466 current_function_decl
= NULL_TREE
;
4468 start_stmt_group ();
4471 /* For a body, first process the spec if there is one. */
4472 if (Nkind (gnat_unit
) == N_Package_Body
4473 || (Nkind (gnat_unit
) == N_Subprogram_Body
&& !Acts_As_Spec (gnat_node
)))
4474 add_stmt (gnat_to_gnu (Library_Unit (gnat_node
)));
4476 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
4478 elaborate_all_entities (gnat_node
);
4480 if (Nkind (gnat_unit
) == N_Subprogram_Declaration
4481 || Nkind (gnat_unit
) == N_Generic_Package_Declaration
4482 || Nkind (gnat_unit
) == N_Generic_Subprogram_Declaration
)
4486 process_decls (Declarations (Aux_Decls_Node (gnat_node
)), Empty
, Empty
,
4488 add_stmt (gnat_to_gnu (gnat_unit
));
4490 /* If we can inline, generate code for all the inlined subprograms. */
4493 Entity_Id gnat_entity
;
4495 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
4496 Present (gnat_entity
);
4497 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
4499 Node_Id gnat_body
= Parent (Declaration_Node (gnat_entity
));
4501 if (Nkind (gnat_body
) != N_Subprogram_Body
)
4503 /* ??? This really should always be present. */
4504 if (No (Corresponding_Body (gnat_body
)))
4507 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
4510 if (Present (gnat_body
))
4512 /* Define the entity first so we set DECL_EXTERNAL. */
4513 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4514 add_stmt (gnat_to_gnu (gnat_body
));
4519 /* Process any pragmas and actions following the unit. */
4520 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node
)));
4521 add_stmt_list (Actions (Aux_Decls_Node (gnat_node
)));
4522 finalize_from_with_types ();
4524 /* Save away what we've made so far and record this potential elaboration
4526 info
= ggc_alloc_elab_info ();
4527 set_current_block_context (gnu_elab_proc_decl
);
4529 DECL_SAVED_TREE (gnu_elab_proc_decl
) = end_stmt_group ();
4531 set_end_locus_from_node (gnu_elab_proc_decl
, gnat_unit
);
4533 info
->next
= elab_info_list
;
4534 info
->elab_proc
= gnu_elab_proc_decl
;
4535 info
->gnat_node
= gnat_node
;
4536 elab_info_list
= info
;
4538 /* Generate elaboration code for this unit, if necessary, and say whether
4540 VEC_pop (tree
, gnu_elab_proc_stack
);
4542 /* Invalidate the global renaming pointers. This is necessary because
4543 stabilization of the renamed entities may create SAVE_EXPRs which
4544 have been tied to a specific elaboration routine just above. */
4545 invalidate_global_renaming_pointers ();
4548 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
4549 parameter of a call. */
4552 lhs_or_actual_p (Node_Id gnat_node
)
4554 Node_Id gnat_parent
= Parent (gnat_node
);
4555 Node_Kind kind
= Nkind (gnat_parent
);
4557 if (kind
== N_Assignment_Statement
&& Name (gnat_parent
) == gnat_node
)
4560 if ((kind
== N_Procedure_Call_Statement
|| kind
== N_Function_Call
)
4561 && Name (gnat_parent
) != gnat_node
)
4564 if (kind
== N_Parameter_Association
)
4570 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
4571 of an assignment or an actual parameter of a call. */
4574 present_in_lhs_or_actual_p (Node_Id gnat_node
)
4578 if (lhs_or_actual_p (gnat_node
))
4581 kind
= Nkind (Parent (gnat_node
));
4583 if ((kind
== N_Type_Conversion
|| kind
== N_Unchecked_Type_Conversion
)
4584 && lhs_or_actual_p (Parent (gnat_node
)))
4590 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
4591 as gigi is concerned. This is used to avoid conversions on the LHS. */
4594 unchecked_conversion_nop (Node_Id gnat_node
)
4596 Entity_Id from_type
, to_type
;
4598 /* The conversion must be on the LHS of an assignment or an actual parameter
4599 of a call. Otherwise, even if the conversion was essentially a no-op, it
4600 could de facto ensure type consistency and this should be preserved. */
4601 if (!lhs_or_actual_p (gnat_node
))
4604 from_type
= Etype (Expression (gnat_node
));
4606 /* We're interested in artificial conversions generated by the front-end
4607 to make private types explicit, e.g. in Expand_Assign_Array. */
4608 if (!Is_Private_Type (from_type
))
4611 from_type
= Underlying_Type (from_type
);
4612 to_type
= Etype (gnat_node
);
4614 /* The direct conversion to the underlying type is a no-op. */
4615 if (to_type
== from_type
)
4618 /* For an array subtype, the conversion to the PAT is a no-op. */
4619 if (Ekind (from_type
) == E_Array_Subtype
4620 && to_type
== Packed_Array_Type (from_type
))
4623 /* For a record subtype, the conversion to the type is a no-op. */
4624 if (Ekind (from_type
) == E_Record_Subtype
4625 && to_type
== Etype (from_type
))
4631 /* This function is the driver of the GNAT to GCC tree transformation process.
4632 It is the entry point of the tree transformer. GNAT_NODE is the root of
4633 some GNAT tree. Return the root of the corresponding GCC tree. If this
4634 is an expression, return the GCC equivalent of the expression. If this
4635 is a statement, return the statement or add it to the current statement
4636 group, in which case anything returned is to be interpreted as occurring
4637 after anything added. */
4640 gnat_to_gnu (Node_Id gnat_node
)
4642 const Node_Kind kind
= Nkind (gnat_node
);
4643 bool went_into_elab_proc
= false;
4644 tree gnu_result
= error_mark_node
; /* Default to no value. */
4645 tree gnu_result_type
= void_type_node
;
4646 tree gnu_expr
, gnu_lhs
, gnu_rhs
;
4649 /* Save node number for error message and set location information. */
4650 error_gnat_node
= gnat_node
;
4651 Sloc_to_locus (Sloc (gnat_node
), &input_location
);
4653 /* If this node is a statement and we are only annotating types, return an
4654 empty statement list. */
4655 if (type_annotate_only
&& IN (kind
, N_Statement_Other_Than_Procedure_Call
))
4656 return alloc_stmt_list ();
4658 /* If this node is a non-static subexpression and we are only annotating
4659 types, make this into a NULL_EXPR. */
4660 if (type_annotate_only
4661 && IN (kind
, N_Subexpr
)
4662 && kind
!= N_Identifier
4663 && !Compile_Time_Known_Value (gnat_node
))
4664 return build1 (NULL_EXPR
, get_unpadded_type (Etype (gnat_node
)),
4665 build_call_raise (CE_Range_Check_Failed
, gnat_node
,
4666 N_Raise_Constraint_Error
));
4668 if ((IN (kind
, N_Statement_Other_Than_Procedure_Call
)
4669 && kind
!= N_Null_Statement
)
4670 || kind
== N_Procedure_Call_Statement
4672 || kind
== N_Implicit_Label_Declaration
4673 || kind
== N_Handled_Sequence_Of_Statements
4674 || (IN (kind
, N_Raise_xxx_Error
) && Ekind (Etype (gnat_node
)) == E_Void
))
4676 tree current_elab_proc
= get_elaboration_procedure ();
4678 /* If this is a statement and we are at top level, it must be part of
4679 the elaboration procedure, so mark us as being in that procedure. */
4680 if (!current_function_decl
)
4682 current_function_decl
= current_elab_proc
;
4683 went_into_elab_proc
= true;
4686 /* If we are in the elaboration procedure, check if we are violating a
4687 No_Elaboration_Code restriction by having a statement there. Don't
4688 check for a possible No_Elaboration_Code restriction violation on
4689 N_Handled_Sequence_Of_Statements, as we want to signal an error on
4690 every nested real statement instead. This also avoids triggering
4691 spurious errors on dummy (empty) sequences created by the front-end
4692 for package bodies in some cases. */
4693 if (current_function_decl
== current_elab_proc
4694 && kind
!= N_Handled_Sequence_Of_Statements
)
4695 Check_Elaboration_Code_Allowed (gnat_node
);
4700 /********************************/
4701 /* Chapter 2: Lexical Elements */
4702 /********************************/
4705 case N_Expanded_Name
:
4706 case N_Operator_Symbol
:
4707 case N_Defining_Identifier
:
4708 gnu_result
= Identifier_to_gnu (gnat_node
, &gnu_result_type
);
4710 /* If this is an atomic access on the RHS for which synchronization is
4711 required, build the atomic load. */
4712 if (atomic_sync_required_p (gnat_node
)
4713 && !present_in_lhs_or_actual_p (gnat_node
))
4714 gnu_result
= build_atomic_load (gnu_result
);
4717 case N_Integer_Literal
:
4721 /* Get the type of the result, looking inside any padding and
4722 justified modular types. Then get the value in that type. */
4723 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4725 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4726 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
4727 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
4729 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
4731 /* If the result overflows (meaning it doesn't fit in its base type),
4732 abort. We would like to check that the value is within the range
4733 of the subtype, but that causes problems with subtypes whose usage
4734 will raise Constraint_Error and with biased representation, so
4736 gcc_assert (!TREE_OVERFLOW (gnu_result
));
4740 case N_Character_Literal
:
4741 /* If a Entity is present, it means that this was one of the
4742 literals in a user-defined character type. In that case,
4743 just return the value in the CONST_DECL. Otherwise, use the
4744 character code. In that case, the base type should be an
4745 INTEGER_TYPE, but we won't bother checking for that. */
4746 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4747 if (Present (Entity (gnat_node
)))
4748 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
4751 = build_int_cst_type
4752 (gnu_result_type
, UI_To_CC (Char_Literal_Value (gnat_node
)));
4755 case N_Real_Literal
:
4756 /* If this is of a fixed-point type, the value we want is the
4757 value of the corresponding integer. */
4758 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
4760 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4761 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
4763 gcc_assert (!TREE_OVERFLOW (gnu_result
));
4766 /* We should never see a Vax_Float type literal, since the front end
4767 is supposed to transform these using appropriate conversions. */
4768 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
4773 Ureal ur_realval
= Realval (gnat_node
);
4775 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4777 /* If the real value is zero, so is the result. Otherwise,
4778 convert it to a machine number if it isn't already. That
4779 forces BASE to 0 or 2 and simplifies the rest of our logic. */
4780 if (UR_Is_Zero (ur_realval
))
4781 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
4784 if (!Is_Machine_Number (gnat_node
))
4786 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
4787 ur_realval
, Round_Even
, gnat_node
);
4790 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
4792 /* If we have a base of zero, divide by the denominator.
4793 Otherwise, the base must be 2 and we scale the value, which
4794 we know can fit in the mantissa of the type (hence the use
4795 of that type above). */
4796 if (No (Rbase (ur_realval
)))
4798 = build_binary_op (RDIV_EXPR
,
4799 get_base_type (gnu_result_type
),
4801 UI_To_gnu (Denominator (ur_realval
),
4805 REAL_VALUE_TYPE tmp
;
4807 gcc_assert (Rbase (ur_realval
) == 2);
4808 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
4809 - UI_To_Int (Denominator (ur_realval
)));
4810 gnu_result
= build_real (gnu_result_type
, tmp
);
4814 /* Now see if we need to negate the result. Do it this way to
4815 properly handle -0. */
4816 if (UR_Is_Negative (Realval (gnat_node
)))
4818 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
4824 case N_String_Literal
:
4825 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4826 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
4828 String_Id gnat_string
= Strval (gnat_node
);
4829 int length
= String_Length (gnat_string
);
4832 if (length
>= ALLOCA_THRESHOLD
)
4833 string
= XNEWVEC (char, length
+ 1);
4835 string
= (char *) alloca (length
+ 1);
4837 /* Build the string with the characters in the literal. Note
4838 that Ada strings are 1-origin. */
4839 for (i
= 0; i
< length
; i
++)
4840 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
4842 /* Put a null at the end of the string in case it's in a context
4843 where GCC will want to treat it as a C string. */
4846 gnu_result
= build_string (length
, string
);
4848 /* Strings in GCC don't normally have types, but we want
4849 this to not be converted to the array type. */
4850 TREE_TYPE (gnu_result
) = gnu_result_type
;
4852 if (length
>= ALLOCA_THRESHOLD
)
4857 /* Build a list consisting of each character, then make
4859 String_Id gnat_string
= Strval (gnat_node
);
4860 int length
= String_Length (gnat_string
);
4862 tree gnu_idx
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
4863 VEC(constructor_elt
,gc
) *gnu_vec
4864 = VEC_alloc (constructor_elt
, gc
, length
);
4866 for (i
= 0; i
< length
; i
++)
4868 tree t
= build_int_cst (TREE_TYPE (gnu_result_type
),
4869 Get_String_Char (gnat_string
, i
+ 1));
4871 CONSTRUCTOR_APPEND_ELT (gnu_vec
, gnu_idx
, t
);
4872 gnu_idx
= int_const_binop (PLUS_EXPR
, gnu_idx
, integer_one_node
);
4875 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
4880 gnu_result
= Pragma_to_gnu (gnat_node
);
4883 /**************************************/
4884 /* Chapter 3: Declarations and Types */
4885 /**************************************/
4887 case N_Subtype_Declaration
:
4888 case N_Full_Type_Declaration
:
4889 case N_Incomplete_Type_Declaration
:
4890 case N_Private_Type_Declaration
:
4891 case N_Private_Extension_Declaration
:
4892 case N_Task_Type_Declaration
:
4893 process_type (Defining_Entity (gnat_node
));
4894 gnu_result
= alloc_stmt_list ();
4897 case N_Object_Declaration
:
4898 case N_Exception_Declaration
:
4899 gnat_temp
= Defining_Entity (gnat_node
);
4900 gnu_result
= alloc_stmt_list ();
4902 /* If we are just annotating types and this object has an unconstrained
4903 or task type, don't elaborate it. */
4904 if (type_annotate_only
4905 && (((Is_Array_Type (Etype (gnat_temp
))
4906 || Is_Record_Type (Etype (gnat_temp
)))
4907 && !Is_Constrained (Etype (gnat_temp
)))
4908 || Is_Concurrent_Type (Etype (gnat_temp
))))
4911 if (Present (Expression (gnat_node
))
4912 && !(kind
== N_Object_Declaration
&& No_Initialization (gnat_node
))
4913 && (!type_annotate_only
4914 || Compile_Time_Known_Value (Expression (gnat_node
))))
4916 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
4917 if (Do_Range_Check (Expression (gnat_node
)))
4919 = emit_range_check (gnu_expr
, Etype (gnat_temp
), gnat_node
);
4921 /* If this object has its elaboration delayed, we must force
4922 evaluation of GNU_EXPR right now and save it for when the object
4924 if (Present (Freeze_Node (gnat_temp
)))
4926 if (TREE_CONSTANT (gnu_expr
))
4928 else if (global_bindings_p ())
4930 = create_var_decl (create_concat_name (gnat_temp
, "init"),
4931 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
4932 false, false, false, false,
4935 gnu_expr
= gnat_save_expr (gnu_expr
);
4937 save_gnu_tree (gnat_node
, gnu_expr
, true);
4941 gnu_expr
= NULL_TREE
;
4943 if (type_annotate_only
&& gnu_expr
&& TREE_CODE (gnu_expr
) == ERROR_MARK
)
4944 gnu_expr
= NULL_TREE
;
4946 /* If this is a deferred constant with an address clause, we ignore the
4947 full view since the clause is on the partial view and we cannot have
4948 2 different GCC trees for the object. The only bits of the full view
4949 we will use is the initializer, but it will be directly fetched. */
4950 if (Ekind(gnat_temp
) == E_Constant
4951 && Present (Address_Clause (gnat_temp
))
4952 && Present (Full_View (gnat_temp
)))
4953 save_gnu_tree (Full_View (gnat_temp
), error_mark_node
, true);
4955 if (No (Freeze_Node (gnat_temp
)))
4956 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
4959 case N_Object_Renaming_Declaration
:
4960 gnat_temp
= Defining_Entity (gnat_node
);
4962 /* Don't do anything if this renaming is handled by the front end or if
4963 we are just annotating types and this object has a composite or task
4964 type, don't elaborate it. We return the result in case it has any
4965 SAVE_EXPRs in it that need to be evaluated here. */
4966 if (!Is_Renaming_Of_Object (gnat_temp
)
4967 && ! (type_annotate_only
4968 && (Is_Array_Type (Etype (gnat_temp
))
4969 || Is_Record_Type (Etype (gnat_temp
))
4970 || Is_Concurrent_Type (Etype (gnat_temp
)))))
4972 = gnat_to_gnu_entity (gnat_temp
,
4973 gnat_to_gnu (Renamed_Object (gnat_temp
)), 1);
4975 gnu_result
= alloc_stmt_list ();
4978 case N_Implicit_Label_Declaration
:
4979 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
4980 gnu_result
= alloc_stmt_list ();
4983 case N_Exception_Renaming_Declaration
:
4984 case N_Number_Declaration
:
4985 case N_Package_Renaming_Declaration
:
4986 case N_Subprogram_Renaming_Declaration
:
4987 /* These are fully handled in the front end. */
4988 gnu_result
= alloc_stmt_list ();
4991 /*************************************/
4992 /* Chapter 4: Names and Expressions */
4993 /*************************************/
4995 case N_Explicit_Dereference
:
4996 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
4997 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4998 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
5000 /* If this is an atomic access on the RHS for which synchronization is
5001 required, build the atomic load. */
5002 if (atomic_sync_required_p (gnat_node
)
5003 && !present_in_lhs_or_actual_p (gnat_node
))
5004 gnu_result
= build_atomic_load (gnu_result
);
5007 case N_Indexed_Component
:
5009 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
5013 Node_Id
*gnat_expr_array
;
5015 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
5017 /* Convert vector inputs to their representative array type, to fit
5018 what the code below expects. */
5019 gnu_array_object
= maybe_vector_array (gnu_array_object
);
5021 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
5023 /* If we got a padded type, remove it too. */
5024 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
5026 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
5029 gnu_result
= gnu_array_object
;
5031 /* First compute the number of dimensions of the array, then
5032 fill the expression array, the order depending on whether
5033 this is a Convention_Fortran array or not. */
5034 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
5035 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
5036 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
5037 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
5040 gnat_expr_array
= XALLOCAVEC (Node_Id
, ndim
);
5042 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
5043 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
5045 i
--, gnat_temp
= Next (gnat_temp
))
5046 gnat_expr_array
[i
] = gnat_temp
;
5048 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
5050 i
++, gnat_temp
= Next (gnat_temp
))
5051 gnat_expr_array
[i
] = gnat_temp
;
5053 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
5054 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
5056 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
5057 gnat_temp
= gnat_expr_array
[i
];
5058 gnu_expr
= gnat_to_gnu (gnat_temp
);
5060 if (Do_Range_Check (gnat_temp
))
5063 (gnu_array_object
, gnu_expr
,
5064 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
5065 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
5068 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
5069 gnu_result
, gnu_expr
);
5072 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5074 /* If this is an atomic access on the RHS for which synchronization is
5075 required, build the atomic load. */
5076 if (atomic_sync_required_p (gnat_node
)
5077 && !present_in_lhs_or_actual_p (gnat_node
))
5078 gnu_result
= build_atomic_load (gnu_result
);
5084 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
5087 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
5088 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5090 /* Do any implicit dereferences of the prefix and do any needed
5092 gnu_result
= maybe_implicit_deref (gnu_result
);
5093 gnu_result
= maybe_unconstrained_array (gnu_result
);
5094 gnu_type
= TREE_TYPE (gnu_result
);
5095 if (Do_Range_Check (gnat_range_node
))
5097 /* Get the bounds of the slice. */
5099 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
5100 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
5101 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
5102 /* Get the permitted bounds. */
5103 tree gnu_base_index_type
5104 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
));
5105 tree gnu_base_min_expr
= SUBSTITUTE_PLACEHOLDER_IN_EXPR
5106 (TYPE_MIN_VALUE (gnu_base_index_type
), gnu_result
);
5107 tree gnu_base_max_expr
= SUBSTITUTE_PLACEHOLDER_IN_EXPR
5108 (TYPE_MAX_VALUE (gnu_base_index_type
), gnu_result
);
5109 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
5111 gnu_min_expr
= gnat_protect_expr (gnu_min_expr
);
5112 gnu_max_expr
= gnat_protect_expr (gnu_max_expr
);
5114 /* Derive a good type to convert everything to. */
5115 gnu_expr_type
= get_base_type (gnu_index_type
);
5117 /* Test whether the minimum slice value is too small. */
5118 gnu_expr_l
= build_binary_op (LT_EXPR
, boolean_type_node
,
5119 convert (gnu_expr_type
,
5121 convert (gnu_expr_type
,
5122 gnu_base_min_expr
));
5124 /* Test whether the maximum slice value is too large. */
5125 gnu_expr_h
= build_binary_op (GT_EXPR
, boolean_type_node
,
5126 convert (gnu_expr_type
,
5128 convert (gnu_expr_type
,
5129 gnu_base_max_expr
));
5131 /* Build a slice index check that returns the low bound,
5132 assuming the slice is not empty. */
5133 gnu_expr
= emit_check
5134 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
5135 gnu_expr_l
, gnu_expr_h
),
5136 gnu_min_expr
, CE_Index_Check_Failed
, gnat_node
);
5138 /* Build a conditional expression that does the index checks and
5139 returns the low bound if the slice is not empty (max >= min),
5140 and returns the naked low bound otherwise (max < min), unless
5141 it is non-constant and the high bound is; this prevents VRP
5142 from inferring bogus ranges on the unlikely path. */
5143 gnu_expr
= fold_build3 (COND_EXPR
, gnu_expr_type
,
5144 build_binary_op (GE_EXPR
, gnu_expr_type
,
5145 convert (gnu_expr_type
,
5147 convert (gnu_expr_type
,
5150 TREE_CODE (gnu_min_expr
) != INTEGER_CST
5151 && TREE_CODE (gnu_max_expr
) == INTEGER_CST
5152 ? gnu_max_expr
: gnu_min_expr
);
5155 /* Simply return the naked low bound. */
5156 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
5158 /* If this is a slice with non-constant size of an array with constant
5159 size, set the maximum size for the allocation of temporaries. */
5160 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type
))
5161 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type
)))
5162 TYPE_ARRAY_MAX_SIZE (gnu_result_type
) = TYPE_SIZE_UNIT (gnu_type
);
5164 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
5165 gnu_result
, gnu_expr
);
5169 case N_Selected_Component
:
5171 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
5172 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
5173 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
5176 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
5177 || IN (Ekind (gnat_pref_type
), Access_Kind
))
5179 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
5180 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
5181 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
5182 gnat_pref_type
= Designated_Type (gnat_pref_type
);
5185 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
5187 /* For discriminant references in tagged types always substitute the
5188 corresponding discriminant as the actual selected component. */
5189 if (Is_Tagged_Type (gnat_pref_type
))
5190 while (Present (Corresponding_Discriminant (gnat_field
)))
5191 gnat_field
= Corresponding_Discriminant (gnat_field
);
5193 /* For discriminant references of untagged types always substitute the
5194 corresponding stored discriminant. */
5195 else if (Present (Corresponding_Discriminant (gnat_field
)))
5196 gnat_field
= Original_Record_Component (gnat_field
);
5198 /* Handle extracting the real or imaginary part of a complex.
5199 The real part is the first field and the imaginary the last. */
5200 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
5201 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
5202 ? REALPART_EXPR
: IMAGPART_EXPR
,
5203 NULL_TREE
, gnu_prefix
);
5206 gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
5208 /* If there are discriminants, the prefix might be evaluated more
5209 than once, which is a problem if it has side-effects. */
5210 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
5211 ? Designated_Type (Etype
5212 (Prefix (gnat_node
)))
5213 : Etype (Prefix (gnat_node
))))
5214 gnu_prefix
= gnat_stabilize_reference (gnu_prefix
, false, NULL
);
5217 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
,
5218 (Nkind (Parent (gnat_node
))
5219 == N_Attribute_Reference
)
5220 && lvalue_required_for_attribute_p
5221 (Parent (gnat_node
)));
5224 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5226 /* If this is an atomic access on the RHS for which synchronization is
5227 required, build the atomic load. */
5228 if (atomic_sync_required_p (gnat_node
)
5229 && !present_in_lhs_or_actual_p (gnat_node
))
5230 gnu_result
= build_atomic_load (gnu_result
);
5234 case N_Attribute_Reference
:
5236 /* The attribute designator. */
5237 const int attr
= Get_Attribute_Id (Attribute_Name (gnat_node
));
5239 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
5240 is a unit, not an object with a GCC equivalent. */
5241 if (attr
== Attr_Elab_Spec
|| attr
== Attr_Elab_Body
)
5243 create_subprog_decl (create_concat_name
5244 (Entity (Prefix (gnat_node
)),
5245 attr
== Attr_Elab_Body
? "elabb" : "elabs"),
5246 NULL_TREE
, void_ftype
, NULL_TREE
, false,
5247 true, true, true, NULL
, gnat_node
);
5249 gnu_result
= Attribute_to_gnu (gnat_node
, &gnu_result_type
, attr
);
5254 /* Like 'Access as far as we are concerned. */
5255 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
5256 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
5257 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5261 case N_Extension_Aggregate
:
5265 /* ??? It is wrong to evaluate the type now, but there doesn't
5266 seem to be any other practical way of doing it. */
5268 gcc_assert (!Expansion_Delayed (gnat_node
));
5270 gnu_aggr_type
= gnu_result_type
5271 = get_unpadded_type (Etype (gnat_node
));
5273 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
5274 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
5276 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type
)));
5277 else if (TREE_CODE (gnu_result_type
) == VECTOR_TYPE
)
5278 gnu_aggr_type
= TYPE_REPRESENTATIVE_ARRAY (gnu_result_type
);
5280 if (Null_Record_Present (gnat_node
))
5281 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL
);
5283 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
5284 || TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
5286 = assoc_to_constructor (Etype (gnat_node
),
5287 First (Component_Associations (gnat_node
)),
5289 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
5290 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
5292 Component_Type (Etype (gnat_node
)));
5293 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
5296 (COMPLEX_EXPR
, gnu_aggr_type
,
5297 gnat_to_gnu (Expression (First
5298 (Component_Associations (gnat_node
)))),
5299 gnat_to_gnu (Expression
5301 (First (Component_Associations (gnat_node
))))));
5305 gnu_result
= convert (gnu_result_type
, gnu_result
);
5310 if (TARGET_VTABLE_USES_DESCRIPTORS
5311 && Ekind (Etype (gnat_node
)) == E_Access_Subprogram_Type
5312 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
5313 gnu_result
= null_fdesc_node
;
5315 gnu_result
= null_pointer_node
;
5316 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5319 case N_Type_Conversion
:
5320 case N_Qualified_Expression
:
5321 /* Get the operand expression. */
5322 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
5323 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5326 = convert_with_check (Etype (gnat_node
), gnu_result
,
5327 Do_Overflow_Check (gnat_node
),
5328 Do_Range_Check (Expression (gnat_node
)),
5329 kind
== N_Type_Conversion
5330 && Float_Truncate (gnat_node
), gnat_node
);
5333 case N_Unchecked_Type_Conversion
:
5334 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
5336 /* Skip further processing if the conversion is deemed a no-op. */
5337 if (unchecked_conversion_nop (gnat_node
))
5339 gnu_result_type
= TREE_TYPE (gnu_result
);
5343 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5345 /* If the result is a pointer type, see if we are improperly
5346 converting to a stricter alignment. */
5347 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
5348 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
5350 unsigned int align
= known_alignment (gnu_result
);
5351 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
5352 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
5354 if (align
!= 0 && align
< oalign
&& !TYPE_ALIGN_OK (gnu_obj_type
))
5355 post_error_ne_tree_2
5356 ("?source alignment (^) '< alignment of & (^)",
5357 gnat_node
, Designated_Type (Etype (gnat_node
)),
5358 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
5361 /* If we are converting a descriptor to a function pointer, first
5362 build the pointer. */
5363 if (TARGET_VTABLE_USES_DESCRIPTORS
5364 && TREE_TYPE (gnu_result
) == fdesc_type_node
5365 && POINTER_TYPE_P (gnu_result_type
))
5366 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
5368 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
,
5369 No_Truncation (gnat_node
));
5375 tree gnu_obj
= gnat_to_gnu (Left_Opnd (gnat_node
));
5376 Node_Id gnat_range
= Right_Opnd (gnat_node
);
5377 tree gnu_low
, gnu_high
;
5379 /* GNAT_RANGE is either an N_Range node or an identifier denoting a
5381 if (Nkind (gnat_range
) == N_Range
)
5383 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
5384 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
5386 else if (Nkind (gnat_range
) == N_Identifier
5387 || Nkind (gnat_range
) == N_Expanded_Name
)
5389 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
5391 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
5392 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
5397 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5399 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
5400 ensure that GNU_OBJ is evaluated only once and perform a full range
5402 if (operand_equal_p (gnu_low
, gnu_high
, 0))
5404 = build_binary_op (EQ_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
5408 gnu_obj
= gnat_protect_expr (gnu_obj
);
5409 t1
= build_binary_op (GE_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
5411 set_expr_location_from_node (t1
, gnat_node
);
5412 t2
= build_binary_op (LE_EXPR
, gnu_result_type
, gnu_obj
, gnu_high
);
5414 set_expr_location_from_node (t2
, gnat_node
);
5416 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
, t1
, t2
);
5419 if (kind
== N_Not_In
)
5421 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result
), gnu_result
);
5426 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
5427 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
5428 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5429 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
5431 : (Rounded_Result (gnat_node
)
5432 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
5433 gnu_result_type
, gnu_lhs
, gnu_rhs
);
5436 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
5437 /* These can either be operations on booleans or on modular types.
5438 Fall through for boolean types since that's the way GNU_CODES is
5440 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
5441 Modular_Integer_Kind
))
5444 = (kind
== N_Op_Or
? BIT_IOR_EXPR
5445 : kind
== N_Op_And
? BIT_AND_EXPR
5448 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
5449 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
5450 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5451 gnu_result
= build_binary_op (code
, gnu_result_type
,
5456 /* ... fall through ... */
5458 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
5459 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
5460 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
5461 case N_Op_Mod
: case N_Op_Rem
:
5462 case N_Op_Rotate_Left
:
5463 case N_Op_Rotate_Right
:
5464 case N_Op_Shift_Left
:
5465 case N_Op_Shift_Right
:
5466 case N_Op_Shift_Right_Arithmetic
:
5467 case N_And_Then
: case N_Or_Else
:
5469 enum tree_code code
= gnu_codes
[kind
];
5470 bool ignore_lhs_overflow
= false;
5471 location_t saved_location
= input_location
;
5474 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
5475 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
5476 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5478 /* Pending generic support for efficient vector logical operations in
5479 GCC, convert vectors to their representative array type view and
5481 gnu_lhs
= maybe_vector_array (gnu_lhs
);
5482 gnu_rhs
= maybe_vector_array (gnu_rhs
);
5484 /* If this is a comparison operator, convert any references to
5485 an unconstrained array value into a reference to the
5487 if (TREE_CODE_CLASS (code
) == tcc_comparison
)
5489 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
5490 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
5493 /* If the result type is a private type, its full view may be a
5494 numeric subtype. The representation we need is that of its base
5495 type, given that it is the result of an arithmetic operation. */
5496 else if (Is_Private_Type (Etype (gnat_node
)))
5497 gnu_type
= gnu_result_type
5498 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node
))));
5500 /* If this is a shift whose count is not guaranteed to be correct,
5501 we need to adjust the shift count. */
5502 if (IN (kind
, N_Op_Shift
) && !Shift_Count_OK (gnat_node
))
5504 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
5506 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
5508 if (kind
== N_Op_Rotate_Left
|| kind
== N_Op_Rotate_Right
)
5509 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
5510 gnu_rhs
, gnu_max_shift
);
5511 else if (kind
== N_Op_Shift_Right_Arithmetic
)
5514 (MIN_EXPR
, gnu_count_type
,
5515 build_binary_op (MINUS_EXPR
,
5518 convert (gnu_count_type
,
5523 /* For right shifts, the type says what kind of shift to do,
5524 so we may need to choose a different type. In this case,
5525 we have to ignore integer overflow lest it propagates all
5526 the way down and causes a CE to be explicitly raised. */
5527 if (kind
== N_Op_Shift_Right
&& !TYPE_UNSIGNED (gnu_type
))
5529 gnu_type
= gnat_unsigned_type (gnu_type
);
5530 ignore_lhs_overflow
= true;
5532 else if (kind
== N_Op_Shift_Right_Arithmetic
5533 && TYPE_UNSIGNED (gnu_type
))
5535 gnu_type
= gnat_signed_type (gnu_type
);
5536 ignore_lhs_overflow
= true;
5539 if (gnu_type
!= gnu_result_type
)
5541 tree gnu_old_lhs
= gnu_lhs
;
5542 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
5543 if (TREE_CODE (gnu_lhs
) == INTEGER_CST
&& ignore_lhs_overflow
)
5544 TREE_OVERFLOW (gnu_lhs
) = TREE_OVERFLOW (gnu_old_lhs
);
5545 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
5548 /* Instead of expanding overflow checks for addition, subtraction
5549 and multiplication itself, the front end will leave this to
5550 the back end when Backend_Overflow_Checks_On_Target is set.
5551 As the GCC back end itself does not know yet how to properly
5552 do overflow checking, do it here. The goal is to push
5553 the expansions further into the back end over time. */
5554 if (Do_Overflow_Check (gnat_node
) && Backend_Overflow_Checks_On_Target
5555 && (kind
== N_Op_Add
5556 || kind
== N_Op_Subtract
5557 || kind
== N_Op_Multiply
)
5558 && !TYPE_UNSIGNED (gnu_type
)
5559 && !FLOAT_TYPE_P (gnu_type
))
5560 gnu_result
= build_binary_op_trapv (code
, gnu_type
,
5561 gnu_lhs
, gnu_rhs
, gnat_node
);
5564 /* Some operations, e.g. comparisons of arrays, generate complex
5565 trees that need to be annotated while they are being built. */
5566 input_location
= saved_location
;
5567 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
5570 /* If this is a logical shift with the shift count not verified,
5571 we must return zero if it is too large. We cannot compensate
5572 above in this case. */
5573 if ((kind
== N_Op_Shift_Left
|| kind
== N_Op_Shift_Right
)
5574 && !Shift_Count_OK (gnat_node
))
5578 build_binary_op (GE_EXPR
, boolean_type_node
,
5580 convert (TREE_TYPE (gnu_rhs
),
5581 TYPE_SIZE (gnu_type
))),
5582 convert (gnu_type
, integer_zero_node
),
5587 case N_Conditional_Expression
:
5589 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
5590 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
5592 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
5594 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5596 = build_cond_expr (gnu_result_type
, gnu_cond
, gnu_true
, gnu_false
);
5601 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
5602 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5606 /* This case can apply to a boolean or a modular type.
5607 Fall through for a boolean operand since GNU_CODES is set
5608 up to handle this. */
5609 if (Is_Modular_Integer_Type (Etype (gnat_node
))
5610 || (Ekind (Etype (gnat_node
)) == E_Private_Type
5611 && Is_Modular_Integer_Type (Full_View (Etype (gnat_node
)))))
5613 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
5614 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5615 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
5620 /* ... fall through ... */
5622 case N_Op_Minus
: case N_Op_Abs
:
5623 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
5625 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
5626 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5628 gnu_result_type
= get_unpadded_type (Base_Type
5629 (Full_View (Etype (gnat_node
))));
5631 if (Do_Overflow_Check (gnat_node
)
5632 && !TYPE_UNSIGNED (gnu_result_type
)
5633 && !FLOAT_TYPE_P (gnu_result_type
))
5635 = build_unary_op_trapv (gnu_codes
[kind
],
5636 gnu_result_type
, gnu_expr
, gnat_node
);
5638 gnu_result
= build_unary_op (gnu_codes
[kind
],
5639 gnu_result_type
, gnu_expr
);
5646 bool ignore_init_type
= false;
5648 gnat_temp
= Expression (gnat_node
);
5650 /* The Expression operand can either be an N_Identifier or
5651 Expanded_Name, which must represent a type, or a
5652 N_Qualified_Expression, which contains both the object type and an
5653 initial value for the object. */
5654 if (Nkind (gnat_temp
) == N_Identifier
5655 || Nkind (gnat_temp
) == N_Expanded_Name
)
5656 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
5657 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
5659 Entity_Id gnat_desig_type
5660 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
5662 ignore_init_type
= Has_Constrained_Partial_View (gnat_desig_type
);
5663 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
5665 gnu_init
= maybe_unconstrained_array (gnu_init
);
5666 if (Do_Range_Check (Expression (gnat_temp
)))
5668 = emit_range_check (gnu_init
, gnat_desig_type
, gnat_temp
);
5670 if (Is_Elementary_Type (gnat_desig_type
)
5671 || Is_Constrained (gnat_desig_type
))
5673 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
5674 gnu_init
= convert (gnu_type
, gnu_init
);
5678 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
5679 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5680 gnu_type
= TREE_TYPE (gnu_init
);
5682 gnu_init
= convert (gnu_type
, gnu_init
);
5688 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5689 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
5690 Procedure_To_Call (gnat_node
),
5691 Storage_Pool (gnat_node
), gnat_node
,
5696 /**************************/
5697 /* Chapter 5: Statements */
5698 /**************************/
5701 gnu_result
= build1 (LABEL_EXPR
, void_type_node
,
5702 gnat_to_gnu (Identifier (gnat_node
)));
5705 case N_Null_Statement
:
5706 /* When not optimizing, turn null statements from source into gotos to
5707 the next statement that the middle-end knows how to preserve. */
5708 if (!optimize
&& Comes_From_Source (gnat_node
))
5710 tree stmt
, label
= create_label_decl (NULL_TREE
);
5711 start_stmt_group ();
5712 stmt
= build1 (GOTO_EXPR
, void_type_node
, label
);
5713 set_expr_location_from_node (stmt
, gnat_node
);
5715 stmt
= build1 (LABEL_EXPR
, void_type_node
, label
);
5716 set_expr_location_from_node (stmt
, gnat_node
);
5718 gnu_result
= end_stmt_group ();
5721 gnu_result
= alloc_stmt_list ();
5724 case N_Assignment_Statement
:
5725 /* Get the LHS and RHS of the statement and convert any reference to an
5726 unconstrained array into a reference to the underlying array. */
5727 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
5729 /* If the type has a size that overflows, convert this into raise of
5730 Storage_Error: execution shouldn't have gotten here anyway. */
5731 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
5732 && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))))
5733 gnu_result
= build_call_raise (SE_Object_Too_Large
, gnat_node
,
5734 N_Raise_Storage_Error
);
5735 else if (Nkind (Expression (gnat_node
)) == N_Function_Call
)
5737 = call_to_gnu (Expression (gnat_node
), &gnu_result_type
, gnu_lhs
,
5738 atomic_sync_required_p (Name (gnat_node
)));
5742 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
5744 /* If range check is needed, emit code to generate it. */
5745 if (Do_Range_Check (Expression (gnat_node
)))
5746 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)),
5749 if (atomic_sync_required_p (Name (gnat_node
)))
5750 gnu_result
= build_atomic_store (gnu_lhs
, gnu_rhs
);
5753 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
5755 /* If the type being assigned is an array type and the two sides are
5756 not completely disjoint, play safe and use memmove. But don't do
5757 it for a bit-packed array as it might not be byte-aligned. */
5758 if (TREE_CODE (gnu_result
) == MODIFY_EXPR
5759 && Is_Array_Type (Etype (Name (gnat_node
)))
5760 && !Is_Bit_Packed_Array (Etype (Name (gnat_node
)))
5761 && !(Forwards_OK (gnat_node
) && Backwards_OK (gnat_node
)))
5763 tree to
, from
, size
, to_ptr
, from_ptr
, t
;
5765 to
= TREE_OPERAND (gnu_result
, 0);
5766 from
= TREE_OPERAND (gnu_result
, 1);
5768 size
= TYPE_SIZE_UNIT (TREE_TYPE (from
));
5769 size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, from
);
5771 to_ptr
= build_fold_addr_expr (to
);
5772 from_ptr
= build_fold_addr_expr (from
);
5774 t
= builtin_decl_implicit (BUILT_IN_MEMMOVE
);
5775 gnu_result
= build_call_expr (t
, 3, to_ptr
, from_ptr
, size
);
5780 case N_If_Statement
:
5782 tree
*gnu_else_ptr
; /* Point to put next "else if" or "else". */
5784 /* Make the outer COND_EXPR. Avoid non-determinism. */
5785 gnu_result
= build3 (COND_EXPR
, void_type_node
,
5786 gnat_to_gnu (Condition (gnat_node
)),
5787 NULL_TREE
, NULL_TREE
);
5788 COND_EXPR_THEN (gnu_result
)
5789 = build_stmt_group (Then_Statements (gnat_node
), false);
5790 TREE_SIDE_EFFECTS (gnu_result
) = 1;
5791 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_result
);
5793 /* Now make a COND_EXPR for each of the "else if" parts. Put each
5794 into the previous "else" part and point to where to put any
5795 outer "else". Also avoid non-determinism. */
5796 if (Present (Elsif_Parts (gnat_node
)))
5797 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
5798 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
5800 gnu_expr
= build3 (COND_EXPR
, void_type_node
,
5801 gnat_to_gnu (Condition (gnat_temp
)),
5802 NULL_TREE
, NULL_TREE
);
5803 COND_EXPR_THEN (gnu_expr
)
5804 = build_stmt_group (Then_Statements (gnat_temp
), false);
5805 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
5806 set_expr_location_from_node (gnu_expr
, gnat_temp
);
5807 *gnu_else_ptr
= gnu_expr
;
5808 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
5811 *gnu_else_ptr
= build_stmt_group (Else_Statements (gnat_node
), false);
5815 case N_Case_Statement
:
5816 gnu_result
= Case_Statement_to_gnu (gnat_node
);
5819 case N_Loop_Statement
:
5820 gnu_result
= Loop_Statement_to_gnu (gnat_node
);
5823 case N_Block_Statement
:
5824 start_stmt_group ();
5826 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
5827 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
5829 gnu_result
= end_stmt_group ();
5831 if (Present (Identifier (gnat_node
)))
5832 mark_out_of_scope (Entity (Identifier (gnat_node
)));
5835 case N_Exit_Statement
:
5837 = build2 (EXIT_STMT
, void_type_node
,
5838 (Present (Condition (gnat_node
))
5839 ? gnat_to_gnu (Condition (gnat_node
)) : NULL_TREE
),
5840 (Present (Name (gnat_node
))
5841 ? get_gnu_tree (Entity (Name (gnat_node
)))
5842 : VEC_last (loop_info
, gnu_loop_stack
)->label
));
5845 case N_Return_Statement
:
5847 tree gnu_ret_obj
, gnu_ret_val
;
5849 /* If the subprogram is a function, we must return the expression. */
5850 if (Present (Expression (gnat_node
)))
5852 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
5854 /* If this function has copy-in/copy-out parameters, get the real
5855 object for the return. See Subprogram_to_gnu. */
5856 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
5857 gnu_ret_obj
= VEC_last (tree
, gnu_return_var_stack
);
5859 gnu_ret_obj
= DECL_RESULT (current_function_decl
);
5861 /* Get the GCC tree for the expression to be returned. */
5862 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
5864 /* Do not remove the padding from GNU_RET_VAL if the inner type is
5865 self-referential since we want to allocate the fixed size. */
5866 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
5867 && TYPE_IS_PADDING_P
5868 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0)))
5869 && CONTAINS_PLACEHOLDER_P
5870 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
))))
5871 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
5873 /* If the function returns by direct reference, return a pointer
5874 to the return value. */
5875 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
)
5876 || By_Ref (gnat_node
))
5877 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
5879 /* Otherwise, if it returns an unconstrained array, we have to
5880 allocate a new version of the result and return it. */
5881 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
))
5883 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
5884 gnu_ret_val
= build_allocator (TREE_TYPE (gnu_ret_val
),
5886 TREE_TYPE (gnu_ret_obj
),
5887 Procedure_To_Call (gnat_node
),
5888 Storage_Pool (gnat_node
),
5892 /* If the function returns by invisible reference, dereference
5893 the pointer it is passed using the type of the return value
5894 and build the copy operation manually. This ensures that we
5895 don't copy too much data, for example if the return type is
5896 unconstrained with a maximum size. */
5897 if (TREE_ADDRESSABLE (gnu_subprog_type
))
5900 = build_unary_op (INDIRECT_REF
, TREE_TYPE (gnu_ret_val
),
5902 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5903 gnu_ret_deref
, gnu_ret_val
);
5904 add_stmt_with_node (gnu_result
, gnat_node
);
5905 gnu_ret_val
= NULL_TREE
;
5910 gnu_ret_obj
= NULL_TREE
;
5911 gnu_ret_val
= NULL_TREE
;
5914 /* If we have a return label defined, convert this into a branch to
5915 that label. The return proper will be handled elsewhere. */
5916 if (VEC_last (tree
, gnu_return_label_stack
))
5919 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_ret_obj
,
5922 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
5923 VEC_last (tree
, gnu_return_label_stack
));
5925 /* When not optimizing, make sure the return is preserved. */
5926 if (!optimize
&& Comes_From_Source (gnat_node
))
5927 DECL_ARTIFICIAL (VEC_last (tree
, gnu_return_label_stack
)) = 0;
5930 /* Otherwise, build a regular return. */
5932 gnu_result
= build_return_expr (gnu_ret_obj
, gnu_ret_val
);
5936 case N_Goto_Statement
:
5937 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
5938 gnat_to_gnu (Name (gnat_node
)));
5941 /***************************/
5942 /* Chapter 6: Subprograms */
5943 /***************************/
5945 case N_Subprogram_Declaration
:
5946 /* Unless there is a freeze node, declare the subprogram. We consider
5947 this a "definition" even though we're not generating code for
5948 the subprogram because we will be making the corresponding GCC
5951 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
5952 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
5954 gnu_result
= alloc_stmt_list ();
5957 case N_Abstract_Subprogram_Declaration
:
5958 /* This subprogram doesn't exist for code generation purposes, but we
5959 have to elaborate the types of any parameters and result, unless
5960 they are imported types (nothing to generate in this case).
5962 The parameter list may contain types with freeze nodes, e.g. not null
5963 subtypes, so the subprogram itself may carry a freeze node, in which
5964 case its elaboration must be deferred. */
5966 /* Process the parameter types first. */
5967 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
5969 = First_Formal_With_Extras
5970 (Defining_Entity (Specification (gnat_node
)));
5971 Present (gnat_temp
);
5972 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
5973 if (Is_Itype (Etype (gnat_temp
))
5974 && !From_With_Type (Etype (gnat_temp
)))
5975 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
5977 /* Then the result type, set to Standard_Void_Type for procedures. */
5979 Entity_Id gnat_temp_type
5980 = Etype (Defining_Entity (Specification (gnat_node
)));
5982 if (Is_Itype (gnat_temp_type
) && !From_With_Type (gnat_temp_type
))
5983 gnat_to_gnu_entity (Etype (gnat_temp_type
), NULL_TREE
, 0);
5986 gnu_result
= alloc_stmt_list ();
5989 case N_Defining_Program_Unit_Name
:
5990 /* For a child unit identifier go up a level to get the specification.
5991 We get this when we try to find the spec of a child unit package
5992 that is the compilation unit being compiled. */
5993 gnu_result
= gnat_to_gnu (Parent (gnat_node
));
5996 case N_Subprogram_Body
:
5997 Subprogram_Body_to_gnu (gnat_node
);
5998 gnu_result
= alloc_stmt_list ();
6001 case N_Function_Call
:
6002 case N_Procedure_Call_Statement
:
6003 gnu_result
= call_to_gnu (gnat_node
, &gnu_result_type
, NULL_TREE
, false);
6006 /************************/
6007 /* Chapter 7: Packages */
6008 /************************/
6010 case N_Package_Declaration
:
6011 gnu_result
= gnat_to_gnu (Specification (gnat_node
));
6014 case N_Package_Specification
:
6016 start_stmt_group ();
6017 process_decls (Visible_Declarations (gnat_node
),
6018 Private_Declarations (gnat_node
), Empty
, true, true);
6019 gnu_result
= end_stmt_group ();
6022 case N_Package_Body
:
6024 /* If this is the body of a generic package - do nothing. */
6025 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
6027 gnu_result
= alloc_stmt_list ();
6031 start_stmt_group ();
6032 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
6034 if (Present (Handled_Statement_Sequence (gnat_node
)))
6035 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
6037 gnu_result
= end_stmt_group ();
6040 /********************************/
6041 /* Chapter 8: Visibility Rules */
6042 /********************************/
6044 case N_Use_Package_Clause
:
6045 case N_Use_Type_Clause
:
6046 /* Nothing to do here - but these may appear in list of declarations. */
6047 gnu_result
= alloc_stmt_list ();
6050 /*********************/
6051 /* Chapter 9: Tasks */
6052 /*********************/
6054 case N_Protected_Type_Declaration
:
6055 gnu_result
= alloc_stmt_list ();
6058 case N_Single_Task_Declaration
:
6059 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
6060 gnu_result
= alloc_stmt_list ();
6063 /*********************************************************/
6064 /* Chapter 10: Program Structure and Compilation Issues */
6065 /*********************************************************/
6067 case N_Compilation_Unit
:
6068 /* This is not called for the main unit on which gigi is invoked. */
6069 Compilation_Unit_to_gnu (gnat_node
);
6070 gnu_result
= alloc_stmt_list ();
6073 case N_Subprogram_Body_Stub
:
6074 case N_Package_Body_Stub
:
6075 case N_Protected_Body_Stub
:
6076 case N_Task_Body_Stub
:
6077 /* Simply process whatever unit is being inserted. */
6078 gnu_result
= gnat_to_gnu (Unit (Library_Unit (gnat_node
)));
6082 gnu_result
= gnat_to_gnu (Proper_Body (gnat_node
));
6085 /***************************/
6086 /* Chapter 11: Exceptions */
6087 /***************************/
6089 case N_Handled_Sequence_Of_Statements
:
6090 /* If there is an At_End procedure attached to this node, and the EH
6091 mechanism is SJLJ, we must have at least a corresponding At_End
6092 handler, unless the No_Exception_Handlers restriction is set. */
6093 gcc_assert (type_annotate_only
6094 || Exception_Mechanism
!= Setjmp_Longjmp
6095 || No (At_End_Proc (gnat_node
))
6096 || Present (Exception_Handlers (gnat_node
))
6097 || No_Exception_Handlers_Set ());
6099 gnu_result
= Handled_Sequence_Of_Statements_to_gnu (gnat_node
);
6102 case N_Exception_Handler
:
6103 if (Exception_Mechanism
== Setjmp_Longjmp
)
6104 gnu_result
= Exception_Handler_to_gnu_sjlj (gnat_node
);
6105 else if (Exception_Mechanism
== Back_End_Exceptions
)
6106 gnu_result
= Exception_Handler_to_gnu_zcx (gnat_node
);
6111 case N_Raise_Statement
:
6112 /* Only for reraise in back-end exceptions mode. */
6113 gcc_assert (No (Name (gnat_node
))
6114 && Exception_Mechanism
== Back_End_Exceptions
);
6116 start_stmt_group ();
6119 /* Clear the current exception pointer so that the occurrence won't be
6121 gnu_expr
= create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE
,
6122 ptr_type_node
, gnu_incoming_exc_ptr
,
6123 false, false, false, false, NULL
, gnat_node
);
6125 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_incoming_exc_ptr
,
6126 convert (ptr_type_node
, integer_zero_node
)));
6127 add_stmt (build_call_n_expr (reraise_zcx_decl
, 1, gnu_expr
));
6129 gnu_result
= end_stmt_group ();
6132 case N_Push_Constraint_Error_Label
:
6133 push_exception_label_stack (&gnu_constraint_error_label_stack
,
6134 Exception_Label (gnat_node
));
6137 case N_Push_Storage_Error_Label
:
6138 push_exception_label_stack (&gnu_storage_error_label_stack
,
6139 Exception_Label (gnat_node
));
6142 case N_Push_Program_Error_Label
:
6143 push_exception_label_stack (&gnu_program_error_label_stack
,
6144 Exception_Label (gnat_node
));
6147 case N_Pop_Constraint_Error_Label
:
6148 VEC_pop (tree
, gnu_constraint_error_label_stack
);
6151 case N_Pop_Storage_Error_Label
:
6152 VEC_pop (tree
, gnu_storage_error_label_stack
);
6155 case N_Pop_Program_Error_Label
:
6156 VEC_pop (tree
, gnu_program_error_label_stack
);
6159 /******************************/
6160 /* Chapter 12: Generic Units */
6161 /******************************/
6163 case N_Generic_Function_Renaming_Declaration
:
6164 case N_Generic_Package_Renaming_Declaration
:
6165 case N_Generic_Procedure_Renaming_Declaration
:
6166 case N_Generic_Package_Declaration
:
6167 case N_Generic_Subprogram_Declaration
:
6168 case N_Package_Instantiation
:
6169 case N_Procedure_Instantiation
:
6170 case N_Function_Instantiation
:
6171 /* These nodes can appear on a declaration list but there is nothing to
6172 to be done with them. */
6173 gnu_result
= alloc_stmt_list ();
6176 /**************************************************/
6177 /* Chapter 13: Representation Clauses and */
6178 /* Implementation-Dependent Features */
6179 /**************************************************/
6181 case N_Attribute_Definition_Clause
:
6182 gnu_result
= alloc_stmt_list ();
6184 /* The only one we need to deal with is 'Address since, for the others,
6185 the front-end puts the information elsewhere. */
6186 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
)
6189 /* And we only deal with 'Address if the object has a Freeze node. */
6190 gnat_temp
= Entity (Name (gnat_node
));
6191 if (No (Freeze_Node (gnat_temp
)))
6194 /* Get the value to use as the address and save it as the equivalent
6195 for the object. When it is frozen, gnat_to_gnu_entity will do the
6197 save_gnu_tree (gnat_temp
, gnat_to_gnu (Expression (gnat_node
)), true);
6200 case N_Enumeration_Representation_Clause
:
6201 case N_Record_Representation_Clause
:
6203 /* We do nothing with these. SEM puts the information elsewhere. */
6204 gnu_result
= alloc_stmt_list ();
6207 case N_Code_Statement
:
6208 if (!type_annotate_only
)
6210 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
6211 tree gnu_inputs
= NULL_TREE
, gnu_outputs
= NULL_TREE
;
6212 tree gnu_clobbers
= NULL_TREE
, tail
;
6213 bool allows_mem
, allows_reg
, fake
;
6214 int ninputs
, noutputs
, i
;
6215 const char **oconstraints
;
6216 const char *constraint
;
6219 /* First retrieve the 3 operand lists built by the front-end. */
6220 Setup_Asm_Outputs (gnat_node
);
6221 while (Present (gnat_temp
= Asm_Output_Variable ()))
6223 tree gnu_value
= gnat_to_gnu (gnat_temp
);
6224 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
6225 (Asm_Output_Constraint ()));
6227 gnu_outputs
= tree_cons (gnu_constr
, gnu_value
, gnu_outputs
);
6231 Setup_Asm_Inputs (gnat_node
);
6232 while (Present (gnat_temp
= Asm_Input_Value ()))
6234 tree gnu_value
= gnat_to_gnu (gnat_temp
);
6235 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
6236 (Asm_Input_Constraint ()));
6238 gnu_inputs
= tree_cons (gnu_constr
, gnu_value
, gnu_inputs
);
6242 Clobber_Setup (gnat_node
);
6243 while ((clobber
= Clobber_Get_Next ()))
6245 = tree_cons (NULL_TREE
,
6246 build_string (strlen (clobber
) + 1, clobber
),
6249 /* Then perform some standard checking and processing on the
6250 operands. In particular, mark them addressable if needed. */
6251 gnu_outputs
= nreverse (gnu_outputs
);
6252 noutputs
= list_length (gnu_outputs
);
6253 gnu_inputs
= nreverse (gnu_inputs
);
6254 ninputs
= list_length (gnu_inputs
);
6255 oconstraints
= XALLOCAVEC (const char *, noutputs
);
6257 for (i
= 0, tail
= gnu_outputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
6259 tree output
= TREE_VALUE (tail
);
6261 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
6262 oconstraints
[i
] = constraint
;
6264 if (parse_output_constraint (&constraint
, i
, ninputs
, noutputs
,
6265 &allows_mem
, &allows_reg
, &fake
))
6267 /* If the operand is going to end up in memory,
6268 mark it addressable. Note that we don't test
6269 allows_mem like in the input case below; this
6270 is modelled on the C front-end. */
6273 output
= remove_conversions (output
, false);
6274 if (TREE_CODE (output
) == CONST_DECL
6275 && DECL_CONST_CORRESPONDING_VAR (output
))
6276 output
= DECL_CONST_CORRESPONDING_VAR (output
);
6277 if (!gnat_mark_addressable (output
))
6278 output
= error_mark_node
;
6282 output
= error_mark_node
;
6284 TREE_VALUE (tail
) = output
;
6287 for (i
= 0, tail
= gnu_inputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
6289 tree input
= TREE_VALUE (tail
);
6291 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
6293 if (parse_input_constraint (&constraint
, i
, ninputs
, noutputs
,
6295 &allows_mem
, &allows_reg
))
6297 /* If the operand is going to end up in memory,
6298 mark it addressable. */
6299 if (!allows_reg
&& allows_mem
)
6301 input
= remove_conversions (input
, false);
6302 if (TREE_CODE (input
) == CONST_DECL
6303 && DECL_CONST_CORRESPONDING_VAR (input
))
6304 input
= DECL_CONST_CORRESPONDING_VAR (input
);
6305 if (!gnat_mark_addressable (input
))
6306 input
= error_mark_node
;
6310 input
= error_mark_node
;
6312 TREE_VALUE (tail
) = input
;
6315 gnu_result
= build5 (ASM_EXPR
, void_type_node
,
6316 gnu_template
, gnu_outputs
,
6317 gnu_inputs
, gnu_clobbers
, NULL_TREE
);
6318 ASM_VOLATILE_P (gnu_result
) = Is_Asm_Volatile (gnat_node
);
6321 gnu_result
= alloc_stmt_list ();
6329 case N_Expression_With_Actions
:
6330 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6331 /* This construct doesn't define a scope so we don't wrap the statement
6332 list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it
6334 gnu_result
= build_stmt_group (Actions (gnat_node
), false);
6335 gnu_result
= build1 (SAVE_EXPR
, void_type_node
, gnu_result
);
6336 TREE_SIDE_EFFECTS (gnu_result
) = 1;
6337 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
6339 = build_compound_expr (TREE_TYPE (gnu_expr
), gnu_result
, gnu_expr
);
6342 case N_Freeze_Entity
:
6343 start_stmt_group ();
6344 process_freeze_entity (gnat_node
);
6345 process_decls (Actions (gnat_node
), Empty
, Empty
, true, true);
6346 gnu_result
= end_stmt_group ();
6349 case N_Itype_Reference
:
6350 if (!present_gnu_tree (Itype (gnat_node
)))
6351 process_type (Itype (gnat_node
));
6353 gnu_result
= alloc_stmt_list ();
6356 case N_Free_Statement
:
6357 if (!type_annotate_only
)
6359 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
6360 tree gnu_ptr_type
= TREE_TYPE (gnu_ptr
);
6362 tree gnu_actual_obj_type
= 0;
6365 /* If this is a thin pointer, we must dereference it to create
6366 a fat pointer, then go back below to a thin pointer. The
6367 reason for this is that we need a fat pointer someplace in
6368 order to properly compute the size. */
6369 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
6370 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
6371 build_unary_op (INDIRECT_REF
, NULL_TREE
,
6374 /* If this is an unconstrained array, we know the object must
6375 have been allocated with the template in front of the object.
6376 So pass the template address, but get the total size. Do this
6377 by converting to a thin pointer. */
6378 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
6380 = convert (build_pointer_type
6381 (TYPE_OBJECT_RECORD_TYPE
6382 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
6385 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
6387 if (Present (Actual_Designated_Subtype (gnat_node
)))
6390 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node
));
6392 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
))
6394 = build_unc_object_type_from_ptr (gnu_ptr_type
,
6395 gnu_actual_obj_type
,
6396 get_identifier ("DEALLOC"),
6400 gnu_actual_obj_type
= gnu_obj_type
;
6402 gnu_obj_size
= TYPE_SIZE_UNIT (gnu_actual_obj_type
);
6404 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
6405 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
6407 tree gnu_char_ptr_type
6408 = build_pointer_type (unsigned_char_type_node
);
6409 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
6410 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
6411 gnu_ptr
= build_binary_op (POINTER_PLUS_EXPR
, gnu_char_ptr_type
,
6416 = build_call_alloc_dealloc (gnu_ptr
, gnu_obj_size
, gnu_obj_type
,
6417 Procedure_To_Call (gnat_node
),
6418 Storage_Pool (gnat_node
),
6423 case N_Raise_Constraint_Error
:
6424 case N_Raise_Program_Error
:
6425 case N_Raise_Storage_Error
:
6427 const int reason
= UI_To_Int (Reason (gnat_node
));
6428 const Node_Id gnat_cond
= Condition (gnat_node
);
6429 const bool with_extra_info
= Exception_Extra_Info
6430 && !No_Exception_Handlers_Set ()
6431 && !get_exception_label (kind
);
6432 tree gnu_cond
= NULL_TREE
;
6434 if (type_annotate_only
)
6436 gnu_result
= alloc_stmt_list ();
6440 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6444 case CE_Access_Check_Failed
:
6445 if (with_extra_info
)
6446 gnu_result
= build_call_raise_column (reason
, gnat_node
);
6449 case CE_Index_Check_Failed
:
6450 case CE_Range_Check_Failed
:
6451 case CE_Invalid_Data
:
6452 if (Present (gnat_cond
)
6453 && Nkind (gnat_cond
) == N_Op_Not
6454 && Nkind (Right_Opnd (gnat_cond
)) == N_In
6455 && Nkind (Right_Opnd (Right_Opnd (gnat_cond
))) == N_Range
)
6457 Node_Id gnat_index
= Left_Opnd (Right_Opnd (gnat_cond
));
6458 Node_Id gnat_type
= Etype (gnat_index
);
6459 Node_Id gnat_range
= Right_Opnd (Right_Opnd (gnat_cond
));
6460 tree gnu_index
= gnat_to_gnu (gnat_index
);
6461 tree gnu_low_bound
= gnat_to_gnu (Low_Bound (gnat_range
));
6462 tree gnu_high_bound
= gnat_to_gnu (High_Bound (gnat_range
));
6463 struct range_check_info_d
*rci
;
6466 && Known_Esize (gnat_type
)
6467 && UI_To_Int (Esize (gnat_type
)) <= 32)
6469 = build_call_raise_range (reason
, gnat_node
, gnu_index
,
6470 gnu_low_bound
, gnu_high_bound
);
6472 /* If loop unswitching is enabled, we try to compute invariant
6473 conditions for checks applied to iteration variables, i.e.
6474 conditions that are both independent of the variable and
6475 necessary in order for the check to fail in the course of
6476 some iteration, and prepend them to the original condition
6477 of the checks. This will make it possible later for the
6478 loop unswitching pass to replace the loop with two loops,
6479 one of which has the checks eliminated and the other has
6480 the original checks reinstated, and a run time selection.
6481 The former loop will be suitable for vectorization. */
6482 if (flag_unswitch_loops
6483 && (gnu_low_bound
= gnat_invariant_expr (gnu_low_bound
))
6484 && (gnu_high_bound
= gnat_invariant_expr (gnu_high_bound
))
6485 && (rci
= push_range_check_info (gnu_index
)))
6487 rci
->low_bound
= gnu_low_bound
;
6488 rci
->high_bound
= gnu_high_bound
;
6489 rci
->type
= gnat_to_gnu_type (gnat_type
);
6490 rci
->invariant_cond
= build1 (SAVE_EXPR
, boolean_type_node
,
6492 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6494 rci
->invariant_cond
,
6495 gnat_to_gnu (gnat_cond
));
6504 if (gnu_result
== error_mark_node
)
6505 gnu_result
= build_call_raise (reason
, gnat_node
, kind
);
6507 set_expr_location_from_node (gnu_result
, gnat_node
);
6509 /* If the type is VOID, this is a statement, so we need to generate
6510 the code for the call. Handle a condition, if there is one. */
6511 if (VOID_TYPE_P (gnu_result_type
))
6513 if (Present (gnat_cond
))
6516 gnu_cond
= gnat_to_gnu (gnat_cond
);
6518 = build3 (COND_EXPR
, void_type_node
, gnu_cond
, gnu_result
,
6519 alloc_stmt_list ());
6523 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
, gnu_result
);
6527 case N_Validate_Unchecked_Conversion
:
6529 Entity_Id gnat_target_type
= Target_Type (gnat_node
);
6530 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
6531 tree gnu_target_type
= gnat_to_gnu_type (gnat_target_type
);
6533 /* No need for any warning in this case. */
6534 if (!flag_strict_aliasing
)
6537 /* If the result is a pointer type, see if we are either converting
6538 from a non-pointer or from a pointer to a type with a different
6539 alias set and warn if so. If the result is defined in the same
6540 unit as this unchecked conversion, we can allow this because we
6541 can know to make the pointer type behave properly. */
6542 else if (POINTER_TYPE_P (gnu_target_type
)
6543 && !In_Same_Source_Unit (gnat_target_type
, gnat_node
)
6544 && !No_Strict_Aliasing (Underlying_Type (gnat_target_type
)))
6546 tree gnu_source_desig_type
= POINTER_TYPE_P (gnu_source_type
)
6547 ? TREE_TYPE (gnu_source_type
)
6549 tree gnu_target_desig_type
= TREE_TYPE (gnu_target_type
);
6551 if ((TYPE_DUMMY_P (gnu_target_desig_type
)
6552 || get_alias_set (gnu_target_desig_type
) != 0)
6553 && (!POINTER_TYPE_P (gnu_source_type
)
6554 || (TYPE_DUMMY_P (gnu_source_desig_type
)
6555 != TYPE_DUMMY_P (gnu_target_desig_type
))
6556 || (TYPE_DUMMY_P (gnu_source_desig_type
)
6557 && gnu_source_desig_type
!= gnu_target_desig_type
)
6558 || !alias_sets_conflict_p
6559 (get_alias_set (gnu_source_desig_type
),
6560 get_alias_set (gnu_target_desig_type
))))
6563 ("?possible aliasing problem for type&",
6564 gnat_node
, Target_Type (gnat_node
));
6566 ("\\?use -fno-strict-aliasing switch for references",
6569 ("\\?or use `pragma No_Strict_Aliasing (&);`",
6570 gnat_node
, Target_Type (gnat_node
));
6574 /* But if the result is a fat pointer type, we have no mechanism to
6575 do that, so we unconditionally warn in problematic cases. */
6576 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type
))
6578 tree gnu_source_array_type
6579 = TYPE_IS_FAT_POINTER_P (gnu_source_type
)
6580 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type
)))
6582 tree gnu_target_array_type
6583 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type
)));
6585 if ((TYPE_DUMMY_P (gnu_target_array_type
)
6586 || get_alias_set (gnu_target_array_type
) != 0)
6587 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type
)
6588 || (TYPE_DUMMY_P (gnu_source_array_type
)
6589 != TYPE_DUMMY_P (gnu_target_array_type
))
6590 || (TYPE_DUMMY_P (gnu_source_array_type
)
6591 && gnu_source_array_type
!= gnu_target_array_type
)
6592 || !alias_sets_conflict_p
6593 (get_alias_set (gnu_source_array_type
),
6594 get_alias_set (gnu_target_array_type
))))
6597 ("?possible aliasing problem for type&",
6598 gnat_node
, Target_Type (gnat_node
));
6600 ("\\?use -fno-strict-aliasing switch for references",
6605 gnu_result
= alloc_stmt_list ();
6609 /* SCIL nodes require no processing for GCC. Other nodes should only
6610 be present when annotating types. */
6611 gcc_assert (IN (kind
, N_SCIL_Node
) || type_annotate_only
);
6612 gnu_result
= alloc_stmt_list ();
6615 /* If we pushed the processing of the elaboration routine, pop it back. */
6616 if (went_into_elab_proc
)
6617 current_function_decl
= NULL_TREE
;
6619 /* When not optimizing, turn boolean rvalues B into B != false tests
6620 so that the code just below can put the location information of the
6621 reference to B on the inequality operator for better debug info. */
6623 && TREE_CODE (gnu_result
) != INTEGER_CST
6624 && (kind
== N_Identifier
6625 || kind
== N_Expanded_Name
6626 || kind
== N_Explicit_Dereference
6627 || kind
== N_Function_Call
6628 || kind
== N_Indexed_Component
6629 || kind
== N_Selected_Component
)
6630 && TREE_CODE (get_base_type (gnu_result_type
)) == BOOLEAN_TYPE
6631 && !lvalue_required_p (gnat_node
, gnu_result_type
, false, false, false))
6632 gnu_result
= build_binary_op (NE_EXPR
, gnu_result_type
,
6633 convert (gnu_result_type
, gnu_result
),
6634 convert (gnu_result_type
,
6635 boolean_false_node
));
6637 /* Set the location information on the result. Note that we may have
6638 no result if we tried to build a CALL_EXPR node to a procedure with
6639 no side-effects and optimization is enabled. */
6640 if (gnu_result
&& EXPR_P (gnu_result
))
6641 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
6643 /* If we're supposed to return something of void_type, it means we have
6644 something we're elaborating for effect, so just return. */
6645 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
6648 /* If the result is a constant that overflowed, raise Constraint_Error. */
6649 if (TREE_CODE (gnu_result
) == INTEGER_CST
&& TREE_OVERFLOW (gnu_result
))
6651 post_error ("?`Constraint_Error` will be raised at run time", gnat_node
);
6653 = build1 (NULL_EXPR
, gnu_result_type
,
6654 build_call_raise (CE_Overflow_Check_Failed
, gnat_node
,
6655 N_Raise_Constraint_Error
));
6658 /* If our result has side-effects and is of an unconstrained type,
6659 make a SAVE_EXPR so that we can be sure it will only be referenced
6660 once. Note we must do this before any conversions. */
6661 if (TREE_SIDE_EFFECTS (gnu_result
)
6662 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
6663 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))))
6664 gnu_result
= gnat_stabilize_reference (gnu_result
, false, NULL
);
6666 /* Now convert the result to the result type, unless we are in one of the
6669 1. If this is the LHS of an assignment or an actual parameter of a
6670 call, return the result almost unmodified since the RHS will have
6671 to be converted to our type in that case, unless the result type
6672 has a simpler size. Likewise if there is just a no-op unchecked
6673 conversion in-between. Similarly, don't convert integral types
6674 that are the operands of an unchecked conversion since we need
6675 to ignore those conversions (for 'Valid).
6677 2. If we have a label (which doesn't have any well-defined type), a
6678 field or an error, return the result almost unmodified. Similarly,
6679 if the two types are record types with the same name, don't convert.
6680 This will be the case when we are converting from a packable version
6681 of a type to its original type and we need those conversions to be
6682 NOPs in order for assignments into these types to work properly.
6684 3. If the type is void or if we have no result, return error_mark_node
6685 to show we have no result.
6687 4. Finally, if the type of the result is already correct. */
6689 if (Present (Parent (gnat_node
))
6690 && (lhs_or_actual_p (gnat_node
)
6691 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
6692 && unchecked_conversion_nop (Parent (gnat_node
)))
6693 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
6694 && !AGGREGATE_TYPE_P (gnu_result_type
)
6695 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))))
6696 && !(TYPE_SIZE (gnu_result_type
)
6697 && TYPE_SIZE (TREE_TYPE (gnu_result
))
6698 && (AGGREGATE_TYPE_P (gnu_result_type
)
6699 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
6700 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
6701 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
6703 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
6704 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
6705 && (CONTAINS_PLACEHOLDER_P
6706 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
6707 && !(TREE_CODE (gnu_result_type
) == RECORD_TYPE
6708 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type
))))
6710 /* Remove padding only if the inner object is of self-referential
6711 size: in that case it must be an object of unconstrained type
6712 with a default discriminant and we want to avoid copying too
6714 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
6715 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
6716 (TREE_TYPE (gnu_result
))))))
6717 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
6721 else if (TREE_CODE (gnu_result
) == LABEL_DECL
6722 || TREE_CODE (gnu_result
) == FIELD_DECL
6723 || TREE_CODE (gnu_result
) == ERROR_MARK
6724 || (TYPE_NAME (gnu_result_type
)
6725 == TYPE_NAME (TREE_TYPE (gnu_result
))
6726 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
6727 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
))
6729 /* Remove any padding. */
6730 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
6731 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
6735 else if (gnu_result
== error_mark_node
|| gnu_result_type
== void_type_node
)
6736 gnu_result
= error_mark_node
;
6738 else if (gnu_result_type
!= TREE_TYPE (gnu_result
))
6739 gnu_result
= convert (gnu_result_type
, gnu_result
);
6741 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
6742 while ((TREE_CODE (gnu_result
) == NOP_EXPR
6743 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
6744 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
6745 gnu_result
= TREE_OPERAND (gnu_result
, 0);
6750 /* Subroutine of above to push the exception label stack. GNU_STACK is
6751 a pointer to the stack to update and GNAT_LABEL, if present, is the
6752 label to push onto the stack. */
6755 push_exception_label_stack (VEC(tree
,gc
) **gnu_stack
, Entity_Id gnat_label
)
6757 tree gnu_label
= (Present (gnat_label
)
6758 ? gnat_to_gnu_entity (gnat_label
, NULL_TREE
, 0)
6761 VEC_safe_push (tree
, gc
, *gnu_stack
, gnu_label
);
6764 /* Record the current code position in GNAT_NODE. */
6767 record_code_position (Node_Id gnat_node
)
6769 tree stmt_stmt
= build1 (STMT_STMT
, void_type_node
, NULL_TREE
);
6771 add_stmt_with_node (stmt_stmt
, gnat_node
);
6772 save_gnu_tree (gnat_node
, stmt_stmt
, true);
6775 /* Insert the code for GNAT_NODE at the position saved for that node. */
6778 insert_code_for (Node_Id gnat_node
)
6780 STMT_STMT_STMT (get_gnu_tree (gnat_node
)) = gnat_to_gnu (gnat_node
);
6781 save_gnu_tree (gnat_node
, NULL_TREE
, true);
6784 /* Start a new statement group chained to the previous group. */
6787 start_stmt_group (void)
6789 struct stmt_group
*group
= stmt_group_free_list
;
6791 /* First see if we can get one from the free list. */
6793 stmt_group_free_list
= group
->previous
;
6795 group
= ggc_alloc_stmt_group ();
6797 group
->previous
= current_stmt_group
;
6798 group
->stmt_list
= group
->block
= group
->cleanups
= NULL_TREE
;
6799 current_stmt_group
= group
;
6802 /* Add GNU_STMT to the current statement group. If it is an expression with
6803 no effects, it is ignored. */
6806 add_stmt (tree gnu_stmt
)
6808 append_to_statement_list (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
6811 /* Similar, but the statement is always added, regardless of side-effects. */
6814 add_stmt_force (tree gnu_stmt
)
6816 append_to_statement_list_force (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
6819 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
6822 add_stmt_with_node (tree gnu_stmt
, Node_Id gnat_node
)
6824 if (Present (gnat_node
))
6825 set_expr_location_from_node (gnu_stmt
, gnat_node
);
6826 add_stmt (gnu_stmt
);
6829 /* Similar, but the statement is always added, regardless of side-effects. */
6832 add_stmt_with_node_force (tree gnu_stmt
, Node_Id gnat_node
)
6834 if (Present (gnat_node
))
6835 set_expr_location_from_node (gnu_stmt
, gnat_node
);
6836 add_stmt_force (gnu_stmt
);
6839 /* Add a declaration statement for GNU_DECL to the current statement group.
6840 Get SLOC from Entity_Id. */
6843 add_decl_expr (tree gnu_decl
, Entity_Id gnat_entity
)
6845 tree type
= TREE_TYPE (gnu_decl
);
6846 tree gnu_stmt
, gnu_init
, t
;
6848 /* If this is a variable that Gigi is to ignore, we may have been given
6849 an ERROR_MARK. So test for it. We also might have been given a
6850 reference for a renaming. So only do something for a decl. Also
6851 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
6852 if (!DECL_P (gnu_decl
)
6853 || (TREE_CODE (gnu_decl
) == TYPE_DECL
6854 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
))
6857 gnu_stmt
= build1 (DECL_EXPR
, void_type_node
, gnu_decl
);
6859 /* If we are global, we don't want to actually output the DECL_EXPR for
6860 this decl since we already have evaluated the expressions in the
6861 sizes and positions as globals and doing it again would be wrong. */
6862 if (global_bindings_p ())
6864 /* Mark everything as used to prevent node sharing with subprograms.
6865 Note that walk_tree knows how to deal with TYPE_DECL, but neither
6866 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
6867 MARK_VISITED (gnu_stmt
);
6868 if (TREE_CODE (gnu_decl
) == VAR_DECL
6869 || TREE_CODE (gnu_decl
) == CONST_DECL
)
6871 MARK_VISITED (DECL_SIZE (gnu_decl
));
6872 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl
));
6873 MARK_VISITED (DECL_INITIAL (gnu_decl
));
6875 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
6876 else if (TREE_CODE (gnu_decl
) == TYPE_DECL
6877 && RECORD_OR_UNION_TYPE_P (type
)
6878 && !TYPE_FAT_POINTER_P (type
))
6879 MARK_VISITED (TYPE_ADA_SIZE (type
));
6881 else if (!DECL_EXTERNAL (gnu_decl
))
6882 add_stmt_with_node (gnu_stmt
, gnat_entity
);
6884 /* If this is a variable and an initializer is attached to it, it must be
6885 valid for the context. Similar to init_const in create_var_decl_1. */
6886 if (TREE_CODE (gnu_decl
) == VAR_DECL
6887 && (gnu_init
= DECL_INITIAL (gnu_decl
)) != NULL_TREE
6888 && (!gnat_types_compatible_p (type
, TREE_TYPE (gnu_init
))
6889 || (TREE_STATIC (gnu_decl
)
6890 && !initializer_constant_valid_p (gnu_init
,
6891 TREE_TYPE (gnu_init
)))))
6893 /* If GNU_DECL has a padded type, convert it to the unpadded
6894 type so the assignment is done properly. */
6895 if (TYPE_IS_PADDING_P (type
))
6896 t
= convert (TREE_TYPE (TYPE_FIELDS (type
)), gnu_decl
);
6900 gnu_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, t
, gnu_init
);
6902 DECL_INITIAL (gnu_decl
) = NULL_TREE
;
6903 if (TREE_READONLY (gnu_decl
))
6905 TREE_READONLY (gnu_decl
) = 0;
6906 DECL_READONLY_ONCE_ELAB (gnu_decl
) = 1;
6909 add_stmt_with_node (gnu_stmt
, gnat_entity
);
6913 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
6916 mark_visited_r (tree
*tp
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
6920 if (TREE_VISITED (t
))
6923 /* Don't mark a dummy type as visited because we want to mark its sizes
6924 and fields once it's filled in. */
6925 else if (!TYPE_IS_DUMMY_P (t
))
6926 TREE_VISITED (t
) = 1;
6929 TYPE_SIZES_GIMPLIFIED (t
) = 1;
6934 /* Mark nodes rooted at T with TREE_VISITED and types as having their
6935 sized gimplified. We use this to indicate all variable sizes and
6936 positions in global types may not be shared by any subprogram. */
6939 mark_visited (tree t
)
6941 walk_tree (&t
, mark_visited_r
, NULL
, NULL
);
6944 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
6945 set its location to that of GNAT_NODE if present. */
6948 add_cleanup (tree gnu_cleanup
, Node_Id gnat_node
)
6950 if (Present (gnat_node
))
6951 set_expr_location_from_node (gnu_cleanup
, gnat_node
);
6952 append_to_statement_list (gnu_cleanup
, ¤t_stmt_group
->cleanups
);
6955 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
6958 set_block_for_group (tree gnu_block
)
6960 gcc_assert (!current_stmt_group
->block
);
6961 current_stmt_group
->block
= gnu_block
;
6964 /* Return code corresponding to the current code group. It is normally
6965 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
6966 BLOCK or cleanups were set. */
6969 end_stmt_group (void)
6971 struct stmt_group
*group
= current_stmt_group
;
6972 tree gnu_retval
= group
->stmt_list
;
6974 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
6975 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
6976 make a BIND_EXPR. Note that we nest in that because the cleanup may
6977 reference variables in the block. */
6978 if (gnu_retval
== NULL_TREE
)
6979 gnu_retval
= alloc_stmt_list ();
6981 if (group
->cleanups
)
6982 gnu_retval
= build2 (TRY_FINALLY_EXPR
, void_type_node
, gnu_retval
,
6985 if (current_stmt_group
->block
)
6986 gnu_retval
= build3 (BIND_EXPR
, void_type_node
, BLOCK_VARS (group
->block
),
6987 gnu_retval
, group
->block
);
6989 /* Remove this group from the stack and add it to the free list. */
6990 current_stmt_group
= group
->previous
;
6991 group
->previous
= stmt_group_free_list
;
6992 stmt_group_free_list
= group
;
6997 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
7001 add_stmt_list (List_Id gnat_list
)
7005 if (Present (gnat_list
))
7006 for (gnat_node
= First (gnat_list
); Present (gnat_node
);
7007 gnat_node
= Next (gnat_node
))
7008 add_stmt (gnat_to_gnu (gnat_node
));
7011 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
7012 If BINDING_P is true, push and pop a binding level around the list. */
7015 build_stmt_group (List_Id gnat_list
, bool binding_p
)
7017 start_stmt_group ();
7021 add_stmt_list (gnat_list
);
7025 return end_stmt_group ();
7028 /* Generate GIMPLE in place for the expression at *EXPR_P. */
7031 gnat_gimplify_expr (tree
*expr_p
, gimple_seq
*pre_p
,
7032 gimple_seq
*post_p ATTRIBUTE_UNUSED
)
7034 tree expr
= *expr_p
;
7037 if (IS_ADA_STMT (expr
))
7038 return gnat_gimplify_stmt (expr_p
);
7040 switch (TREE_CODE (expr
))
7043 /* If this is for a scalar, just make a VAR_DECL for it. If for
7044 an aggregate, get a null pointer of the appropriate type and
7046 if (AGGREGATE_TYPE_P (TREE_TYPE (expr
)))
7047 *expr_p
= build1 (INDIRECT_REF
, TREE_TYPE (expr
),
7048 convert (build_pointer_type (TREE_TYPE (expr
)),
7049 integer_zero_node
));
7052 *expr_p
= create_tmp_var (TREE_TYPE (expr
), NULL
);
7053 TREE_NO_WARNING (*expr_p
) = 1;
7056 gimplify_and_add (TREE_OPERAND (expr
, 0), pre_p
);
7059 case UNCONSTRAINED_ARRAY_REF
:
7060 /* We should only do this if we are just elaborating for side-effects,
7061 but we can't know that yet. */
7062 *expr_p
= TREE_OPERAND (*expr_p
, 0);
7066 op
= TREE_OPERAND (expr
, 0);
7068 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
7069 is put into static memory. We know that it's going to be read-only
7070 given the semantics we have and it must be in static memory when the
7071 reference is in an elaboration procedure. */
7072 if (TREE_CODE (op
) == CONSTRUCTOR
&& TREE_CONSTANT (op
))
7074 tree addr
= build_fold_addr_expr (tree_output_constant_def (op
));
7075 *expr_p
= fold_convert (TREE_TYPE (expr
), addr
);
7079 /* Otherwise, if we are taking the address of a non-constant CONSTRUCTOR
7080 or of a call, explicitly create the local temporary. That's required
7081 if the type is passed by reference. */
7082 if (TREE_CODE (op
) == CONSTRUCTOR
|| TREE_CODE (op
) == CALL_EXPR
)
7084 tree mod
, new_var
= create_tmp_var_raw (TREE_TYPE (op
), "C");
7085 TREE_ADDRESSABLE (new_var
) = 1;
7086 gimple_add_tmp_var (new_var
);
7088 mod
= build2 (INIT_EXPR
, TREE_TYPE (new_var
), new_var
, op
);
7089 gimplify_and_add (mod
, pre_p
);
7091 TREE_OPERAND (expr
, 0) = new_var
;
7092 recompute_tree_invariant_for_addr_expr (expr
);
7096 return GS_UNHANDLED
;
7098 case VIEW_CONVERT_EXPR
:
7099 op
= TREE_OPERAND (expr
, 0);
7101 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
7102 type to a scalar one, explicitly create the local temporary. That's
7103 required if the type is passed by reference. */
7104 if ((TREE_CODE (op
) == CONSTRUCTOR
|| TREE_CODE (op
) == CALL_EXPR
)
7105 && AGGREGATE_TYPE_P (TREE_TYPE (op
))
7106 && !AGGREGATE_TYPE_P (TREE_TYPE (expr
)))
7108 tree mod
, new_var
= create_tmp_var_raw (TREE_TYPE (op
), "C");
7109 gimple_add_tmp_var (new_var
);
7111 mod
= build2 (INIT_EXPR
, TREE_TYPE (new_var
), new_var
, op
);
7112 gimplify_and_add (mod
, pre_p
);
7114 TREE_OPERAND (expr
, 0) = new_var
;
7118 return GS_UNHANDLED
;
7121 op
= DECL_EXPR_DECL (expr
);
7123 /* The expressions for the RM bounds must be gimplified to ensure that
7124 they are properly elaborated. See gimplify_decl_expr. */
7125 if ((TREE_CODE (op
) == TYPE_DECL
|| TREE_CODE (op
) == VAR_DECL
)
7126 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op
)))
7127 switch (TREE_CODE (TREE_TYPE (op
)))
7134 tree type
= TYPE_MAIN_VARIANT (TREE_TYPE (op
)), t
, val
;
7136 val
= TYPE_RM_MIN_VALUE (type
);
7139 gimplify_one_sizepos (&val
, pre_p
);
7140 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
7141 SET_TYPE_RM_MIN_VALUE (t
, val
);
7144 val
= TYPE_RM_MAX_VALUE (type
);
7147 gimplify_one_sizepos (&val
, pre_p
);
7148 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
7149 SET_TYPE_RM_MAX_VALUE (t
, val
);
7159 /* ... fall through ... */
7162 return GS_UNHANDLED
;
7166 /* Generate GIMPLE in place for the statement at *STMT_P. */
7168 static enum gimplify_status
7169 gnat_gimplify_stmt (tree
*stmt_p
)
7171 tree stmt
= *stmt_p
;
7173 switch (TREE_CODE (stmt
))
7176 *stmt_p
= STMT_STMT_STMT (stmt
);
7181 tree gnu_start_label
= create_artificial_label (input_location
);
7182 tree gnu_cond
= LOOP_STMT_COND (stmt
);
7183 tree gnu_update
= LOOP_STMT_UPDATE (stmt
);
7184 tree gnu_end_label
= LOOP_STMT_LABEL (stmt
);
7187 /* Build the condition expression from the test, if any. */
7190 = build3 (COND_EXPR
, void_type_node
, gnu_cond
, alloc_stmt_list (),
7191 build1 (GOTO_EXPR
, void_type_node
, gnu_end_label
));
7193 /* Set to emit the statements of the loop. */
7194 *stmt_p
= NULL_TREE
;
7196 /* We first emit the start label and then a conditional jump to the
7197 end label if there's a top condition, then the update if it's at
7198 the top, then the body of the loop, then a conditional jump to
7199 the end label if there's a bottom condition, then the update if
7200 it's at the bottom, and finally a jump to the start label and the
7201 definition of the end label. */
7202 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
7206 if (gnu_cond
&& !LOOP_STMT_BOTTOM_COND_P (stmt
))
7207 append_to_statement_list (gnu_cond
, stmt_p
);
7209 if (gnu_update
&& LOOP_STMT_TOP_UPDATE_P (stmt
))
7210 append_to_statement_list (gnu_update
, stmt_p
);
7212 append_to_statement_list (LOOP_STMT_BODY (stmt
), stmt_p
);
7214 if (gnu_cond
&& LOOP_STMT_BOTTOM_COND_P (stmt
))
7215 append_to_statement_list (gnu_cond
, stmt_p
);
7217 if (gnu_update
&& !LOOP_STMT_TOP_UPDATE_P (stmt
))
7218 append_to_statement_list (gnu_update
, stmt_p
);
7220 t
= build1 (GOTO_EXPR
, void_type_node
, gnu_start_label
);
7221 SET_EXPR_LOCATION (t
, DECL_SOURCE_LOCATION (gnu_end_label
));
7222 append_to_statement_list (t
, stmt_p
);
7224 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
7231 /* Build a statement to jump to the corresponding end label, then
7232 see if it needs to be conditional. */
7233 *stmt_p
= build1 (GOTO_EXPR
, void_type_node
, EXIT_STMT_LABEL (stmt
));
7234 if (EXIT_STMT_COND (stmt
))
7235 *stmt_p
= build3 (COND_EXPR
, void_type_node
,
7236 EXIT_STMT_COND (stmt
), *stmt_p
, alloc_stmt_list ());
7244 /* Force references to each of the entities in packages withed by GNAT_NODE.
7245 Operate recursively but check that we aren't elaborating something more
7248 This routine is exclusively called in type_annotate mode, to compute DDA
7249 information for types in withed units, for ASIS use. */
7252 elaborate_all_entities (Node_Id gnat_node
)
7254 Entity_Id gnat_with_clause
, gnat_entity
;
7256 /* Process each unit only once. As we trace the context of all relevant
7257 units transitively, including generic bodies, we may encounter the
7258 same generic unit repeatedly. */
7259 if (!present_gnu_tree (gnat_node
))
7260 save_gnu_tree (gnat_node
, integer_zero_node
, true);
7262 /* Save entities in all context units. A body may have an implicit_with
7263 on its own spec, if the context includes a child unit, so don't save
7265 for (gnat_with_clause
= First (Context_Items (gnat_node
));
7266 Present (gnat_with_clause
);
7267 gnat_with_clause
= Next (gnat_with_clause
))
7268 if (Nkind (gnat_with_clause
) == N_With_Clause
7269 && !present_gnu_tree (Library_Unit (gnat_with_clause
))
7270 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
7272 elaborate_all_entities (Library_Unit (gnat_with_clause
));
7274 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
7276 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
7277 Present (gnat_entity
);
7278 gnat_entity
= Next_Entity (gnat_entity
))
7279 if (Is_Public (gnat_entity
)
7280 && Convention (gnat_entity
) != Convention_Intrinsic
7281 && Ekind (gnat_entity
) != E_Package
7282 && Ekind (gnat_entity
) != E_Package_Body
7283 && Ekind (gnat_entity
) != E_Operator
7284 && !(IN (Ekind (gnat_entity
), Type_Kind
)
7285 && !Is_Frozen (gnat_entity
))
7286 && !((Ekind (gnat_entity
) == E_Procedure
7287 || Ekind (gnat_entity
) == E_Function
)
7288 && Is_Intrinsic_Subprogram (gnat_entity
))
7289 && !IN (Ekind (gnat_entity
), Named_Kind
)
7290 && !IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
7291 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
7293 else if (Ekind (Entity (Name (gnat_with_clause
))) == E_Generic_Package
)
7296 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause
)));
7298 /* Retrieve compilation unit node of generic body. */
7299 while (Present (gnat_body
)
7300 && Nkind (gnat_body
) != N_Compilation_Unit
)
7301 gnat_body
= Parent (gnat_body
);
7303 /* If body is available, elaborate its context. */
7304 if (Present (gnat_body
))
7305 elaborate_all_entities (gnat_body
);
7309 if (Nkind (Unit (gnat_node
)) == N_Package_Body
)
7310 elaborate_all_entities (Library_Unit (gnat_node
));
7313 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
7316 process_freeze_entity (Node_Id gnat_node
)
7318 const Entity_Id gnat_entity
= Entity (gnat_node
);
7319 const Entity_Kind kind
= Ekind (gnat_entity
);
7320 tree gnu_old
, gnu_new
;
7322 /* If this is a package, we need to generate code for the package. */
7323 if (kind
== E_Package
)
7326 (Parent (Corresponding_Body
7327 (Parent (Declaration_Node (gnat_entity
)))));
7331 /* Don't do anything for class-wide types as they are always transformed
7332 into their root type. */
7333 if (kind
== E_Class_Wide_Type
)
7336 /* Check for an old definition. This freeze node might be for an Itype. */
7338 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
7340 /* If this entity has an address representation clause, GNU_OLD is the
7341 address, so discard it here. */
7342 if (Present (Address_Clause (gnat_entity
)))
7343 gnu_old
= NULL_TREE
;
7345 /* Don't do anything for subprograms that may have been elaborated before
7346 their freeze nodes. This can happen, for example, because of an inner
7347 call in an instance body or because of previous compilation of a spec
7348 for inlining purposes. */
7350 && ((TREE_CODE (gnu_old
) == FUNCTION_DECL
7351 && (kind
== E_Function
|| kind
== E_Procedure
))
7352 || (TREE_CODE (TREE_TYPE (gnu_old
)) == FUNCTION_TYPE
7353 && kind
== E_Subprogram_Type
)))
7356 /* If we have a non-dummy type old tree, we have nothing to do, except
7357 aborting if this is the public view of a private type whose full view was
7358 not delayed, as this node was never delayed as it should have been. We
7359 let this happen for concurrent types and their Corresponding_Record_Type,
7360 however, because each might legitimately be elaborated before its own
7361 freeze node, e.g. while processing the other. */
7363 && !(TREE_CODE (gnu_old
) == TYPE_DECL
7364 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
7366 gcc_assert ((IN (kind
, Incomplete_Or_Private_Kind
)
7367 && Present (Full_View (gnat_entity
))
7368 && No (Freeze_Node (Full_View (gnat_entity
))))
7369 || Is_Concurrent_Type (gnat_entity
)
7370 || (IN (kind
, Record_Kind
)
7371 && Is_Concurrent_Record_Type (gnat_entity
)));
7375 /* Reset the saved tree, if any, and elaborate the object or type for real.
7376 If there is a full view, elaborate it and use the result. And, if this
7377 is the root type of a class-wide type, reuse it for the latter. */
7380 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
7381 if (IN (kind
, Incomplete_Or_Private_Kind
)
7382 && Present (Full_View (gnat_entity
))
7383 && present_gnu_tree (Full_View (gnat_entity
)))
7384 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, false);
7385 if (IN (kind
, Type_Kind
)
7386 && Present (Class_Wide_Type (gnat_entity
))
7387 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
7388 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, false);
7391 if (IN (kind
, Incomplete_Or_Private_Kind
)
7392 && Present (Full_View (gnat_entity
)))
7394 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
7396 /* Propagate back-annotations from full view to partial view. */
7397 if (Unknown_Alignment (gnat_entity
))
7398 Set_Alignment (gnat_entity
, Alignment (Full_View (gnat_entity
)));
7400 if (Unknown_Esize (gnat_entity
))
7401 Set_Esize (gnat_entity
, Esize (Full_View (gnat_entity
)));
7403 if (Unknown_RM_Size (gnat_entity
))
7404 Set_RM_Size (gnat_entity
, RM_Size (Full_View (gnat_entity
)));
7406 /* The above call may have defined this entity (the simplest example
7407 of this is when we have a private enumeral type since the bounds
7408 will have the public view). */
7409 if (!present_gnu_tree (gnat_entity
))
7410 save_gnu_tree (gnat_entity
, gnu_new
, false);
7415 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
7416 && present_gnu_tree (Declaration_Node (gnat_entity
)))
7417 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
7419 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
7422 if (IN (kind
, Type_Kind
)
7423 && Present (Class_Wide_Type (gnat_entity
))
7424 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
7425 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, false);
7427 /* If we have an old type and we've made pointers to this type, update those
7428 pointers. If this is a Taft amendment type in the main unit, we need to
7429 mark the type as used since other units referencing it don't see the full
7430 declaration and, therefore, cannot mark it as used themselves. */
7433 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
7434 TREE_TYPE (gnu_new
));
7435 if (DECL_TAFT_TYPE_P (gnu_old
))
7436 used_types_insert (TREE_TYPE (gnu_new
));
7440 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
7441 We make two passes, one to elaborate anything other than bodies (but
7442 we declare a function if there was no spec). The second pass
7443 elaborates the bodies.
7445 GNAT_END_LIST gives the element in the list past the end. Normally,
7446 this is Empty, but can be First_Real_Statement for a
7447 Handled_Sequence_Of_Statements.
7449 We make a complete pass through both lists if PASS1P is true, then make
7450 the second pass over both lists if PASS2P is true. The lists usually
7451 correspond to the public and private parts of a package. */
7454 process_decls (List_Id gnat_decls
, List_Id gnat_decls2
,
7455 Node_Id gnat_end_list
, bool pass1p
, bool pass2p
)
7457 List_Id gnat_decl_array
[2];
7461 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
7464 for (i
= 0; i
<= 1; i
++)
7465 if (Present (gnat_decl_array
[i
]))
7466 for (gnat_decl
= First (gnat_decl_array
[i
]);
7467 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
7469 /* For package specs, we recurse inside the declarations,
7470 thus taking the two pass approach inside the boundary. */
7471 if (Nkind (gnat_decl
) == N_Package_Declaration
7472 && (Nkind (Specification (gnat_decl
)
7473 == N_Package_Specification
)))
7474 process_decls (Visible_Declarations (Specification (gnat_decl
)),
7475 Private_Declarations (Specification (gnat_decl
)),
7476 Empty
, true, false);
7478 /* Similarly for any declarations in the actions of a
7480 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
7482 process_freeze_entity (gnat_decl
);
7483 process_decls (Actions (gnat_decl
), Empty
, Empty
, true, false);
7486 /* Package bodies with freeze nodes get their elaboration deferred
7487 until the freeze node, but the code must be placed in the right
7488 place, so record the code position now. */
7489 else if (Nkind (gnat_decl
) == N_Package_Body
7490 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
7491 record_code_position (gnat_decl
);
7493 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
7494 && Present (Library_Unit (gnat_decl
))
7495 && Present (Freeze_Node
7498 (Library_Unit (gnat_decl
)))))))
7499 record_code_position
7500 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
7502 /* We defer most subprogram bodies to the second pass. */
7503 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
7505 if (Acts_As_Spec (gnat_decl
))
7507 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
7509 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
7510 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
7511 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
7515 /* For bodies and stubs that act as their own specs, the entity
7516 itself must be elaborated in the first pass, because it may
7517 be used in other declarations. */
7518 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
7520 Node_Id gnat_subprog_id
7521 = Defining_Entity (Specification (gnat_decl
));
7523 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
7524 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
7525 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
7526 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
7529 /* Concurrent stubs stand for the corresponding subprogram bodies,
7530 which are deferred like other bodies. */
7531 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
7532 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
7536 add_stmt (gnat_to_gnu (gnat_decl
));
7539 /* Here we elaborate everything we deferred above except for package bodies,
7540 which are elaborated at their freeze nodes. Note that we must also
7541 go inside things (package specs and freeze nodes) the first pass did. */
7543 for (i
= 0; i
<= 1; i
++)
7544 if (Present (gnat_decl_array
[i
]))
7545 for (gnat_decl
= First (gnat_decl_array
[i
]);
7546 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
7548 if (Nkind (gnat_decl
) == N_Subprogram_Body
7549 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
7550 || Nkind (gnat_decl
) == N_Task_Body_Stub
7551 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
7552 add_stmt (gnat_to_gnu (gnat_decl
));
7554 else if (Nkind (gnat_decl
) == N_Package_Declaration
7555 && (Nkind (Specification (gnat_decl
)
7556 == N_Package_Specification
)))
7557 process_decls (Visible_Declarations (Specification (gnat_decl
)),
7558 Private_Declarations (Specification (gnat_decl
)),
7559 Empty
, false, true);
7561 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
7562 process_decls (Actions (gnat_decl
), Empty
, Empty
, false, true);
7566 /* Make a unary operation of kind CODE using build_unary_op, but guard
7567 the operation by an overflow check. CODE can be one of NEGATE_EXPR
7568 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
7569 the operation is to be performed in that type. GNAT_NODE is the gnat
7570 node conveying the source location for which the error should be
7574 build_unary_op_trapv (enum tree_code code
, tree gnu_type
, tree operand
,
7577 gcc_assert (code
== NEGATE_EXPR
|| code
== ABS_EXPR
);
7579 operand
= gnat_protect_expr (operand
);
7581 return emit_check (build_binary_op (EQ_EXPR
, boolean_type_node
,
7582 operand
, TYPE_MIN_VALUE (gnu_type
)),
7583 build_unary_op (code
, gnu_type
, operand
),
7584 CE_Overflow_Check_Failed
, gnat_node
);
7587 /* Make a binary operation of kind CODE using build_binary_op, but guard
7588 the operation by an overflow check. CODE can be one of PLUS_EXPR,
7589 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
7590 Usually the operation is to be performed in that type. GNAT_NODE is
7591 the GNAT node conveying the source location for which the error should
7595 build_binary_op_trapv (enum tree_code code
, tree gnu_type
, tree left
,
7596 tree right
, Node_Id gnat_node
)
7598 tree lhs
= gnat_protect_expr (left
);
7599 tree rhs
= gnat_protect_expr (right
);
7600 tree type_max
= TYPE_MAX_VALUE (gnu_type
);
7601 tree type_min
= TYPE_MIN_VALUE (gnu_type
);
7604 tree zero
= convert (gnu_type
, integer_zero_node
);
7609 int precision
= TYPE_PRECISION (gnu_type
);
7611 gcc_assert (!(precision
& (precision
- 1))); /* ensure power of 2 */
7613 /* Prefer a constant or known-positive rhs to simplify checks. */
7614 if (!TREE_CONSTANT (rhs
)
7615 && commutative_tree_code (code
)
7616 && (TREE_CONSTANT (lhs
) || (!tree_expr_nonnegative_p (rhs
)
7617 && tree_expr_nonnegative_p (lhs
))))
7624 rhs_lt_zero
= tree_expr_nonnegative_p (rhs
)
7625 ? boolean_false_node
7626 : build_binary_op (LT_EXPR
, boolean_type_node
, rhs
, zero
);
7628 /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
7630 /* Try a few strategies that may be cheaper than the general
7631 code at the end of the function, if the rhs is not known.
7633 - Call library function for 64-bit multiplication (complex)
7634 - Widen, if input arguments are sufficiently small
7635 - Determine overflow using wrapped result for addition/subtraction. */
7637 if (!TREE_CONSTANT (rhs
))
7639 /* Even for add/subtract double size to get another base type. */
7640 int needed_precision
= precision
* 2;
7642 if (code
== MULT_EXPR
&& precision
== 64)
7644 tree int_64
= gnat_type_for_size (64, 0);
7646 return convert (gnu_type
, build_call_n_expr (mulv64_decl
, 2,
7647 convert (int_64
, lhs
),
7648 convert (int_64
, rhs
)));
7651 else if (needed_precision
<= BITS_PER_WORD
7652 || (code
== MULT_EXPR
7653 && needed_precision
<= LONG_LONG_TYPE_SIZE
))
7655 tree wide_type
= gnat_type_for_size (needed_precision
, 0);
7657 tree wide_result
= build_binary_op (code
, wide_type
,
7658 convert (wide_type
, lhs
),
7659 convert (wide_type
, rhs
));
7661 tree check
= build_binary_op
7662 (TRUTH_ORIF_EXPR
, boolean_type_node
,
7663 build_binary_op (LT_EXPR
, boolean_type_node
, wide_result
,
7664 convert (wide_type
, type_min
)),
7665 build_binary_op (GT_EXPR
, boolean_type_node
, wide_result
,
7666 convert (wide_type
, type_max
)));
7668 tree result
= convert (gnu_type
, wide_result
);
7671 emit_check (check
, result
, CE_Overflow_Check_Failed
, gnat_node
);
7674 else if (code
== PLUS_EXPR
|| code
== MINUS_EXPR
)
7676 tree unsigned_type
= gnat_type_for_size (precision
, 1);
7677 tree wrapped_expr
= convert
7678 (gnu_type
, build_binary_op (code
, unsigned_type
,
7679 convert (unsigned_type
, lhs
),
7680 convert (unsigned_type
, rhs
)));
7682 tree result
= convert
7683 (gnu_type
, build_binary_op (code
, gnu_type
, lhs
, rhs
));
7685 /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
7686 or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */
7687 tree check
= build_binary_op
7688 (TRUTH_XOR_EXPR
, boolean_type_node
, rhs_lt_zero
,
7689 build_binary_op (code
== PLUS_EXPR
? LT_EXPR
: GT_EXPR
,
7690 boolean_type_node
, wrapped_expr
, lhs
));
7693 emit_check (check
, result
, CE_Overflow_Check_Failed
, gnat_node
);
7700 /* When rhs >= 0, overflow when lhs > type_max - rhs. */
7701 check_pos
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
7702 build_binary_op (MINUS_EXPR
, gnu_type
,
7705 /* When rhs < 0, overflow when lhs < type_min - rhs. */
7706 check_neg
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
7707 build_binary_op (MINUS_EXPR
, gnu_type
,
7712 /* When rhs >= 0, overflow when lhs < type_min + rhs. */
7713 check_pos
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
7714 build_binary_op (PLUS_EXPR
, gnu_type
,
7717 /* When rhs < 0, overflow when lhs > type_max + rhs. */
7718 check_neg
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
7719 build_binary_op (PLUS_EXPR
, gnu_type
,
7724 /* The check here is designed to be efficient if the rhs is constant,
7725 but it will work for any rhs by using integer division.
7726 Four different check expressions determine whether X * C overflows,
7729 C > 0 => X > type_max / C || X < type_min / C
7730 C == -1 => X == type_min
7731 C < -1 => X > type_min / C || X < type_max / C */
7733 tmp1
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
7734 tmp2
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
7737 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
7738 build_binary_op (NE_EXPR
, boolean_type_node
, zero
,
7740 build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
7741 build_binary_op (GT_EXPR
,
7744 build_binary_op (LT_EXPR
,
7749 = fold_build3 (COND_EXPR
, boolean_type_node
,
7750 build_binary_op (EQ_EXPR
, boolean_type_node
, rhs
,
7751 build_int_cst (gnu_type
, -1)),
7752 build_binary_op (EQ_EXPR
, boolean_type_node
, lhs
,
7754 build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
7755 build_binary_op (GT_EXPR
,
7758 build_binary_op (LT_EXPR
,
7767 gnu_expr
= build_binary_op (code
, gnu_type
, lhs
, rhs
);
7769 /* If we can fold the expression to a constant, just return it.
7770 The caller will deal with overflow, no need to generate a check. */
7771 if (TREE_CONSTANT (gnu_expr
))
7774 check
= fold_build3 (COND_EXPR
, boolean_type_node
, rhs_lt_zero
, check_neg
,
7777 return emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
7780 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
7781 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
7782 which we have to check. GNAT_NODE is the GNAT node conveying the source
7783 location for which the error should be signaled. */
7786 emit_range_check (tree gnu_expr
, Entity_Id gnat_range_type
, Node_Id gnat_node
)
7788 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
7789 tree gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
7790 tree gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
7791 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
7793 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
7794 This can for example happen when translating 'Val or 'Value. */
7795 if (gnu_compare_type
== gnu_range_type
)
7798 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
7799 we can't do anything since we might be truncating the bounds. No
7800 check is needed in this case. */
7801 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
7802 && (TYPE_PRECISION (gnu_compare_type
)
7803 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
7806 /* Checked expressions must be evaluated only once. */
7807 gnu_expr
= gnat_protect_expr (gnu_expr
);
7809 /* Note that the form of the check is
7810 (not (expr >= lo)) or (not (expr <= hi))
7811 the reason for this slightly convoluted form is that NaNs
7812 are not considered to be in range in the float case. */
7814 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
7816 (build_binary_op (GE_EXPR
, boolean_type_node
,
7817 convert (gnu_compare_type
, gnu_expr
),
7818 convert (gnu_compare_type
, gnu_low
))),
7820 (build_binary_op (LE_EXPR
, boolean_type_node
,
7821 convert (gnu_compare_type
, gnu_expr
),
7822 convert (gnu_compare_type
,
7824 gnu_expr
, CE_Range_Check_Failed
, gnat_node
);
7827 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which
7828 we are about to index, GNU_EXPR is the index expression to be checked,
7829 GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
7830 has to be checked. Note that for index checking we cannot simply use the
7831 emit_range_check function (although very similar code needs to be generated
7832 in both cases) since for index checking the array type against which we are
7833 checking the indices may be unconstrained and consequently we need to get
7834 the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
7835 The place where we need to do that is in subprograms having unconstrained
7836 array formal parameters. GNAT_NODE is the GNAT node conveying the source
7837 location for which the error should be signaled. */
7840 emit_index_check (tree gnu_array_object
, tree gnu_expr
, tree gnu_low
,
7841 tree gnu_high
, Node_Id gnat_node
)
7843 tree gnu_expr_check
;
7845 /* Checked expressions must be evaluated only once. */
7846 gnu_expr
= gnat_protect_expr (gnu_expr
);
7848 /* Must do this computation in the base type in case the expression's
7849 type is an unsigned subtypes. */
7850 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
7852 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
7853 the object we are handling. */
7854 gnu_low
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low
, gnu_array_object
);
7855 gnu_high
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high
, gnu_array_object
);
7858 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
7859 build_binary_op (LT_EXPR
, boolean_type_node
,
7861 convert (TREE_TYPE (gnu_expr_check
),
7863 build_binary_op (GT_EXPR
, boolean_type_node
,
7865 convert (TREE_TYPE (gnu_expr_check
),
7867 gnu_expr
, CE_Index_Check_Failed
, gnat_node
);
7870 /* GNU_COND contains the condition corresponding to an access, discriminant or
7871 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
7872 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
7873 REASON is the code that says why the exception was raised. GNAT_NODE is
7874 the GNAT node conveying the source location for which the error should be
7878 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
, Node_Id gnat_node
)
7881 = build_call_raise (reason
, gnat_node
, N_Raise_Constraint_Error
);
7883 = fold_build3 (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
7884 build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_call
,
7885 convert (TREE_TYPE (gnu_expr
), integer_zero_node
)),
7888 /* GNU_RESULT has side effects if and only if GNU_EXPR has:
7889 we don't need to evaluate it just for the check. */
7890 TREE_SIDE_EFFECTS (gnu_result
) = TREE_SIDE_EFFECTS (gnu_expr
);
7895 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
7896 checks if OVERFLOW_P is true and range checks if RANGE_P is true.
7897 GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
7898 float to integer conversion with truncation; otherwise round.
7899 GNAT_NODE is the GNAT node conveying the source location for which the
7900 error should be signaled. */
7903 convert_with_check (Entity_Id gnat_type
, tree gnu_expr
, bool overflowp
,
7904 bool rangep
, bool truncatep
, Node_Id gnat_node
)
7906 tree gnu_type
= get_unpadded_type (gnat_type
);
7907 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
7908 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
7909 tree gnu_base_type
= get_base_type (gnu_type
);
7910 tree gnu_result
= gnu_expr
;
7912 /* If we are not doing any checks, the output is an integral type, and
7913 the input is not a floating type, just do the conversion. This
7914 shortcut is required to avoid problems with packed array types
7915 and simplifies code in all cases anyway. */
7916 if (!rangep
&& !overflowp
&& INTEGRAL_TYPE_P (gnu_base_type
)
7917 && !FLOAT_TYPE_P (gnu_in_type
))
7918 return convert (gnu_type
, gnu_expr
);
7920 /* First convert the expression to its base type. This
7921 will never generate code, but makes the tests below much simpler.
7922 But don't do this if converting from an integer type to an unconstrained
7923 array type since then we need to get the bounds from the original
7925 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
7926 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
7928 /* If overflow checks are requested, we need to be sure the result will
7929 fit in the output base type. But don't do this if the input
7930 is integer and the output floating-point. */
7932 && !(FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
7934 /* Ensure GNU_EXPR only gets evaluated once. */
7935 tree gnu_input
= gnat_protect_expr (gnu_result
);
7936 tree gnu_cond
= boolean_false_node
;
7937 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
7938 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
7939 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
7940 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
7942 /* Convert the lower bounds to signed types, so we're sure we're
7943 comparing them properly. Likewise, convert the upper bounds
7944 to unsigned types. */
7945 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TYPE_UNSIGNED (gnu_in_basetype
))
7946 gnu_in_lb
= convert (gnat_signed_type (gnu_in_basetype
), gnu_in_lb
);
7948 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
7949 && !TYPE_UNSIGNED (gnu_in_basetype
))
7950 gnu_in_ub
= convert (gnat_unsigned_type (gnu_in_basetype
), gnu_in_ub
);
7952 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
7953 gnu_out_lb
= convert (gnat_signed_type (gnu_base_type
), gnu_out_lb
);
7955 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
7956 gnu_out_ub
= convert (gnat_unsigned_type (gnu_base_type
), gnu_out_ub
);
7958 /* Check each bound separately and only if the result bound
7959 is tighter than the bound on the input type. Note that all the
7960 types are base types, so the bounds must be constant. Also,
7961 the comparison is done in the base type of the input, which
7962 always has the proper signedness. First check for input
7963 integer (which means output integer), output float (which means
7964 both float), or mixed, in which case we always compare.
7965 Note that we have to do the comparison which would *fail* in the
7966 case of an error since if it's an FP comparison and one of the
7967 values is a NaN or Inf, the comparison will fail. */
7968 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
7969 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
7970 : (FLOAT_TYPE_P (gnu_base_type
)
7971 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
7972 TREE_REAL_CST (gnu_out_lb
))
7976 (build_binary_op (GE_EXPR
, boolean_type_node
,
7977 gnu_input
, convert (gnu_in_basetype
,
7980 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
7981 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
7982 : (FLOAT_TYPE_P (gnu_base_type
)
7983 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
7984 TREE_REAL_CST (gnu_in_lb
))
7987 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, gnu_cond
,
7989 (build_binary_op (LE_EXPR
, boolean_type_node
,
7991 convert (gnu_in_basetype
,
7994 if (!integer_zerop (gnu_cond
))
7995 gnu_result
= emit_check (gnu_cond
, gnu_input
,
7996 CE_Overflow_Check_Failed
, gnat_node
);
7999 /* Now convert to the result base type. If this is a non-truncating
8000 float-to-integer conversion, round. */
8001 if (INTEGRAL_TYPE_P (gnu_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
8004 REAL_VALUE_TYPE half_minus_pred_half
, pred_half
;
8005 tree gnu_conv
, gnu_zero
, gnu_comp
, calc_type
;
8006 tree gnu_pred_half
, gnu_add_pred_half
, gnu_subtract_pred_half
;
8007 const struct real_format
*fmt
;
8009 /* The following calculations depend on proper rounding to even
8010 of each arithmetic operation. In order to prevent excess
8011 precision from spoiling this property, use the widest hardware
8012 floating-point type if FP_ARITH_MAY_WIDEN is true. */
8014 = FP_ARITH_MAY_WIDEN
? longest_float_type_node
: gnu_in_basetype
;
8016 /* FIXME: Should not have padding in the first place. */
8017 if (TYPE_IS_PADDING_P (calc_type
))
8018 calc_type
= TREE_TYPE (TYPE_FIELDS (calc_type
));
8020 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
8021 fmt
= REAL_MODE_FORMAT (TYPE_MODE (calc_type
));
8022 real_2expN (&half_minus_pred_half
, -(fmt
->p
) - 1, TYPE_MODE (calc_type
));
8023 REAL_ARITHMETIC (pred_half
, MINUS_EXPR
, dconsthalf
,
8024 half_minus_pred_half
);
8025 gnu_pred_half
= build_real (calc_type
, pred_half
);
8027 /* If the input is strictly negative, subtract this value
8028 and otherwise add it from the input. For 0.5, the result
8029 is exactly between 1.0 and the machine number preceding 1.0
8030 (for calc_type). Since the last bit of 1.0 is even, this 0.5
8031 will round to 1.0, while all other number with an absolute
8032 value less than 0.5 round to 0.0. For larger numbers exactly
8033 halfway between integers, rounding will always be correct as
8034 the true mathematical result will be closer to the higher
8035 integer compared to the lower one. So, this constant works
8036 for all floating-point numbers.
8038 The reason to use the same constant with subtract/add instead
8039 of a positive and negative constant is to allow the comparison
8040 to be scheduled in parallel with retrieval of the constant and
8041 conversion of the input to the calc_type (if necessary). */
8043 gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
8044 gnu_result
= gnat_protect_expr (gnu_result
);
8045 gnu_conv
= convert (calc_type
, gnu_result
);
8047 = fold_build2 (GE_EXPR
, boolean_type_node
, gnu_result
, gnu_zero
);
8049 = fold_build2 (PLUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
8050 gnu_subtract_pred_half
8051 = fold_build2 (MINUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
8052 gnu_result
= fold_build3 (COND_EXPR
, calc_type
, gnu_comp
,
8053 gnu_add_pred_half
, gnu_subtract_pred_half
);
8056 if (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
8057 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type
)
8058 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
8059 gnu_result
= unchecked_convert (gnu_base_type
, gnu_result
, false);
8061 gnu_result
= convert (gnu_base_type
, gnu_result
);
8063 /* Finally, do the range check if requested. Note that if the result type
8064 is a modular type, the range check is actually an overflow check. */
8066 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
8067 && TYPE_MODULAR_P (gnu_base_type
) && overflowp
))
8068 gnu_result
= emit_range_check (gnu_result
, gnat_type
, gnat_node
);
8070 return convert (gnu_type
, gnu_result
);
8073 /* Return true if GNU_EXPR can be directly addressed. This is the case
8074 unless it is an expression involving computation or if it involves a
8075 reference to a bitfield or to an object not sufficiently aligned for
8076 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
8077 be directly addressed as an object of this type.
8079 *** Notes on addressability issues in the Ada compiler ***
8081 This predicate is necessary in order to bridge the gap between Gigi
8082 and the middle-end about addressability of GENERIC trees. A tree
8083 is said to be addressable if it can be directly addressed, i.e. if
8084 its address can be taken, is a multiple of the type's alignment on
8085 strict-alignment architectures and returns the first storage unit
8086 assigned to the object represented by the tree.
8088 In the C family of languages, everything is in practice addressable
8089 at the language level, except for bit-fields. This means that these
8090 compilers will take the address of any tree that doesn't represent
8091 a bit-field reference and expect the result to be the first storage
8092 unit assigned to the object. Even in cases where this will result
8093 in unaligned accesses at run time, nothing is supposed to be done
8094 and the program is considered as erroneous instead (see PR c/18287).
8096 The implicit assumptions made in the middle-end are in keeping with
8097 the C viewpoint described above:
8098 - the address of a bit-field reference is supposed to be never
8099 taken; the compiler (generally) will stop on such a construct,
8100 - any other tree is addressable if it is formally addressable,
8101 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
8103 In Ada, the viewpoint is the opposite one: nothing is addressable
8104 at the language level unless explicitly declared so. This means
8105 that the compiler will both make sure that the trees representing
8106 references to addressable ("aliased" in Ada parlance) objects are
8107 addressable and make no real attempts at ensuring that the trees
8108 representing references to non-addressable objects are addressable.
8110 In the first case, Ada is effectively equivalent to C and handing
8111 down the direct result of applying ADDR_EXPR to these trees to the
8112 middle-end works flawlessly. In the second case, Ada cannot afford
8113 to consider the program as erroneous if the address of trees that
8114 are not addressable is requested for technical reasons, unlike C;
8115 as a consequence, the Ada compiler must arrange for either making
8116 sure that this address is not requested in the middle-end or for
8117 compensating by inserting temporaries if it is requested in Gigi.
8119 The first goal can be achieved because the middle-end should not
8120 request the address of non-addressable trees on its own; the only
8121 exception is for the invocation of low-level block operations like
8122 memcpy, for which the addressability requirements are lower since
8123 the type's alignment can be disregarded. In practice, this means
8124 that Gigi must make sure that such operations cannot be applied to
8125 non-BLKmode bit-fields.
8127 The second goal is achieved by means of the addressable_p predicate,
8128 which computes whether a temporary must be inserted by Gigi when the
8129 address of a tree is requested; if so, the address of the temporary
8130 will be used in lieu of that of the original tree and some glue code
8131 generated to connect everything together. */
8134 addressable_p (tree gnu_expr
, tree gnu_type
)
8136 /* For an integral type, the size of the actual type of the object may not
8137 be greater than that of the expected type, otherwise an indirect access
8138 in the latter type wouldn't correctly set all the bits of the object. */
8140 && INTEGRAL_TYPE_P (gnu_type
)
8141 && smaller_form_type_p (gnu_type
, TREE_TYPE (gnu_expr
)))
8144 /* The size of the actual type of the object may not be smaller than that
8145 of the expected type, otherwise an indirect access in the latter type
8146 would be larger than the object. But only record types need to be
8147 considered in practice for this case. */
8149 && TREE_CODE (gnu_type
) == RECORD_TYPE
8150 && smaller_form_type_p (TREE_TYPE (gnu_expr
), gnu_type
))
8153 switch (TREE_CODE (gnu_expr
))
8159 /* All DECLs are addressable: if they are in a register, we can force
8163 case UNCONSTRAINED_ARRAY_REF
:
8165 /* Taking the address of a dereference yields the original pointer. */
8170 /* Taking the address yields a pointer to the constant pool. */
8174 /* Taking the address of a static constructor yields a pointer to the
8175 tree constant pool. */
8176 return TREE_STATIC (gnu_expr
) ? true : false;
8187 /* All rvalues are deemed addressable since taking their address will
8188 force a temporary to be created by the middle-end. */
8192 /* The address of a compound expression is that of its 2nd operand. */
8193 return addressable_p (TREE_OPERAND (gnu_expr
, 1), gnu_type
);
8196 /* We accept &COND_EXPR as soon as both operands are addressable and
8197 expect the outcome to be the address of the selected operand. */
8198 return (addressable_p (TREE_OPERAND (gnu_expr
, 1), NULL_TREE
)
8199 && addressable_p (TREE_OPERAND (gnu_expr
, 2), NULL_TREE
));
8202 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
8203 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
8204 the field is sufficiently aligned, in case it is subject
8205 to a pragma Component_Alignment. But we don't need to
8206 check the alignment of the containing record, as it is
8207 guaranteed to be not smaller than that of its most
8208 aligned field that is not a bit-field. */
8209 && (!STRICT_ALIGNMENT
8210 || DECL_ALIGN (TREE_OPERAND (gnu_expr
, 1))
8211 >= TYPE_ALIGN (TREE_TYPE (gnu_expr
))))
8212 /* The field of a padding record is always addressable. */
8213 || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
8214 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
8216 case ARRAY_REF
: case ARRAY_RANGE_REF
:
8217 case REALPART_EXPR
: case IMAGPART_EXPR
:
8219 return addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
);
8222 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
8223 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
8225 case VIEW_CONVERT_EXPR
:
8227 /* This is addressable if we can avoid a copy. */
8228 tree type
= TREE_TYPE (gnu_expr
);
8229 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
8230 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
8231 && (!STRICT_ALIGNMENT
8232 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
8233 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
8234 || ((TYPE_MODE (type
) == BLKmode
8235 || TYPE_MODE (inner_type
) == BLKmode
)
8236 && (!STRICT_ALIGNMENT
8237 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
8238 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
8239 || TYPE_ALIGN_OK (type
)
8240 || TYPE_ALIGN_OK (inner_type
))))
8241 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
8249 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
8250 a separate Freeze node exists, delay the bulk of the processing. Otherwise
8251 make a GCC type for GNAT_ENTITY and set up the correspondence. */
8254 process_type (Entity_Id gnat_entity
)
8257 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
8260 /* If we are to delay elaboration of this type, just do any
8261 elaborations needed for expressions within the declaration and
8262 make a dummy type entry for this node and its Full_View (if
8263 any) in case something points to it. Don't do this if it
8264 has already been done (the only way that can happen is if
8265 the private completion is also delayed). */
8266 if (Present (Freeze_Node (gnat_entity
))
8267 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
8268 && Present (Full_View (gnat_entity
))
8269 && Freeze_Node (Full_View (gnat_entity
))
8270 && !present_gnu_tree (Full_View (gnat_entity
))))
8272 elaborate_entity (gnat_entity
);
8276 tree gnu_decl
= TYPE_STUB_DECL (make_dummy_type (gnat_entity
));
8277 save_gnu_tree (gnat_entity
, gnu_decl
, false);
8278 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
8279 && Present (Full_View (gnat_entity
)))
8281 if (Has_Completion_In_Body (gnat_entity
))
8282 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
8283 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, false);
8290 /* If we saved away a dummy type for this node it means that this
8291 made the type that corresponds to the full type of an incomplete
8292 type. Clear that type for now and then update the type in the
8296 gcc_assert (TREE_CODE (gnu_old
) == TYPE_DECL
8297 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)));
8299 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
8302 /* Now fully elaborate the type. */
8303 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
8304 gcc_assert (TREE_CODE (gnu_new
) == TYPE_DECL
);
8306 /* If we have an old type and we've made pointers to this type, update those
8307 pointers. If this is a Taft amendment type in the main unit, we need to
8308 mark the type as used since other units referencing it don't see the full
8309 declaration and, therefore, cannot mark it as used themselves. */
8312 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
8313 TREE_TYPE (gnu_new
));
8314 if (DECL_TAFT_TYPE_P (gnu_old
))
8315 used_types_insert (TREE_TYPE (gnu_new
));
8318 /* If this is a record type corresponding to a task or protected type
8319 that is a completion of an incomplete type, perform a similar update
8320 on the type. ??? Including protected types here is a guess. */
8321 if (IN (Ekind (gnat_entity
), Record_Kind
)
8322 && Is_Concurrent_Record_Type (gnat_entity
)
8323 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
8326 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
8328 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
8330 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
8333 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
8334 TREE_TYPE (gnu_new
));
8338 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
8339 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
8340 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
8343 assoc_to_constructor (Entity_Id gnat_entity
, Node_Id gnat_assoc
, tree gnu_type
)
8345 tree gnu_list
= NULL_TREE
, gnu_result
;
8347 /* We test for GNU_FIELD being empty in the case where a variant
8348 was the last thing since we don't take things off GNAT_ASSOC in
8349 that case. We check GNAT_ASSOC in case we have a variant, but it
8352 for (; Present (gnat_assoc
); gnat_assoc
= Next (gnat_assoc
))
8354 Node_Id gnat_field
= First (Choices (gnat_assoc
));
8355 tree gnu_field
= gnat_to_gnu_field_decl (Entity (gnat_field
));
8356 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
8358 /* The expander is supposed to put a single component selector name
8359 in every record component association. */
8360 gcc_assert (No (Next (gnat_field
)));
8362 /* Ignore fields that have Corresponding_Discriminants since we'll
8363 be setting that field in the parent. */
8364 if (Present (Corresponding_Discriminant (Entity (gnat_field
)))
8365 && Is_Tagged_Type (Scope (Entity (gnat_field
))))
8368 /* Also ignore discriminants of Unchecked_Unions. */
8369 if (Is_Unchecked_Union (gnat_entity
)
8370 && Ekind (Entity (gnat_field
)) == E_Discriminant
)
8373 /* Before assigning a value in an aggregate make sure range checks
8374 are done if required. Then convert to the type of the field. */
8375 if (Do_Range_Check (Expression (gnat_assoc
)))
8376 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
), Empty
);
8378 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
8380 /* Add the field and expression to the list. */
8381 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
8384 gnu_result
= extract_values (gnu_list
, gnu_type
);
8386 #ifdef ENABLE_CHECKING
8387 /* Verify that every entry in GNU_LIST was used. */
8388 for (; gnu_list
; gnu_list
= TREE_CHAIN (gnu_list
))
8389 gcc_assert (TREE_ADDRESSABLE (gnu_list
));
8395 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
8396 the first element of an array aggregate. It may itself be an aggregate.
8397 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
8398 GNAT_COMPONENT_TYPE is the type of the array component; it is needed
8399 for range checking. */
8402 pos_to_constructor (Node_Id gnat_expr
, tree gnu_array_type
,
8403 Entity_Id gnat_component_type
)
8405 tree gnu_index
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type
));
8407 VEC(constructor_elt
,gc
) *gnu_expr_vec
= NULL
;
8409 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
8411 /* If the expression is itself an array aggregate then first build the
8412 innermost constructor if it is part of our array (multi-dimensional
8414 if (Nkind (gnat_expr
) == N_Aggregate
8415 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
8416 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
8417 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
8418 TREE_TYPE (gnu_array_type
),
8419 gnat_component_type
);
8422 gnu_expr
= gnat_to_gnu (gnat_expr
);
8424 /* Before assigning the element to the array, make sure it is
8426 if (Do_Range_Check (gnat_expr
))
8427 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
, Empty
);
8430 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec
, gnu_index
,
8431 convert (TREE_TYPE (gnu_array_type
), gnu_expr
));
8433 gnu_index
= int_const_binop (PLUS_EXPR
, gnu_index
, integer_one_node
);
8436 return gnat_build_constructor (gnu_array_type
, gnu_expr_vec
);
8439 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
8440 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
8441 of the associations that are from RECORD_TYPE. If we see an internal
8442 record, make a recursive call to fill it in as well. */
8445 extract_values (tree values
, tree record_type
)
8448 VEC(constructor_elt
,gc
) *v
= NULL
;
8450 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
8454 /* _Parent is an internal field, but may have values in the aggregate,
8455 so check for values first. */
8456 if ((tem
= purpose_member (field
, values
)))
8458 value
= TREE_VALUE (tem
);
8459 TREE_ADDRESSABLE (tem
) = 1;
8462 else if (DECL_INTERNAL_P (field
))
8464 value
= extract_values (values
, TREE_TYPE (field
));
8465 if (TREE_CODE (value
) == CONSTRUCTOR
8466 && VEC_empty (constructor_elt
, CONSTRUCTOR_ELTS (value
)))
8470 /* If we have a record subtype, the names will match, but not the
8471 actual FIELD_DECLs. */
8472 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
8473 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
8475 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
8476 TREE_ADDRESSABLE (tem
) = 1;
8482 CONSTRUCTOR_APPEND_ELT (v
, field
, value
);
8485 return gnat_build_constructor (record_type
, v
);
8488 /* EXP is to be treated as an array or record. Handle the cases when it is
8489 an access object and perform the required dereferences. */
8492 maybe_implicit_deref (tree exp
)
8494 /* If the type is a pointer, dereference it. */
8495 if (POINTER_TYPE_P (TREE_TYPE (exp
))
8496 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp
)))
8497 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
8499 /* If we got a padded type, remove it too. */
8500 if (TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
8501 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
8506 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
8507 location and false if it doesn't. In the former case, set the Gigi global
8508 variable REF_FILENAME to the simple debug file name as given by sinput. */
8511 Sloc_to_locus (Source_Ptr Sloc
, location_t
*locus
)
8513 if (Sloc
== No_Location
)
8516 if (Sloc
<= Standard_Location
)
8518 *locus
= BUILTINS_LOCATION
;
8523 Source_File_Index file
= Get_Source_File_Index (Sloc
);
8524 Logical_Line_Number line
= Get_Logical_Line_Number (Sloc
);
8525 Column_Number column
= Get_Column_Number (Sloc
);
8526 struct line_map
*map
= LINEMAPS_ORDINARY_MAP_AT (line_table
, file
- 1);
8528 /* We can have zero if pragma Source_Reference is in effect. */
8532 /* Translate the location. */
8533 *locus
= linemap_position_for_line_and_column (map
, line
, column
);
8537 = IDENTIFIER_POINTER
8539 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc
)))));;
8544 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
8545 don't do anything if it doesn't correspond to a source location. */
8548 set_expr_location_from_node (tree node
, Node_Id gnat_node
)
8552 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
))
8555 SET_EXPR_LOCATION (node
, locus
);
8558 /* More elaborate version of set_expr_location_from_node to be used in more
8559 general contexts, for example the result of the translation of a generic
8563 set_gnu_expr_location_from_node (tree node
, Node_Id gnat_node
)
8565 /* Set the location information on the node if it is a real expression.
8566 References can be reused for multiple GNAT nodes and they would get
8567 the location information of their last use. Also make sure not to
8568 overwrite an existing location as it is probably more precise. */
8570 switch (TREE_CODE (node
))
8573 case NON_LVALUE_EXPR
:
8577 if (EXPR_P (TREE_OPERAND (node
, 1)))
8578 set_gnu_expr_location_from_node (TREE_OPERAND (node
, 1), gnat_node
);
8580 /* ... fall through ... */
8583 if (!REFERENCE_CLASS_P (node
) && !EXPR_HAS_LOCATION (node
))
8585 set_expr_location_from_node (node
, gnat_node
);
8586 set_end_locus_from_node (node
, gnat_node
);
8592 /* Return a colon-separated list of encodings contained in encoded Ada
8596 extract_encoding (const char *name
)
8598 char *encoding
= (char *) ggc_alloc_atomic (strlen (name
));
8599 get_encoding (name
, encoding
);
8603 /* Extract the Ada name from an encoded name. */
8606 decode_name (const char *name
)
8608 char *decoded
= (char *) ggc_alloc_atomic (strlen (name
) * 2 + 60);
8609 __gnat_decode (name
, decoded
, 0);
8613 /* Post an error message. MSG is the error message, properly annotated.
8614 NODE is the node at which to post the error and the node to use for the
8615 '&' substitution. */
8618 post_error (const char *msg
, Node_Id node
)
8620 String_Template temp
;
8623 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
8624 fp
.Array
= msg
, fp
.Bounds
= &temp
;
8626 Error_Msg_N (fp
, node
);
8629 /* Similar to post_error, but NODE is the node at which to post the error and
8630 ENT is the node to use for the '&' substitution. */
8633 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
8635 String_Template temp
;
8638 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
8639 fp
.Array
= msg
, fp
.Bounds
= &temp
;
8641 Error_Msg_NE (fp
, node
, ent
);
8644 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
8647 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int num
)
8649 Error_Msg_Uint_1
= UI_From_Int (num
);
8650 post_error_ne (msg
, node
, ent
);
8653 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
8654 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
8655 most sense. Return true if a sensible assignment was performed. */
8658 set_end_locus_from_node (tree gnu_node
, Node_Id gnat_node
)
8660 Node_Id gnat_end_label
= Empty
;
8661 location_t end_locus
;
8663 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
8664 end_locus when there is one. We consider only GNAT nodes with a possible
8665 End_Label attached. If the End_Label actually was unassigned, fallback
8666 on the orginal node. We'd better assign an explicit sloc associated with
8667 the outer construct in any case. */
8669 switch (Nkind (gnat_node
))
8671 case N_Package_Body
:
8672 case N_Subprogram_Body
:
8673 case N_Block_Statement
:
8674 gnat_end_label
= End_Label (Handled_Statement_Sequence (gnat_node
));
8677 case N_Package_Declaration
:
8678 gnat_end_label
= End_Label (Specification (gnat_node
));
8685 gnat_node
= Present (gnat_end_label
) ? gnat_end_label
: gnat_node
;
8687 /* Some expanded subprograms have neither an End_Label nor a Sloc
8688 attached. Notify that to callers. */
8690 if (!Sloc_to_locus (Sloc (gnat_node
), &end_locus
))
8693 switch (TREE_CODE (gnu_node
))
8696 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node
)) = end_locus
;
8700 DECL_STRUCT_FUNCTION (gnu_node
)->function_end_locus
= end_locus
;
8708 /* Similar to post_error_ne, but T is a GCC tree representing the number to
8709 write. If T represents a constant, the text inside curly brackets in
8710 MSG will be output (presumably including a '^'). Otherwise it will not
8711 be output and the text inside square brackets will be output instead. */
8714 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
8716 char *new_msg
= XALLOCAVEC (char, strlen (msg
) + 1);
8717 char start_yes
, end_yes
, start_no
, end_no
;
8721 if (TREE_CODE (t
) == INTEGER_CST
)
8723 Error_Msg_Uint_1
= UI_From_gnu (t
);
8724 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
8727 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
8729 for (p
= msg
, q
= new_msg
; *p
; p
++)
8731 if (*p
== start_yes
)
8732 for (p
++; *p
!= end_yes
; p
++)
8734 else if (*p
== start_no
)
8735 for (p
++; *p
!= end_no
; p
++)
8743 post_error_ne (new_msg
, node
, ent
);
8746 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
8749 post_error_ne_tree_2 (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
,
8752 Error_Msg_Uint_2
= UI_From_Int (num
);
8753 post_error_ne_tree (msg
, node
, ent
, t
);
8756 /* Initialize the table that maps GNAT codes to GCC codes for simple
8757 binary and unary operations. */
8760 init_code_table (void)
8762 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
8763 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
8765 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
8766 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
8767 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
8768 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
8769 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
8770 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
8771 gnu_codes
[N_Op_Le
] = LE_EXPR
;
8772 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
8773 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
8774 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
8775 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
8776 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
8777 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
8778 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
8779 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
8780 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
8781 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
8782 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
8783 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
8784 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
8785 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
8786 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
8789 /* Return a label to branch to for the exception type in KIND or NULL_TREE
8793 get_exception_label (char kind
)
8795 if (kind
== N_Raise_Constraint_Error
)
8796 return VEC_last (tree
, gnu_constraint_error_label_stack
);
8797 else if (kind
== N_Raise_Storage_Error
)
8798 return VEC_last (tree
, gnu_storage_error_label_stack
);
8799 else if (kind
== N_Raise_Program_Error
)
8800 return VEC_last (tree
, gnu_program_error_label_stack
);
8805 /* Return the decl for the current elaboration procedure. */
8808 get_elaboration_procedure (void)
8810 return VEC_last (tree
, gnu_elab_proc_stack
);
8813 #include "gt-ada-trans.h"