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 /* Create a temporary variable with PREFIX and TYPE, and return it. */
3306 create_temporary (const char *prefix
, tree type
)
3308 tree gnu_temp
= create_var_decl (create_tmp_var_name (prefix
), NULL_TREE
,
3309 type
, NULL_TREE
, false, false, false, false,
3311 DECL_ARTIFICIAL (gnu_temp
) = 1;
3312 DECL_IGNORED_P (gnu_temp
) = 1;
3317 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
3318 Put the initialization statement into GNU_INIT_STMT and annotate it with
3319 the SLOC of GNAT_NODE. Return the temporary variable. */
3322 create_init_temporary (const char *prefix
, tree gnu_init
, tree
*gnu_init_stmt
,
3325 tree gnu_temp
= create_temporary (prefix
, TREE_TYPE (gnu_init
));
3327 *gnu_init_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_temp
, gnu_init
);
3328 set_expr_location_from_node (*gnu_init_stmt
, gnat_node
);
3333 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
3334 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
3335 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
3336 If GNU_TARGET is non-null, this must be a function call on the RHS of a
3337 N_Assignment_Statement and the result is to be placed into that object. */
3340 call_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, tree gnu_target
)
3342 const bool function_call
= (Nkind (gnat_node
) == N_Function_Call
);
3343 const bool returning_value
= (function_call
&& !gnu_target
);
3344 /* The GCC node corresponding to the GNAT subprogram name. This can either
3345 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
3346 or an indirect reference expression (an INDIRECT_REF node) pointing to a
3348 tree gnu_subprog
= gnat_to_gnu (Name (gnat_node
));
3349 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
3350 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog
);
3351 /* The return type of the FUNCTION_TYPE. */
3352 tree gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
3353 tree gnu_subprog_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog
);
3354 VEC(tree
,gc
) *gnu_actual_vec
= NULL
;
3355 tree gnu_name_list
= NULL_TREE
;
3356 tree gnu_stmt_list
= NULL_TREE
;
3357 tree gnu_after_list
= NULL_TREE
;
3358 tree gnu_retval
= NULL_TREE
;
3359 tree gnu_call
, gnu_result
;
3360 bool went_into_elab_proc
= false;
3361 bool pushed_binding_level
= false;
3362 Entity_Id gnat_formal
;
3363 Node_Id gnat_actual
;
3365 gcc_assert (TREE_CODE (gnu_subprog_type
) == FUNCTION_TYPE
);
3367 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
3368 all our args first. */
3369 if (TREE_CODE (gnu_subprog
) == FUNCTION_DECL
&& DECL_STUBBED_P (gnu_subprog
))
3371 tree call_expr
= build_call_raise (PE_Stubbed_Subprogram_Called
,
3372 gnat_node
, N_Raise_Program_Error
);
3374 for (gnat_actual
= First_Actual (gnat_node
);
3375 Present (gnat_actual
);
3376 gnat_actual
= Next_Actual (gnat_actual
))
3377 add_stmt (gnat_to_gnu (gnat_actual
));
3379 if (returning_value
)
3381 *gnu_result_type_p
= gnu_result_type
;
3382 return build1 (NULL_EXPR
, gnu_result_type
, call_expr
);
3388 /* The only way we can be making a call via an access type is if Name is an
3389 explicit dereference. In that case, get the list of formal args from the
3390 type the access type is pointing to. Otherwise, get the formals from the
3391 entity being called. */
3392 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3393 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
3394 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
3395 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
3396 gnat_formal
= Empty
;
3398 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
3400 /* The lifetime of the temporaries created for the call ends right after the
3401 return value is copied, so we can give them the scope of the elaboration
3402 routine at top level. */
3403 if (!current_function_decl
)
3405 current_function_decl
= get_elaboration_procedure ();
3406 went_into_elab_proc
= true;
3409 /* First, create the temporary for the return value if we need it: for a
3410 variable-sized return type if there is no target or if this is slice,
3411 because the gimplifier doesn't support these cases; or for a function
3412 with copy-in/copy-out parameters if there is no target, because we'll
3413 need to preserve the return value before copying back the parameters.
3414 This must be done before we push a new binding level around the call
3415 as we will pop it before copying the return value. */
3417 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3418 && (!gnu_target
|| TREE_CODE (gnu_target
) == ARRAY_RANGE_REF
))
3419 || (!gnu_target
&& TYPE_CI_CO_LIST (gnu_subprog_type
))))
3420 gnu_retval
= create_temporary ("R", gnu_result_type
);
3422 /* Create the list of the actual parameters as GCC expects it, namely a
3423 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
3424 is an expression and the TREE_PURPOSE field is null. But skip Out
3425 parameters not passed by reference and that need not be copied in. */
3426 for (gnat_actual
= First_Actual (gnat_node
);
3427 Present (gnat_actual
);
3428 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3429 gnat_actual
= Next_Actual (gnat_actual
))
3431 tree gnu_formal
= present_gnu_tree (gnat_formal
)
3432 ? get_gnu_tree (gnat_formal
) : NULL_TREE
;
3433 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
3434 const bool is_true_formal_parm
3435 = gnu_formal
&& TREE_CODE (gnu_formal
) == PARM_DECL
;
3436 /* In the Out or In Out case, we must suppress conversions that yield
3437 an lvalue but can nevertheless cause the creation of a temporary,
3438 because we need the real object in this case, either to pass its
3439 address if it's passed by reference or as target of the back copy
3440 done after the call if it uses the copy-in/copy-out mechanism.
3441 We do it in the In case too, except for an unchecked conversion
3442 because it alone can cause the actual to be misaligned and the
3443 addressability test is applied to the real object. */
3444 const bool suppress_type_conversion
3445 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
3446 && Ekind (gnat_formal
) != E_In_Parameter
)
3447 || (Nkind (gnat_actual
) == N_Type_Conversion
3448 && Is_Composite_Type (Underlying_Type (Etype (gnat_formal
)))));
3449 Node_Id gnat_name
= suppress_type_conversion
3450 ? Expression (gnat_actual
) : gnat_actual
;
3451 tree gnu_name
= gnat_to_gnu (gnat_name
), gnu_name_type
;
3454 /* If it's possible we may need to use this expression twice, make sure
3455 that any side-effects are handled via SAVE_EXPRs; likewise if we need
3456 to force side-effects before the call.
3457 ??? This is more conservative than we need since we don't need to do
3458 this for pass-by-ref with no conversion. */
3459 if (Ekind (gnat_formal
) != E_In_Parameter
)
3460 gnu_name
= gnat_stabilize_reference (gnu_name
, true, NULL
);
3462 /* If we are passing a non-addressable parameter by reference, pass the
3463 address of a copy. In the Out or In Out case, set up to copy back
3464 out after the call. */
3465 if (is_true_formal_parm
3466 && (DECL_BY_REF_P (gnu_formal
)
3467 || DECL_BY_COMPONENT_PTR_P (gnu_formal
)
3468 || DECL_BY_DESCRIPTOR_P (gnu_formal
))
3469 && (gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
)))
3470 && !addressable_p (gnu_name
, gnu_name_type
))
3472 bool in_param
= (Ekind (gnat_formal
) == E_In_Parameter
);
3473 tree gnu_orig
= gnu_name
, gnu_temp
, gnu_stmt
;
3475 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
3476 but sort of an instantiation for them. */
3477 if (TREE_CODE (gnu_name
) == CONSTRUCTOR
)
3480 /* If the type is passed by reference, a copy is not allowed. */
3481 else if (TREE_ADDRESSABLE (gnu_formal_type
))
3482 post_error ("misaligned actual cannot be passed by reference",
3485 /* For users of Starlet we issue a warning because the interface
3486 apparently assumes that by-ref parameters outlive the procedure
3487 invocation. The code still will not work as intended, but we
3488 cannot do much better since low-level parts of the back-end
3489 would allocate temporaries at will because of the misalignment
3490 if we did not do so here. */
3491 else if (Is_Valued_Procedure (Entity (Name (gnat_node
))))
3494 ("?possible violation of implicit assumption", gnat_actual
);
3496 ("?made by pragma Import_Valued_Procedure on &", gnat_actual
,
3497 Entity (Name (gnat_node
)));
3498 post_error_ne ("?because of misalignment of &", gnat_actual
,
3502 /* If the actual type of the object is already the nominal type,
3503 we have nothing to do, except if the size is self-referential
3504 in which case we'll remove the unpadding below. */
3505 if (TREE_TYPE (gnu_name
) == gnu_name_type
3506 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type
)))
3509 /* Otherwise remove the unpadding from all the objects. */
3510 else if (TREE_CODE (gnu_name
) == COMPONENT_REF
3511 && TYPE_IS_PADDING_P
3512 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))
3513 gnu_orig
= gnu_name
= TREE_OPERAND (gnu_name
, 0);
3515 /* Otherwise convert to the nominal type of the object if needed.
3516 There are several cases in which we need to make the temporary
3517 using this type instead of the actual type of the object when
3518 they are distinct, because the expectations of the callee would
3519 otherwise not be met:
3520 - if it's a justified modular type,
3521 - if the actual type is a smaller form of it,
3522 - if it's a smaller form of the actual type. */
3523 else if ((TREE_CODE (gnu_name_type
) == RECORD_TYPE
3524 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type
)
3525 || smaller_form_type_p (TREE_TYPE (gnu_name
),
3527 || (INTEGRAL_TYPE_P (gnu_name_type
)
3528 && smaller_form_type_p (gnu_name_type
,
3529 TREE_TYPE (gnu_name
))))
3530 gnu_name
= convert (gnu_name_type
, gnu_name
);
3532 /* If this is an In Out or Out parameter and we're returning a value,
3533 we need to create a temporary for the return value because we must
3534 preserve it before copying back at the very end. */
3535 if (!in_param
&& returning_value
&& !gnu_retval
)
3536 gnu_retval
= create_temporary ("R", gnu_result_type
);
3538 /* If we haven't pushed a binding level, push a new one. This will
3539 narrow the lifetime of the temporary we are about to make as much
3540 as possible. The drawback is that we'd need to create a temporary
3541 for the return value, if any (see comment before the loop). So do
3542 it only when this temporary was already created just above. */
3543 if (!pushed_binding_level
&& !(in_param
&& returning_value
))
3545 start_stmt_group ();
3547 pushed_binding_level
= true;
3550 /* Create an explicit temporary holding the copy. */
3552 = create_init_temporary ("A", gnu_name
, &gnu_stmt
, gnat_actual
);
3554 /* But initialize it on the fly like for an implicit temporary as
3555 we aren't necessarily having a statement list. */
3556 gnu_name
= build_compound_expr (TREE_TYPE (gnu_name
), gnu_stmt
,
3559 /* Set up to move the copy back to the original if needed. */
3562 gnu_stmt
= build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_orig
,
3564 set_expr_location_from_node (gnu_stmt
, gnat_node
);
3565 append_to_statement_list (gnu_stmt
, &gnu_after_list
);
3569 /* Start from the real object and build the actual. */
3570 gnu_actual
= gnu_name
;
3572 /* If this was a procedure call, we may not have removed any padding.
3573 So do it here for the part we will use as an input, if any. */
3574 if (Ekind (gnat_formal
) != E_Out_Parameter
3575 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
3577 = convert (get_unpadded_type (Etype (gnat_actual
)), gnu_actual
);
3579 /* Put back the conversion we suppressed above in the computation of the
3580 real object. And even if we didn't suppress any conversion there, we
3581 may have suppressed a conversion to the Etype of the actual earlier,
3582 since the parent is a procedure call, so put it back here. */
3583 if (suppress_type_conversion
3584 && Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
3586 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
3587 gnu_actual
, No_Truncation (gnat_actual
));
3590 = convert (gnat_to_gnu_type (Etype (gnat_actual
)), gnu_actual
);
3592 /* Make sure that the actual is in range of the formal's type. */
3593 if (Ekind (gnat_formal
) != E_Out_Parameter
3594 && Do_Range_Check (gnat_actual
))
3596 = emit_range_check (gnu_actual
, Etype (gnat_formal
), gnat_actual
);
3598 /* Unless this is an In parameter, we must remove any justified modular
3599 building from GNU_NAME to get an lvalue. */
3600 if (Ekind (gnat_formal
) != E_In_Parameter
3601 && TREE_CODE (gnu_name
) == CONSTRUCTOR
3602 && TREE_CODE (TREE_TYPE (gnu_name
)) == RECORD_TYPE
3603 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name
)))
3605 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name
))), gnu_name
);
3607 /* If we have not saved a GCC object for the formal, it means it is an
3608 Out parameter not passed by reference and that need not be copied in.
3609 Otherwise, first see if the parameter is passed by reference. */
3610 if (is_true_formal_parm
&& DECL_BY_REF_P (gnu_formal
))
3612 if (Ekind (gnat_formal
) != E_In_Parameter
)
3614 /* In Out or Out parameters passed by reference don't use the
3615 copy-in/copy-out mechanism so the address of the real object
3616 must be passed to the function. */
3617 gnu_actual
= gnu_name
;
3619 /* If we have a padded type, be sure we've removed padding. */
3620 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
3621 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
3624 /* If we have the constructed subtype of an aliased object
3625 with an unconstrained nominal subtype, the type of the
3626 actual includes the template, although it is formally
3627 constrained. So we need to convert it back to the real
3628 constructed subtype to retrieve the constrained part
3629 and takes its address. */
3630 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
3631 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual
))
3632 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual
))
3633 && Is_Array_Type (Etype (gnat_actual
)))
3634 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
3638 /* There is no need to convert the actual to the formal's type before
3639 taking its address. The only exception is for unconstrained array
3640 types because of the way we build fat pointers. */
3641 if (TREE_CODE (gnu_formal_type
) == UNCONSTRAINED_ARRAY_TYPE
)
3643 /* Put back a view conversion for In Out or Out parameters. */
3644 if (Ekind (gnat_formal
) != E_In_Parameter
)
3645 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
3647 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3650 /* The symmetry of the paths to the type of an entity is broken here
3651 since arguments don't know that they will be passed by ref. */
3652 gnu_formal_type
= TREE_TYPE (gnu_formal
);
3654 if (DECL_BY_DOUBLE_REF_P (gnu_formal
))
3656 = build_unary_op (ADDR_EXPR
, TREE_TYPE (gnu_formal_type
),
3659 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
3661 else if (is_true_formal_parm
&& DECL_BY_COMPONENT_PTR_P (gnu_formal
))
3663 gnu_formal_type
= TREE_TYPE (gnu_formal
);
3664 gnu_actual
= maybe_implicit_deref (gnu_actual
);
3665 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
3667 if (TYPE_IS_PADDING_P (gnu_formal_type
))
3669 gnu_formal_type
= TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
3670 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3673 /* Take the address of the object and convert to the proper pointer
3674 type. We'd like to actually compute the address of the beginning
3675 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
3676 possibility that the ARRAY_REF might return a constant and we'd be
3677 getting the wrong address. Neither approach is exactly correct,
3678 but this is the most likely to work in all cases. */
3679 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
3681 else if (is_true_formal_parm
&& DECL_BY_DESCRIPTOR_P (gnu_formal
))
3683 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3685 /* If this is 'Null_Parameter, pass a zero descriptor. */
3686 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
3687 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
3688 && TREE_PRIVATE (gnu_actual
))
3690 = convert (DECL_ARG_TYPE (gnu_formal
), integer_zero_node
);
3692 gnu_actual
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
3694 (TREE_TYPE (TREE_TYPE (gnu_formal
)),
3695 gnu_actual
, gnat_actual
));
3701 if (Ekind (gnat_formal
) != E_In_Parameter
)
3702 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
3704 if (!is_true_formal_parm
)
3706 /* Make sure side-effects are evaluated before the call. */
3707 if (TREE_SIDE_EFFECTS (gnu_name
))
3708 append_to_statement_list (gnu_name
, &gnu_stmt_list
);
3712 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3714 /* If this is 'Null_Parameter, pass a zero even though we are
3715 dereferencing it. */
3716 if (TREE_CODE (gnu_actual
) == INDIRECT_REF
3717 && TREE_PRIVATE (gnu_actual
)
3718 && (gnu_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
)))
3719 && TREE_CODE (gnu_size
) == INTEGER_CST
3720 && compare_tree_int (gnu_size
, BITS_PER_WORD
) <= 0)
3722 = unchecked_convert (DECL_ARG_TYPE (gnu_formal
),
3723 convert (gnat_type_for_size
3724 (TREE_INT_CST_LOW (gnu_size
), 1),
3728 gnu_actual
= convert (DECL_ARG_TYPE (gnu_formal
), gnu_actual
);
3731 VEC_safe_push (tree
, gc
, gnu_actual_vec
, gnu_actual
);
3735 = build_call_vec (gnu_result_type
, gnu_subprog_addr
, gnu_actual_vec
);
3736 set_expr_location_from_node (gnu_call
, gnat_node
);
3738 /* If we have created a temporary for the return value, initialize it. */
3742 = build_binary_op (INIT_EXPR
, NULL_TREE
, gnu_retval
, gnu_call
);
3743 set_expr_location_from_node (gnu_stmt
, gnat_node
);
3744 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
3745 gnu_call
= gnu_retval
;
3748 /* If this is a subprogram with copy-in/copy-out parameters, we need to
3749 unpack the valued returned from the function into the In Out or Out
3750 parameters. We deal with the function return (if this is an Ada
3752 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
3754 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
3755 copy-out parameters. */
3756 tree gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3757 const int length
= list_length (gnu_cico_list
);
3759 /* The call sequence must contain one and only one call, even though the
3760 function is pure. Save the result into a temporary if needed. */
3766 /* If we haven't pushed a binding level, push a new one. This
3767 will narrow the lifetime of the temporary we are about to
3768 make as much as possible. */
3769 if (!pushed_binding_level
)
3771 start_stmt_group ();
3773 pushed_binding_level
= true;
3776 = create_init_temporary ("P", gnu_call
, &gnu_stmt
, gnat_node
);
3777 append_to_statement_list (gnu_stmt
, &gnu_stmt_list
);
3780 gnu_name_list
= nreverse (gnu_name_list
);
3783 /* The first entry is for the actual return value if this is a
3784 function, so skip it. */
3785 if (TREE_VALUE (gnu_cico_list
) == void_type_node
)
3786 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
3788 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3789 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
3791 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
3793 for (gnat_actual
= First_Actual (gnat_node
);
3794 Present (gnat_actual
);
3795 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3796 gnat_actual
= Next_Actual (gnat_actual
))
3797 /* If we are dealing with a copy-in/copy-out parameter, we must
3798 retrieve its value from the record returned in the call. */
3799 if (!(present_gnu_tree (gnat_formal
)
3800 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3801 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
3802 || (TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3803 && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))
3804 || (DECL_BY_DESCRIPTOR_P
3805 (get_gnu_tree (gnat_formal
))))))))
3806 && Ekind (gnat_formal
) != E_In_Parameter
)
3808 /* Get the value to assign to this Out or In Out parameter. It is
3809 either the result of the function if there is only a single such
3810 parameter or the appropriate field from the record returned. */
3814 : build_component_ref (gnu_call
, NULL_TREE
,
3815 TREE_PURPOSE (gnu_cico_list
), false);
3817 /* If the actual is a conversion, get the inner expression, which
3818 will be the real destination, and convert the result to the
3819 type of the actual parameter. */
3821 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
3823 /* If the result is a padded type, remove the padding. */
3824 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3826 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
3829 /* If the actual is a type conversion, the real target object is
3830 denoted by the inner Expression and we need to convert the
3831 result to the associated type.
3832 We also need to convert our gnu assignment target to this type
3833 if the corresponding GNU_NAME was constructed from the GNAT
3834 conversion node and not from the inner Expression. */
3835 if (Nkind (gnat_actual
) == N_Type_Conversion
)
3838 = convert_with_check
3839 (Etype (Expression (gnat_actual
)), gnu_result
,
3840 Do_Overflow_Check (gnat_actual
),
3841 Do_Range_Check (Expression (gnat_actual
)),
3842 Float_Truncate (gnat_actual
), gnat_actual
);
3844 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal
))))
3845 gnu_actual
= convert (TREE_TYPE (gnu_result
), gnu_actual
);
3848 /* Unchecked conversions as actuals for Out parameters are not
3849 allowed in user code because they are not variables, but do
3850 occur in front-end expansions. The associated GNU_NAME is
3851 always obtained from the inner expression in such cases. */
3852 else if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
3853 gnu_result
= unchecked_convert (TREE_TYPE (gnu_actual
),
3855 No_Truncation (gnat_actual
));
3858 if (Do_Range_Check (gnat_actual
))
3860 = emit_range_check (gnu_result
, Etype (gnat_actual
),
3863 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
3864 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
3865 gnu_result
= convert (TREE_TYPE (gnu_actual
), gnu_result
);
3868 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3869 gnu_actual
, gnu_result
);
3870 set_expr_location_from_node (gnu_result
, gnat_node
);
3871 append_to_statement_list (gnu_result
, &gnu_stmt_list
);
3872 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
);
3873 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
3877 /* If this is a function call, the result is the call expression unless a
3878 target is specified, in which case we copy the result into the target
3879 and return the assignment statement. */
3882 /* If this is a function with copy-in/copy-out parameters, extract the
3883 return value from it and update the return type. */
3884 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
3886 tree gnu_elmt
= value_member (void_type_node
,
3887 TYPE_CI_CO_LIST (gnu_subprog_type
));
3888 gnu_call
= build_component_ref (gnu_call
, NULL_TREE
,
3889 TREE_PURPOSE (gnu_elmt
), false);
3890 gnu_result_type
= TREE_TYPE (gnu_call
);
3893 /* If the function returns an unconstrained array or by direct reference,
3894 we have to dereference the pointer. */
3895 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
)
3896 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
))
3897 gnu_call
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_call
);
3901 Node_Id gnat_parent
= Parent (gnat_node
);
3902 enum tree_code op_code
;
3904 /* If range check is needed, emit code to generate it. */
3905 if (Do_Range_Check (gnat_node
))
3907 = emit_range_check (gnu_call
, Etype (Name (gnat_parent
)),
3910 /* ??? If the return type has variable size, then force the return
3911 slot optimization as we would not be able to create a temporary.
3912 Likewise if it was unconstrained as we would copy too much data.
3913 That's what has been done historically. */
3914 if (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3915 || (TYPE_IS_PADDING_P (gnu_result_type
)
3916 && CONTAINS_PLACEHOLDER_P
3917 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type
))))))
3918 op_code
= INIT_EXPR
;
3920 op_code
= MODIFY_EXPR
;
3923 = build_binary_op (op_code
, NULL_TREE
, gnu_target
, gnu_call
);
3924 set_expr_location_from_node (gnu_call
, gnat_parent
);
3925 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
3928 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
3931 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
3932 parameters, the result is just the call statement. */
3933 else if (!TYPE_CI_CO_LIST (gnu_subprog_type
))
3934 append_to_statement_list (gnu_call
, &gnu_stmt_list
);
3936 /* Finally, add the copy back statements, if any. */
3937 append_to_statement_list (gnu_after_list
, &gnu_stmt_list
);
3939 if (went_into_elab_proc
)
3940 current_function_decl
= NULL_TREE
;
3942 /* If we have pushed a binding level, pop it and finish up the enclosing
3944 if (pushed_binding_level
)
3946 add_stmt (gnu_stmt_list
);
3948 gnu_result
= end_stmt_group ();
3951 /* Otherwise, retrieve the statement list, if any. */
3952 else if (gnu_stmt_list
)
3953 gnu_result
= gnu_stmt_list
;
3955 /* Otherwise, just return the call expression. */
3959 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
3960 But first simplify if we have only one statement in the list. */
3961 if (returning_value
)
3963 tree first
= expr_first (gnu_result
), last
= expr_last (gnu_result
);
3967 = build_compound_expr (TREE_TYPE (gnu_call
), gnu_result
, gnu_call
);
3973 /* Subroutine of gnat_to_gnu to translate gnat_node, an
3974 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
3977 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node
)
3979 tree gnu_jmpsave_decl
= NULL_TREE
;
3980 tree gnu_jmpbuf_decl
= NULL_TREE
;
3981 /* If just annotating, ignore all EH and cleanups. */
3982 bool gcc_zcx
= (!type_annotate_only
3983 && Present (Exception_Handlers (gnat_node
))
3984 && Exception_Mechanism
== Back_End_Exceptions
);
3986 = (!type_annotate_only
&& Present (Exception_Handlers (gnat_node
))
3987 && Exception_Mechanism
== Setjmp_Longjmp
);
3988 bool at_end
= !type_annotate_only
&& Present (At_End_Proc (gnat_node
));
3989 bool binding_for_block
= (at_end
|| gcc_zcx
|| setjmp_longjmp
);
3990 tree gnu_inner_block
; /* The statement(s) for the block itself. */
3995 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
3996 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
3997 add_cleanup, and when we leave the binding, end_stmt_group will create
3998 the TRY_FINALLY_EXPR.
4000 ??? The region level calls down there have been specifically put in place
4001 for a ZCX context and currently the order in which things are emitted
4002 (region/handlers) is different from the SJLJ case. Instead of putting
4003 other calls with different conditions at other places for the SJLJ case,
4004 it seems cleaner to reorder things for the SJLJ case and generalize the
4005 condition to make it not ZCX specific.
4007 If there are any exceptions or cleanup processing involved, we need an
4008 outer statement group (for Setjmp_Longjmp) and binding level. */
4009 if (binding_for_block
)
4011 start_stmt_group ();
4015 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
4016 area for address of previous buffer. Do this first since we need to have
4017 the setjmp buf known for any decls in this block. */
4021 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
4023 build_call_n_expr (get_jmpbuf_decl
, 0),
4024 false, false, false, false, NULL
, gnat_node
);
4025 DECL_ARTIFICIAL (gnu_jmpsave_decl
) = 1;
4027 /* The __builtin_setjmp receivers will immediately reinstall it. Now
4028 because of the unstructured form of EH used by setjmp_longjmp, there
4029 might be forward edges going to __builtin_setjmp receivers on which
4030 it is uninitialized, although they will never be actually taken. */
4031 TREE_NO_WARNING (gnu_jmpsave_decl
) = 1;
4033 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE
,
4036 false, false, false, false, NULL
, gnat_node
);
4037 DECL_ARTIFICIAL (gnu_jmpbuf_decl
) = 1;
4039 set_block_jmpbuf_decl (gnu_jmpbuf_decl
);
4041 /* When we exit this block, restore the saved value. */
4042 add_cleanup (build_call_n_expr (set_jmpbuf_decl
, 1, gnu_jmpsave_decl
),
4043 End_Label (gnat_node
));
4046 /* If we are to call a function when exiting this block, add a cleanup
4047 to the binding level we made above. Note that add_cleanup is FIFO
4048 so we must register this cleanup after the EH cleanup just above. */
4050 add_cleanup (build_call_n_expr (gnat_to_gnu (At_End_Proc (gnat_node
)), 0),
4051 End_Label (gnat_node
));
4053 /* Now build the tree for the declarations and statements inside this block.
4054 If this is SJLJ, set our jmp_buf as the current buffer. */
4055 start_stmt_group ();
4058 add_stmt (build_call_n_expr (set_jmpbuf_decl
, 1,
4059 build_unary_op (ADDR_EXPR
, NULL_TREE
,
4062 if (Present (First_Real_Statement (gnat_node
)))
4063 process_decls (Statements (gnat_node
), Empty
,
4064 First_Real_Statement (gnat_node
), true, true);
4066 /* Generate code for each statement in the block. */
4067 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
4068 ? First_Real_Statement (gnat_node
)
4069 : First (Statements (gnat_node
)));
4070 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
4071 add_stmt (gnat_to_gnu (gnat_temp
));
4072 gnu_inner_block
= end_stmt_group ();
4074 /* Now generate code for the two exception models, if either is relevant for
4078 tree
*gnu_else_ptr
= 0;
4081 /* Make a binding level for the exception handling declarations and code
4082 and set up gnu_except_ptr_stack for the handlers to use. */
4083 start_stmt_group ();
4086 VEC_safe_push (tree
, gc
, gnu_except_ptr_stack
,
4087 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
4088 build_pointer_type (except_type_node
),
4089 build_call_n_expr (get_excptr_decl
, 0),
4090 false, false, false, false,
4093 /* Generate code for each handler. The N_Exception_Handler case does the
4094 real work and returns a COND_EXPR for each handler, which we chain
4096 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
4097 Present (gnat_temp
); gnat_temp
= Next_Non_Pragma (gnat_temp
))
4099 gnu_expr
= gnat_to_gnu (gnat_temp
);
4101 /* If this is the first one, set it as the outer one. Otherwise,
4102 point the "else" part of the previous handler to us. Then point
4103 to our "else" part. */
4105 add_stmt (gnu_expr
);
4107 *gnu_else_ptr
= gnu_expr
;
4109 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
4112 /* If none of the exception handlers did anything, re-raise but do not
4114 gnu_expr
= build_call_n_expr (raise_nodefer_decl
, 1,
4115 VEC_last (tree
, gnu_except_ptr_stack
));
4116 set_expr_location_from_node
4118 Present (End_Label (gnat_node
)) ? End_Label (gnat_node
) : gnat_node
);
4121 *gnu_else_ptr
= gnu_expr
;
4123 add_stmt (gnu_expr
);
4125 /* End the binding level dedicated to the exception handlers and get the
4126 whole statement group. */
4127 VEC_pop (tree
, gnu_except_ptr_stack
);
4129 gnu_handler
= end_stmt_group ();
4131 /* If the setjmp returns 1, we restore our incoming longjmp value and
4132 then check the handlers. */
4133 start_stmt_group ();
4134 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl
, 1,
4137 add_stmt (gnu_handler
);
4138 gnu_handler
= end_stmt_group ();
4140 /* This block is now "if (setjmp) ... <handlers> else <block>". */
4141 gnu_result
= build3 (COND_EXPR
, void_type_node
,
4144 build_unary_op (ADDR_EXPR
, NULL_TREE
,
4146 gnu_handler
, gnu_inner_block
);
4152 /* First make a block containing the handlers. */
4153 start_stmt_group ();
4154 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
4155 Present (gnat_temp
);
4156 gnat_temp
= Next_Non_Pragma (gnat_temp
))
4157 add_stmt (gnat_to_gnu (gnat_temp
));
4158 gnu_handlers
= end_stmt_group ();
4160 /* Now make the TRY_CATCH_EXPR for the block. */
4161 gnu_result
= build2 (TRY_CATCH_EXPR
, void_type_node
,
4162 gnu_inner_block
, gnu_handlers
);
4165 gnu_result
= gnu_inner_block
;
4167 /* Now close our outer block, if we had to make one. */
4168 if (binding_for_block
)
4170 add_stmt (gnu_result
);
4172 gnu_result
= end_stmt_group ();
4178 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4179 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
4180 exception handling. */
4183 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node
)
4185 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
4186 an "if" statement to select the proper exceptions. For "Others", exclude
4187 exceptions where Handled_By_Others is nonzero unless the All_Others flag
4188 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
4189 tree gnu_choice
= boolean_false_node
;
4190 tree gnu_body
= build_stmt_group (Statements (gnat_node
), false);
4193 for (gnat_temp
= First (Exception_Choices (gnat_node
));
4194 gnat_temp
; gnat_temp
= Next (gnat_temp
))
4198 if (Nkind (gnat_temp
) == N_Others_Choice
)
4200 if (All_Others (gnat_temp
))
4201 this_choice
= boolean_true_node
;
4205 (EQ_EXPR
, boolean_type_node
,
4210 (INDIRECT_REF
, NULL_TREE
,
4211 VEC_last (tree
, gnu_except_ptr_stack
)),
4212 get_identifier ("not_handled_by_others"), NULL_TREE
,
4217 else if (Nkind (gnat_temp
) == N_Identifier
4218 || Nkind (gnat_temp
) == N_Expanded_Name
)
4220 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
4223 /* Exception may be a renaming. Recover original exception which is
4224 the one elaborated and registered. */
4225 if (Present (Renamed_Object (gnat_ex_id
)))
4226 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
4228 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
4232 (EQ_EXPR
, boolean_type_node
,
4233 VEC_last (tree
, gnu_except_ptr_stack
),
4234 convert (TREE_TYPE (VEC_last (tree
, gnu_except_ptr_stack
)),
4235 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
4237 /* If this is the distinguished exception "Non_Ada_Error" (and we are
4238 in VMS mode), also allow a non-Ada exception (a VMS condition) t
4240 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
4243 = build_component_ref
4244 (build_unary_op (INDIRECT_REF
, NULL_TREE
,
4245 VEC_last (tree
, gnu_except_ptr_stack
)),
4246 get_identifier ("lang"), NULL_TREE
, false);
4250 (TRUTH_ORIF_EXPR
, boolean_type_node
,
4251 build_binary_op (EQ_EXPR
, boolean_type_node
, gnu_comp
,
4252 build_int_cst (TREE_TYPE (gnu_comp
), 'V')),
4259 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
4260 gnu_choice
, this_choice
);
4263 return build3 (COND_EXPR
, void_type_node
, gnu_choice
, gnu_body
, NULL_TREE
);
4266 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4267 to a GCC tree, which is returned. This is the variant for ZCX. */
4270 Exception_Handler_to_gnu_zcx (Node_Id gnat_node
)
4272 tree gnu_etypes_list
= NULL_TREE
;
4275 tree gnu_current_exc_ptr
;
4276 tree prev_gnu_incoming_exc_ptr
;
4279 /* We build a TREE_LIST of nodes representing what exception types this
4280 handler can catch, with special cases for others and all others cases.
4282 Each exception type is actually identified by a pointer to the exception
4283 id, or to a dummy object for "others" and "all others". */
4284 for (gnat_temp
= First (Exception_Choices (gnat_node
));
4285 gnat_temp
; gnat_temp
= Next (gnat_temp
))
4287 if (Nkind (gnat_temp
) == N_Others_Choice
)
4290 = All_Others (gnat_temp
) ? all_others_decl
: others_decl
;
4293 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
4295 else if (Nkind (gnat_temp
) == N_Identifier
4296 || Nkind (gnat_temp
) == N_Expanded_Name
)
4298 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
4300 /* Exception may be a renaming. Recover original exception which is
4301 the one elaborated and registered. */
4302 if (Present (Renamed_Object (gnat_ex_id
)))
4303 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
4305 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
4306 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
4308 /* The Non_Ada_Error case for VMS exceptions is handled
4309 by the personality routine. */
4314 /* The GCC interface expects NULL to be passed for catch all handlers, so
4315 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
4316 is integer_zero_node. It would not work, however, because GCC's
4317 notion of "catch all" is stronger than our notion of "others". Until
4318 we correctly use the cleanup interface as well, doing that would
4319 prevent the "all others" handlers from being seen, because nothing
4320 can be caught beyond a catch all from GCC's point of view. */
4321 gnu_etypes_list
= tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
4324 start_stmt_group ();
4327 /* Expand a call to the begin_handler hook at the beginning of the handler,
4328 and arrange for a call to the end_handler hook to occur on every possible
4331 The hooks expect a pointer to the low level occurrence. This is required
4332 for our stack management scheme because a raise inside the handler pushes
4333 a new occurrence on top of the stack, which means that this top does not
4334 necessarily match the occurrence this handler was dealing with.
4336 __builtin_eh_pointer references the exception occurrence being
4337 propagated. Upon handler entry, this is the exception for which the
4338 handler is triggered. This might not be the case upon handler exit,
4339 however, as we might have a new occurrence propagated by the handler's
4340 body, and the end_handler hook called as a cleanup in this context.
4342 We use a local variable to retrieve the incoming value at handler entry
4343 time, and reuse it to feed the end_handler hook's argument at exit. */
4346 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER
),
4347 1, integer_zero_node
);
4348 prev_gnu_incoming_exc_ptr
= gnu_incoming_exc_ptr
;
4349 gnu_incoming_exc_ptr
= create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
4350 ptr_type_node
, gnu_current_exc_ptr
,
4351 false, false, false, false,
4354 add_stmt_with_node (build_call_n_expr (begin_handler_decl
, 1,
4355 gnu_incoming_exc_ptr
),
4357 /* ??? We don't seem to have an End_Label at hand to set the location. */
4358 add_cleanup (build_call_n_expr (end_handler_decl
, 1, gnu_incoming_exc_ptr
),
4360 add_stmt_list (Statements (gnat_node
));
4363 gnu_incoming_exc_ptr
= prev_gnu_incoming_exc_ptr
;
4365 return build2 (CATCH_EXPR
, void_type_node
, gnu_etypes_list
,
4369 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
4372 Compilation_Unit_to_gnu (Node_Id gnat_node
)
4374 const Node_Id gnat_unit
= Unit (gnat_node
);
4375 const bool body_p
= (Nkind (gnat_unit
) == N_Package_Body
4376 || Nkind (gnat_unit
) == N_Subprogram_Body
);
4377 const Entity_Id gnat_unit_entity
= Defining_Entity (gnat_unit
);
4378 /* Make the decl for the elaboration procedure. */
4379 tree gnu_elab_proc_decl
4380 = create_subprog_decl
4381 (create_concat_name (gnat_unit_entity
, body_p
? "elabb" : "elabs"),
4382 NULL_TREE
, void_ftype
, NULL_TREE
, false, true, false, true, NULL
,
4384 struct elab_info
*info
;
4386 VEC_safe_push (tree
, gc
, gnu_elab_proc_stack
, gnu_elab_proc_decl
);
4387 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl
) = 1;
4389 /* Initialize the information structure for the function. */
4390 allocate_struct_function (gnu_elab_proc_decl
, false);
4393 current_function_decl
= NULL_TREE
;
4395 start_stmt_group ();
4398 /* For a body, first process the spec if there is one. */
4399 if (Nkind (gnat_unit
) == N_Package_Body
4400 || (Nkind (gnat_unit
) == N_Subprogram_Body
&& !Acts_As_Spec (gnat_node
)))
4401 add_stmt (gnat_to_gnu (Library_Unit (gnat_node
)));
4403 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
4405 elaborate_all_entities (gnat_node
);
4407 if (Nkind (gnat_unit
) == N_Subprogram_Declaration
4408 || Nkind (gnat_unit
) == N_Generic_Package_Declaration
4409 || Nkind (gnat_unit
) == N_Generic_Subprogram_Declaration
)
4413 process_decls (Declarations (Aux_Decls_Node (gnat_node
)), Empty
, Empty
,
4415 add_stmt (gnat_to_gnu (gnat_unit
));
4417 /* If we can inline, generate code for all the inlined subprograms. */
4420 Entity_Id gnat_entity
;
4422 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
4423 Present (gnat_entity
);
4424 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
4426 Node_Id gnat_body
= Parent (Declaration_Node (gnat_entity
));
4428 if (Nkind (gnat_body
) != N_Subprogram_Body
)
4430 /* ??? This really should always be present. */
4431 if (No (Corresponding_Body (gnat_body
)))
4434 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
4437 if (Present (gnat_body
))
4439 /* Define the entity first so we set DECL_EXTERNAL. */
4440 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4441 add_stmt (gnat_to_gnu (gnat_body
));
4446 /* Process any pragmas and actions following the unit. */
4447 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node
)));
4448 add_stmt_list (Actions (Aux_Decls_Node (gnat_node
)));
4449 finalize_from_with_types ();
4451 /* Save away what we've made so far and record this potential elaboration
4453 info
= ggc_alloc_elab_info ();
4454 set_current_block_context (gnu_elab_proc_decl
);
4456 DECL_SAVED_TREE (gnu_elab_proc_decl
) = end_stmt_group ();
4458 set_end_locus_from_node (gnu_elab_proc_decl
, gnat_unit
);
4460 info
->next
= elab_info_list
;
4461 info
->elab_proc
= gnu_elab_proc_decl
;
4462 info
->gnat_node
= gnat_node
;
4463 elab_info_list
= info
;
4465 /* Generate elaboration code for this unit, if necessary, and say whether
4467 VEC_pop (tree
, gnu_elab_proc_stack
);
4469 /* Invalidate the global renaming pointers. This is necessary because
4470 stabilization of the renamed entities may create SAVE_EXPRs which
4471 have been tied to a specific elaboration routine just above. */
4472 invalidate_global_renaming_pointers ();
4475 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
4476 parameter of a call. */
4479 lhs_or_actual_p (Node_Id gnat_node
)
4481 Node_Id gnat_parent
= Parent (gnat_node
);
4482 Node_Kind kind
= Nkind (gnat_parent
);
4484 if (kind
== N_Assignment_Statement
&& Name (gnat_parent
) == gnat_node
)
4487 if ((kind
== N_Procedure_Call_Statement
|| kind
== N_Function_Call
)
4488 && Name (gnat_parent
) != gnat_node
)
4491 if (kind
== N_Parameter_Association
)
4497 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
4498 as gigi is concerned. This is used to avoid conversions on the LHS. */
4501 unchecked_conversion_nop (Node_Id gnat_node
)
4503 Entity_Id from_type
, to_type
;
4505 /* The conversion must be on the LHS of an assignment or an actual parameter
4506 of a call. Otherwise, even if the conversion was essentially a no-op, it
4507 could de facto ensure type consistency and this should be preserved. */
4508 if (!lhs_or_actual_p (gnat_node
))
4511 from_type
= Etype (Expression (gnat_node
));
4513 /* We're interested in artificial conversions generated by the front-end
4514 to make private types explicit, e.g. in Expand_Assign_Array. */
4515 if (!Is_Private_Type (from_type
))
4518 from_type
= Underlying_Type (from_type
);
4519 to_type
= Etype (gnat_node
);
4521 /* The direct conversion to the underlying type is a no-op. */
4522 if (to_type
== from_type
)
4525 /* For an array subtype, the conversion to the PAT is a no-op. */
4526 if (Ekind (from_type
) == E_Array_Subtype
4527 && to_type
== Packed_Array_Type (from_type
))
4530 /* For a record subtype, the conversion to the type is a no-op. */
4531 if (Ekind (from_type
) == E_Record_Subtype
4532 && to_type
== Etype (from_type
))
4538 /* This function is the driver of the GNAT to GCC tree transformation process.
4539 It is the entry point of the tree transformer. GNAT_NODE is the root of
4540 some GNAT tree. Return the root of the corresponding GCC tree. If this
4541 is an expression, return the GCC equivalent of the expression. If this
4542 is a statement, return the statement or add it to the current statement
4543 group, in which case anything returned is to be interpreted as occurring
4544 after anything added. */
4547 gnat_to_gnu (Node_Id gnat_node
)
4549 const Node_Kind kind
= Nkind (gnat_node
);
4550 bool went_into_elab_proc
= false;
4551 tree gnu_result
= error_mark_node
; /* Default to no value. */
4552 tree gnu_result_type
= void_type_node
;
4553 tree gnu_expr
, gnu_lhs
, gnu_rhs
;
4556 /* Save node number for error message and set location information. */
4557 error_gnat_node
= gnat_node
;
4558 Sloc_to_locus (Sloc (gnat_node
), &input_location
);
4560 /* If this node is a statement and we are only annotating types, return an
4561 empty statement list. */
4562 if (type_annotate_only
&& IN (kind
, N_Statement_Other_Than_Procedure_Call
))
4563 return alloc_stmt_list ();
4565 /* If this node is a non-static subexpression and we are only annotating
4566 types, make this into a NULL_EXPR. */
4567 if (type_annotate_only
4568 && IN (kind
, N_Subexpr
)
4569 && kind
!= N_Identifier
4570 && !Compile_Time_Known_Value (gnat_node
))
4571 return build1 (NULL_EXPR
, get_unpadded_type (Etype (gnat_node
)),
4572 build_call_raise (CE_Range_Check_Failed
, gnat_node
,
4573 N_Raise_Constraint_Error
));
4575 if ((IN (kind
, N_Statement_Other_Than_Procedure_Call
)
4576 && kind
!= N_Null_Statement
)
4577 || kind
== N_Procedure_Call_Statement
4579 || kind
== N_Implicit_Label_Declaration
4580 || kind
== N_Handled_Sequence_Of_Statements
4581 || (IN (kind
, N_Raise_xxx_Error
) && Ekind (Etype (gnat_node
)) == E_Void
))
4583 tree current_elab_proc
= get_elaboration_procedure ();
4585 /* If this is a statement and we are at top level, it must be part of
4586 the elaboration procedure, so mark us as being in that procedure. */
4587 if (!current_function_decl
)
4589 current_function_decl
= current_elab_proc
;
4590 went_into_elab_proc
= true;
4593 /* If we are in the elaboration procedure, check if we are violating a
4594 No_Elaboration_Code restriction by having a statement there. Don't
4595 check for a possible No_Elaboration_Code restriction violation on
4596 N_Handled_Sequence_Of_Statements, as we want to signal an error on
4597 every nested real statement instead. This also avoids triggering
4598 spurious errors on dummy (empty) sequences created by the front-end
4599 for package bodies in some cases. */
4600 if (current_function_decl
== current_elab_proc
4601 && kind
!= N_Handled_Sequence_Of_Statements
)
4602 Check_Elaboration_Code_Allowed (gnat_node
);
4607 /********************************/
4608 /* Chapter 2: Lexical Elements */
4609 /********************************/
4612 case N_Expanded_Name
:
4613 case N_Operator_Symbol
:
4614 case N_Defining_Identifier
:
4615 gnu_result
= Identifier_to_gnu (gnat_node
, &gnu_result_type
);
4618 case N_Integer_Literal
:
4622 /* Get the type of the result, looking inside any padding and
4623 justified modular types. Then get the value in that type. */
4624 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4626 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4627 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
4628 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
4630 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
4632 /* If the result overflows (meaning it doesn't fit in its base type),
4633 abort. We would like to check that the value is within the range
4634 of the subtype, but that causes problems with subtypes whose usage
4635 will raise Constraint_Error and with biased representation, so
4637 gcc_assert (!TREE_OVERFLOW (gnu_result
));
4641 case N_Character_Literal
:
4642 /* If a Entity is present, it means that this was one of the
4643 literals in a user-defined character type. In that case,
4644 just return the value in the CONST_DECL. Otherwise, use the
4645 character code. In that case, the base type should be an
4646 INTEGER_TYPE, but we won't bother checking for that. */
4647 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4648 if (Present (Entity (gnat_node
)))
4649 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
4652 = build_int_cst_type
4653 (gnu_result_type
, UI_To_CC (Char_Literal_Value (gnat_node
)));
4656 case N_Real_Literal
:
4657 /* If this is of a fixed-point type, the value we want is the
4658 value of the corresponding integer. */
4659 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
4661 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4662 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
4664 gcc_assert (!TREE_OVERFLOW (gnu_result
));
4667 /* We should never see a Vax_Float type literal, since the front end
4668 is supposed to transform these using appropriate conversions. */
4669 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
4674 Ureal ur_realval
= Realval (gnat_node
);
4676 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4678 /* If the real value is zero, so is the result. Otherwise,
4679 convert it to a machine number if it isn't already. That
4680 forces BASE to 0 or 2 and simplifies the rest of our logic. */
4681 if (UR_Is_Zero (ur_realval
))
4682 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
4685 if (!Is_Machine_Number (gnat_node
))
4687 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
4688 ur_realval
, Round_Even
, gnat_node
);
4691 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
4693 /* If we have a base of zero, divide by the denominator.
4694 Otherwise, the base must be 2 and we scale the value, which
4695 we know can fit in the mantissa of the type (hence the use
4696 of that type above). */
4697 if (No (Rbase (ur_realval
)))
4699 = build_binary_op (RDIV_EXPR
,
4700 get_base_type (gnu_result_type
),
4702 UI_To_gnu (Denominator (ur_realval
),
4706 REAL_VALUE_TYPE tmp
;
4708 gcc_assert (Rbase (ur_realval
) == 2);
4709 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
4710 - UI_To_Int (Denominator (ur_realval
)));
4711 gnu_result
= build_real (gnu_result_type
, tmp
);
4715 /* Now see if we need to negate the result. Do it this way to
4716 properly handle -0. */
4717 if (UR_Is_Negative (Realval (gnat_node
)))
4719 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
4725 case N_String_Literal
:
4726 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4727 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
4729 String_Id gnat_string
= Strval (gnat_node
);
4730 int length
= String_Length (gnat_string
);
4733 if (length
>= ALLOCA_THRESHOLD
)
4734 string
= XNEWVEC (char, length
+ 1);
4736 string
= (char *) alloca (length
+ 1);
4738 /* Build the string with the characters in the literal. Note
4739 that Ada strings are 1-origin. */
4740 for (i
= 0; i
< length
; i
++)
4741 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
4743 /* Put a null at the end of the string in case it's in a context
4744 where GCC will want to treat it as a C string. */
4747 gnu_result
= build_string (length
, string
);
4749 /* Strings in GCC don't normally have types, but we want
4750 this to not be converted to the array type. */
4751 TREE_TYPE (gnu_result
) = gnu_result_type
;
4753 if (length
>= ALLOCA_THRESHOLD
)
4758 /* Build a list consisting of each character, then make
4760 String_Id gnat_string
= Strval (gnat_node
);
4761 int length
= String_Length (gnat_string
);
4763 tree gnu_idx
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
4764 VEC(constructor_elt
,gc
) *gnu_vec
4765 = VEC_alloc (constructor_elt
, gc
, length
);
4767 for (i
= 0; i
< length
; i
++)
4769 tree t
= build_int_cst (TREE_TYPE (gnu_result_type
),
4770 Get_String_Char (gnat_string
, i
+ 1));
4772 CONSTRUCTOR_APPEND_ELT (gnu_vec
, gnu_idx
, t
);
4773 gnu_idx
= int_const_binop (PLUS_EXPR
, gnu_idx
, integer_one_node
);
4776 gnu_result
= gnat_build_constructor (gnu_result_type
, gnu_vec
);
4781 gnu_result
= Pragma_to_gnu (gnat_node
);
4784 /**************************************/
4785 /* Chapter 3: Declarations and Types */
4786 /**************************************/
4788 case N_Subtype_Declaration
:
4789 case N_Full_Type_Declaration
:
4790 case N_Incomplete_Type_Declaration
:
4791 case N_Private_Type_Declaration
:
4792 case N_Private_Extension_Declaration
:
4793 case N_Task_Type_Declaration
:
4794 process_type (Defining_Entity (gnat_node
));
4795 gnu_result
= alloc_stmt_list ();
4798 case N_Object_Declaration
:
4799 case N_Exception_Declaration
:
4800 gnat_temp
= Defining_Entity (gnat_node
);
4801 gnu_result
= alloc_stmt_list ();
4803 /* If we are just annotating types and this object has an unconstrained
4804 or task type, don't elaborate it. */
4805 if (type_annotate_only
4806 && (((Is_Array_Type (Etype (gnat_temp
))
4807 || Is_Record_Type (Etype (gnat_temp
)))
4808 && !Is_Constrained (Etype (gnat_temp
)))
4809 || Is_Concurrent_Type (Etype (gnat_temp
))))
4812 if (Present (Expression (gnat_node
))
4813 && !(kind
== N_Object_Declaration
&& No_Initialization (gnat_node
))
4814 && (!type_annotate_only
4815 || Compile_Time_Known_Value (Expression (gnat_node
))))
4817 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
4818 if (Do_Range_Check (Expression (gnat_node
)))
4820 = emit_range_check (gnu_expr
, Etype (gnat_temp
), gnat_node
);
4822 /* If this object has its elaboration delayed, we must force
4823 evaluation of GNU_EXPR right now and save it for when the object
4825 if (Present (Freeze_Node (gnat_temp
)))
4827 if (TREE_CONSTANT (gnu_expr
))
4829 else if (global_bindings_p ())
4831 = create_var_decl (create_concat_name (gnat_temp
, "init"),
4832 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
4833 false, false, false, false,
4836 gnu_expr
= gnat_save_expr (gnu_expr
);
4838 save_gnu_tree (gnat_node
, gnu_expr
, true);
4842 gnu_expr
= NULL_TREE
;
4844 if (type_annotate_only
&& gnu_expr
&& TREE_CODE (gnu_expr
) == ERROR_MARK
)
4845 gnu_expr
= NULL_TREE
;
4847 /* If this is a deferred constant with an address clause, we ignore the
4848 full view since the clause is on the partial view and we cannot have
4849 2 different GCC trees for the object. The only bits of the full view
4850 we will use is the initializer, but it will be directly fetched. */
4851 if (Ekind(gnat_temp
) == E_Constant
4852 && Present (Address_Clause (gnat_temp
))
4853 && Present (Full_View (gnat_temp
)))
4854 save_gnu_tree (Full_View (gnat_temp
), error_mark_node
, true);
4856 if (No (Freeze_Node (gnat_temp
)))
4857 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
4860 case N_Object_Renaming_Declaration
:
4861 gnat_temp
= Defining_Entity (gnat_node
);
4863 /* Don't do anything if this renaming is handled by the front end or if
4864 we are just annotating types and this object has a composite or task
4865 type, don't elaborate it. We return the result in case it has any
4866 SAVE_EXPRs in it that need to be evaluated here. */
4867 if (!Is_Renaming_Of_Object (gnat_temp
)
4868 && ! (type_annotate_only
4869 && (Is_Array_Type (Etype (gnat_temp
))
4870 || Is_Record_Type (Etype (gnat_temp
))
4871 || Is_Concurrent_Type (Etype (gnat_temp
)))))
4873 = gnat_to_gnu_entity (gnat_temp
,
4874 gnat_to_gnu (Renamed_Object (gnat_temp
)), 1);
4876 gnu_result
= alloc_stmt_list ();
4879 case N_Implicit_Label_Declaration
:
4880 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
4881 gnu_result
= alloc_stmt_list ();
4884 case N_Exception_Renaming_Declaration
:
4885 case N_Number_Declaration
:
4886 case N_Package_Renaming_Declaration
:
4887 case N_Subprogram_Renaming_Declaration
:
4888 /* These are fully handled in the front end. */
4889 gnu_result
= alloc_stmt_list ();
4892 /*************************************/
4893 /* Chapter 4: Names and Expressions */
4894 /*************************************/
4896 case N_Explicit_Dereference
:
4897 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
4898 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4899 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
4902 case N_Indexed_Component
:
4904 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
4908 Node_Id
*gnat_expr_array
;
4910 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
4912 /* Convert vector inputs to their representative array type, to fit
4913 what the code below expects. */
4914 gnu_array_object
= maybe_vector_array (gnu_array_object
);
4916 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
4918 /* If we got a padded type, remove it too. */
4919 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
4921 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
4924 gnu_result
= gnu_array_object
;
4926 /* First compute the number of dimensions of the array, then
4927 fill the expression array, the order depending on whether
4928 this is a Convention_Fortran array or not. */
4929 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
4930 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
4931 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
4932 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
4935 gnat_expr_array
= XALLOCAVEC (Node_Id
, ndim
);
4937 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
4938 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
4940 i
--, gnat_temp
= Next (gnat_temp
))
4941 gnat_expr_array
[i
] = gnat_temp
;
4943 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
4945 i
++, gnat_temp
= Next (gnat_temp
))
4946 gnat_expr_array
[i
] = gnat_temp
;
4948 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
4949 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
4951 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
4952 gnat_temp
= gnat_expr_array
[i
];
4953 gnu_expr
= gnat_to_gnu (gnat_temp
);
4955 if (Do_Range_Check (gnat_temp
))
4958 (gnu_array_object
, gnu_expr
,
4959 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
4960 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
4963 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
4964 gnu_result
, gnu_expr
);
4968 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4973 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
4976 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
4977 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4979 /* Do any implicit dereferences of the prefix and do any needed
4981 gnu_result
= maybe_implicit_deref (gnu_result
);
4982 gnu_result
= maybe_unconstrained_array (gnu_result
);
4983 gnu_type
= TREE_TYPE (gnu_result
);
4984 if (Do_Range_Check (gnat_range_node
))
4986 /* Get the bounds of the slice. */
4988 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
4989 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
4990 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
4991 /* Get the permitted bounds. */
4992 tree gnu_base_index_type
4993 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
));
4994 tree gnu_base_min_expr
= SUBSTITUTE_PLACEHOLDER_IN_EXPR
4995 (TYPE_MIN_VALUE (gnu_base_index_type
), gnu_result
);
4996 tree gnu_base_max_expr
= SUBSTITUTE_PLACEHOLDER_IN_EXPR
4997 (TYPE_MAX_VALUE (gnu_base_index_type
), gnu_result
);
4998 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
5000 gnu_min_expr
= gnat_protect_expr (gnu_min_expr
);
5001 gnu_max_expr
= gnat_protect_expr (gnu_max_expr
);
5003 /* Derive a good type to convert everything to. */
5004 gnu_expr_type
= get_base_type (gnu_index_type
);
5006 /* Test whether the minimum slice value is too small. */
5007 gnu_expr_l
= build_binary_op (LT_EXPR
, boolean_type_node
,
5008 convert (gnu_expr_type
,
5010 convert (gnu_expr_type
,
5011 gnu_base_min_expr
));
5013 /* Test whether the maximum slice value is too large. */
5014 gnu_expr_h
= build_binary_op (GT_EXPR
, boolean_type_node
,
5015 convert (gnu_expr_type
,
5017 convert (gnu_expr_type
,
5018 gnu_base_max_expr
));
5020 /* Build a slice index check that returns the low bound,
5021 assuming the slice is not empty. */
5022 gnu_expr
= emit_check
5023 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
5024 gnu_expr_l
, gnu_expr_h
),
5025 gnu_min_expr
, CE_Index_Check_Failed
, gnat_node
);
5027 /* Build a conditional expression that does the index checks and
5028 returns the low bound if the slice is not empty (max >= min),
5029 and returns the naked low bound otherwise (max < min), unless
5030 it is non-constant and the high bound is; this prevents VRP
5031 from inferring bogus ranges on the unlikely path. */
5032 gnu_expr
= fold_build3 (COND_EXPR
, gnu_expr_type
,
5033 build_binary_op (GE_EXPR
, gnu_expr_type
,
5034 convert (gnu_expr_type
,
5036 convert (gnu_expr_type
,
5039 TREE_CODE (gnu_min_expr
) != INTEGER_CST
5040 && TREE_CODE (gnu_max_expr
) == INTEGER_CST
5041 ? gnu_max_expr
: gnu_min_expr
);
5044 /* Simply return the naked low bound. */
5045 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
5047 /* If this is a slice with non-constant size of an array with constant
5048 size, set the maximum size for the allocation of temporaries. */
5049 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type
))
5050 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type
)))
5051 TYPE_ARRAY_MAX_SIZE (gnu_result_type
) = TYPE_SIZE_UNIT (gnu_type
);
5053 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
5054 gnu_result
, gnu_expr
);
5058 case N_Selected_Component
:
5060 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
5061 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
5062 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
5065 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
5066 || IN (Ekind (gnat_pref_type
), Access_Kind
))
5068 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
5069 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
5070 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
5071 gnat_pref_type
= Designated_Type (gnat_pref_type
);
5074 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
5076 /* For discriminant references in tagged types always substitute the
5077 corresponding discriminant as the actual selected component. */
5078 if (Is_Tagged_Type (gnat_pref_type
))
5079 while (Present (Corresponding_Discriminant (gnat_field
)))
5080 gnat_field
= Corresponding_Discriminant (gnat_field
);
5082 /* For discriminant references of untagged types always substitute the
5083 corresponding stored discriminant. */
5084 else if (Present (Corresponding_Discriminant (gnat_field
)))
5085 gnat_field
= Original_Record_Component (gnat_field
);
5087 /* Handle extracting the real or imaginary part of a complex.
5088 The real part is the first field and the imaginary the last. */
5089 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
5090 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
5091 ? REALPART_EXPR
: IMAGPART_EXPR
,
5092 NULL_TREE
, gnu_prefix
);
5095 gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
5097 /* If there are discriminants, the prefix might be evaluated more
5098 than once, which is a problem if it has side-effects. */
5099 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
5100 ? Designated_Type (Etype
5101 (Prefix (gnat_node
)))
5102 : Etype (Prefix (gnat_node
))))
5103 gnu_prefix
= gnat_stabilize_reference (gnu_prefix
, false, NULL
);
5106 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
,
5107 (Nkind (Parent (gnat_node
))
5108 == N_Attribute_Reference
)
5109 && lvalue_required_for_attribute_p
5110 (Parent (gnat_node
)));
5113 gcc_assert (gnu_result
);
5114 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5118 case N_Attribute_Reference
:
5120 /* The attribute designator. */
5121 const int attr
= Get_Attribute_Id (Attribute_Name (gnat_node
));
5123 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
5124 is a unit, not an object with a GCC equivalent. */
5125 if (attr
== Attr_Elab_Spec
|| attr
== Attr_Elab_Body
)
5127 create_subprog_decl (create_concat_name
5128 (Entity (Prefix (gnat_node
)),
5129 attr
== Attr_Elab_Body
? "elabb" : "elabs"),
5130 NULL_TREE
, void_ftype
, NULL_TREE
, false,
5131 true, true, true, NULL
, gnat_node
);
5133 gnu_result
= Attribute_to_gnu (gnat_node
, &gnu_result_type
, attr
);
5138 /* Like 'Access as far as we are concerned. */
5139 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
5140 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
5141 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5145 case N_Extension_Aggregate
:
5149 /* ??? It is wrong to evaluate the type now, but there doesn't
5150 seem to be any other practical way of doing it. */
5152 gcc_assert (!Expansion_Delayed (gnat_node
));
5154 gnu_aggr_type
= gnu_result_type
5155 = get_unpadded_type (Etype (gnat_node
));
5157 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
5158 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
5160 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type
)));
5161 else if (TREE_CODE (gnu_result_type
) == VECTOR_TYPE
)
5162 gnu_aggr_type
= TYPE_REPRESENTATIVE_ARRAY (gnu_result_type
);
5164 if (Null_Record_Present (gnat_node
))
5165 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL
);
5167 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
5168 || TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
5170 = assoc_to_constructor (Etype (gnat_node
),
5171 First (Component_Associations (gnat_node
)),
5173 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
5174 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
5176 Component_Type (Etype (gnat_node
)));
5177 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
5180 (COMPLEX_EXPR
, gnu_aggr_type
,
5181 gnat_to_gnu (Expression (First
5182 (Component_Associations (gnat_node
)))),
5183 gnat_to_gnu (Expression
5185 (First (Component_Associations (gnat_node
))))));
5189 gnu_result
= convert (gnu_result_type
, gnu_result
);
5194 if (TARGET_VTABLE_USES_DESCRIPTORS
5195 && Ekind (Etype (gnat_node
)) == E_Access_Subprogram_Type
5196 && Is_Dispatch_Table_Entity (Etype (gnat_node
)))
5197 gnu_result
= null_fdesc_node
;
5199 gnu_result
= null_pointer_node
;
5200 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5203 case N_Type_Conversion
:
5204 case N_Qualified_Expression
:
5205 /* Get the operand expression. */
5206 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
5207 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5210 = convert_with_check (Etype (gnat_node
), gnu_result
,
5211 Do_Overflow_Check (gnat_node
),
5212 Do_Range_Check (Expression (gnat_node
)),
5213 kind
== N_Type_Conversion
5214 && Float_Truncate (gnat_node
), gnat_node
);
5217 case N_Unchecked_Type_Conversion
:
5218 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
5220 /* Skip further processing if the conversion is deemed a no-op. */
5221 if (unchecked_conversion_nop (gnat_node
))
5223 gnu_result_type
= TREE_TYPE (gnu_result
);
5227 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5229 /* If the result is a pointer type, see if we are improperly
5230 converting to a stricter alignment. */
5231 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
5232 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
5234 unsigned int align
= known_alignment (gnu_result
);
5235 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
5236 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
5238 if (align
!= 0 && align
< oalign
&& !TYPE_ALIGN_OK (gnu_obj_type
))
5239 post_error_ne_tree_2
5240 ("?source alignment (^) '< alignment of & (^)",
5241 gnat_node
, Designated_Type (Etype (gnat_node
)),
5242 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
5245 /* If we are converting a descriptor to a function pointer, first
5246 build the pointer. */
5247 if (TARGET_VTABLE_USES_DESCRIPTORS
5248 && TREE_TYPE (gnu_result
) == fdesc_type_node
5249 && POINTER_TYPE_P (gnu_result_type
))
5250 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
5252 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
,
5253 No_Truncation (gnat_node
));
5259 tree gnu_obj
= gnat_to_gnu (Left_Opnd (gnat_node
));
5260 Node_Id gnat_range
= Right_Opnd (gnat_node
);
5261 tree gnu_low
, gnu_high
;
5263 /* GNAT_RANGE is either an N_Range node or an identifier denoting a
5265 if (Nkind (gnat_range
) == N_Range
)
5267 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
5268 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
5270 else if (Nkind (gnat_range
) == N_Identifier
5271 || Nkind (gnat_range
) == N_Expanded_Name
)
5273 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
5275 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
5276 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
5281 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5283 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
5284 ensure that GNU_OBJ is evaluated only once and perform a full range
5286 if (operand_equal_p (gnu_low
, gnu_high
, 0))
5288 = build_binary_op (EQ_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
5292 gnu_obj
= gnat_protect_expr (gnu_obj
);
5293 t1
= build_binary_op (GE_EXPR
, gnu_result_type
, gnu_obj
, gnu_low
);
5295 set_expr_location_from_node (t1
, gnat_node
);
5296 t2
= build_binary_op (LE_EXPR
, gnu_result_type
, gnu_obj
, gnu_high
);
5298 set_expr_location_from_node (t2
, gnat_node
);
5300 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
, t1
, t2
);
5303 if (kind
== N_Not_In
)
5305 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result
), gnu_result
);
5310 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
5311 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
5312 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5313 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
5315 : (Rounded_Result (gnat_node
)
5316 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
5317 gnu_result_type
, gnu_lhs
, gnu_rhs
);
5320 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
5321 /* These can either be operations on booleans or on modular types.
5322 Fall through for boolean types since that's the way GNU_CODES is
5324 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
5325 Modular_Integer_Kind
))
5328 = (kind
== N_Op_Or
? BIT_IOR_EXPR
5329 : kind
== N_Op_And
? BIT_AND_EXPR
5332 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
5333 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
5334 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5335 gnu_result
= build_binary_op (code
, gnu_result_type
,
5340 /* ... fall through ... */
5342 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
5343 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
5344 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
5345 case N_Op_Mod
: case N_Op_Rem
:
5346 case N_Op_Rotate_Left
:
5347 case N_Op_Rotate_Right
:
5348 case N_Op_Shift_Left
:
5349 case N_Op_Shift_Right
:
5350 case N_Op_Shift_Right_Arithmetic
:
5351 case N_And_Then
: case N_Or_Else
:
5353 enum tree_code code
= gnu_codes
[kind
];
5354 bool ignore_lhs_overflow
= false;
5355 location_t saved_location
= input_location
;
5358 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
5359 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
5360 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5362 /* Pending generic support for efficient vector logical operations in
5363 GCC, convert vectors to their representative array type view and
5365 gnu_lhs
= maybe_vector_array (gnu_lhs
);
5366 gnu_rhs
= maybe_vector_array (gnu_rhs
);
5368 /* If this is a comparison operator, convert any references to
5369 an unconstrained array value into a reference to the
5371 if (TREE_CODE_CLASS (code
) == tcc_comparison
)
5373 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
5374 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
5377 /* If the result type is a private type, its full view may be a
5378 numeric subtype. The representation we need is that of its base
5379 type, given that it is the result of an arithmetic operation. */
5380 else if (Is_Private_Type (Etype (gnat_node
)))
5381 gnu_type
= gnu_result_type
5382 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node
))));
5384 /* If this is a shift whose count is not guaranteed to be correct,
5385 we need to adjust the shift count. */
5386 if (IN (kind
, N_Op_Shift
) && !Shift_Count_OK (gnat_node
))
5388 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
5390 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
5392 if (kind
== N_Op_Rotate_Left
|| kind
== N_Op_Rotate_Right
)
5393 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
5394 gnu_rhs
, gnu_max_shift
);
5395 else if (kind
== N_Op_Shift_Right_Arithmetic
)
5398 (MIN_EXPR
, gnu_count_type
,
5399 build_binary_op (MINUS_EXPR
,
5402 convert (gnu_count_type
,
5407 /* For right shifts, the type says what kind of shift to do,
5408 so we may need to choose a different type. In this case,
5409 we have to ignore integer overflow lest it propagates all
5410 the way down and causes a CE to be explicitly raised. */
5411 if (kind
== N_Op_Shift_Right
&& !TYPE_UNSIGNED (gnu_type
))
5413 gnu_type
= gnat_unsigned_type (gnu_type
);
5414 ignore_lhs_overflow
= true;
5416 else if (kind
== N_Op_Shift_Right_Arithmetic
5417 && TYPE_UNSIGNED (gnu_type
))
5419 gnu_type
= gnat_signed_type (gnu_type
);
5420 ignore_lhs_overflow
= true;
5423 if (gnu_type
!= gnu_result_type
)
5425 tree gnu_old_lhs
= gnu_lhs
;
5426 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
5427 if (TREE_CODE (gnu_lhs
) == INTEGER_CST
&& ignore_lhs_overflow
)
5428 TREE_OVERFLOW (gnu_lhs
) = TREE_OVERFLOW (gnu_old_lhs
);
5429 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
5432 /* Instead of expanding overflow checks for addition, subtraction
5433 and multiplication itself, the front end will leave this to
5434 the back end when Backend_Overflow_Checks_On_Target is set.
5435 As the GCC back end itself does not know yet how to properly
5436 do overflow checking, do it here. The goal is to push
5437 the expansions further into the back end over time. */
5438 if (Do_Overflow_Check (gnat_node
) && Backend_Overflow_Checks_On_Target
5439 && (kind
== N_Op_Add
5440 || kind
== N_Op_Subtract
5441 || kind
== N_Op_Multiply
)
5442 && !TYPE_UNSIGNED (gnu_type
)
5443 && !FLOAT_TYPE_P (gnu_type
))
5444 gnu_result
= build_binary_op_trapv (code
, gnu_type
,
5445 gnu_lhs
, gnu_rhs
, gnat_node
);
5448 /* Some operations, e.g. comparisons of arrays, generate complex
5449 trees that need to be annotated while they are being built. */
5450 input_location
= saved_location
;
5451 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
5454 /* If this is a logical shift with the shift count not verified,
5455 we must return zero if it is too large. We cannot compensate
5456 above in this case. */
5457 if ((kind
== N_Op_Shift_Left
|| kind
== N_Op_Shift_Right
)
5458 && !Shift_Count_OK (gnat_node
))
5462 build_binary_op (GE_EXPR
, boolean_type_node
,
5464 convert (TREE_TYPE (gnu_rhs
),
5465 TYPE_SIZE (gnu_type
))),
5466 convert (gnu_type
, integer_zero_node
),
5471 case N_Conditional_Expression
:
5473 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
5474 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
5476 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
5478 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5480 = build_cond_expr (gnu_result_type
, gnu_cond
, gnu_true
, gnu_false
);
5485 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
5486 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5490 /* This case can apply to a boolean or a modular type.
5491 Fall through for a boolean operand since GNU_CODES is set
5492 up to handle this. */
5493 if (Is_Modular_Integer_Type (Etype (gnat_node
))
5494 || (Ekind (Etype (gnat_node
)) == E_Private_Type
5495 && Is_Modular_Integer_Type (Full_View (Etype (gnat_node
)))))
5497 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
5498 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5499 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
5504 /* ... fall through ... */
5506 case N_Op_Minus
: case N_Op_Abs
:
5507 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
5509 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
5510 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5512 gnu_result_type
= get_unpadded_type (Base_Type
5513 (Full_View (Etype (gnat_node
))));
5515 if (Do_Overflow_Check (gnat_node
)
5516 && !TYPE_UNSIGNED (gnu_result_type
)
5517 && !FLOAT_TYPE_P (gnu_result_type
))
5519 = build_unary_op_trapv (gnu_codes
[kind
],
5520 gnu_result_type
, gnu_expr
, gnat_node
);
5522 gnu_result
= build_unary_op (gnu_codes
[kind
],
5523 gnu_result_type
, gnu_expr
);
5530 bool ignore_init_type
= false;
5532 gnat_temp
= Expression (gnat_node
);
5534 /* The Expression operand can either be an N_Identifier or
5535 Expanded_Name, which must represent a type, or a
5536 N_Qualified_Expression, which contains both the object type and an
5537 initial value for the object. */
5538 if (Nkind (gnat_temp
) == N_Identifier
5539 || Nkind (gnat_temp
) == N_Expanded_Name
)
5540 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
5541 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
5543 Entity_Id gnat_desig_type
5544 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
5546 ignore_init_type
= Has_Constrained_Partial_View (gnat_desig_type
);
5547 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
5549 gnu_init
= maybe_unconstrained_array (gnu_init
);
5550 if (Do_Range_Check (Expression (gnat_temp
)))
5552 = emit_range_check (gnu_init
, gnat_desig_type
, gnat_temp
);
5554 if (Is_Elementary_Type (gnat_desig_type
)
5555 || Is_Constrained (gnat_desig_type
))
5557 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
5558 gnu_init
= convert (gnu_type
, gnu_init
);
5562 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
5563 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5564 gnu_type
= TREE_TYPE (gnu_init
);
5566 gnu_init
= convert (gnu_type
, gnu_init
);
5572 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
5573 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
5574 Procedure_To_Call (gnat_node
),
5575 Storage_Pool (gnat_node
), gnat_node
,
5580 /**************************/
5581 /* Chapter 5: Statements */
5582 /**************************/
5585 gnu_result
= build1 (LABEL_EXPR
, void_type_node
,
5586 gnat_to_gnu (Identifier (gnat_node
)));
5589 case N_Null_Statement
:
5590 /* When not optimizing, turn null statements from source into gotos to
5591 the next statement that the middle-end knows how to preserve. */
5592 if (!optimize
&& Comes_From_Source (gnat_node
))
5594 tree stmt
, label
= create_label_decl (NULL_TREE
);
5595 start_stmt_group ();
5596 stmt
= build1 (GOTO_EXPR
, void_type_node
, label
);
5597 set_expr_location_from_node (stmt
, gnat_node
);
5599 stmt
= build1 (LABEL_EXPR
, void_type_node
, label
);
5600 set_expr_location_from_node (stmt
, gnat_node
);
5602 gnu_result
= end_stmt_group ();
5605 gnu_result
= alloc_stmt_list ();
5608 case N_Assignment_Statement
:
5609 /* Get the LHS and RHS of the statement and convert any reference to an
5610 unconstrained array into a reference to the underlying array. */
5611 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
5613 /* If the type has a size that overflows, convert this into raise of
5614 Storage_Error: execution shouldn't have gotten here anyway. */
5615 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
5616 && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))))
5617 gnu_result
= build_call_raise (SE_Object_Too_Large
, gnat_node
,
5618 N_Raise_Storage_Error
);
5619 else if (Nkind (Expression (gnat_node
)) == N_Function_Call
)
5621 = call_to_gnu (Expression (gnat_node
), &gnu_result_type
, gnu_lhs
);
5625 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
5627 /* If range check is needed, emit code to generate it. */
5628 if (Do_Range_Check (Expression (gnat_node
)))
5629 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)),
5633 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
5635 /* If the type being assigned is an array type and the two sides are
5636 not completely disjoint, play safe and use memmove. But don't do
5637 it for a bit-packed array as it might not be byte-aligned. */
5638 if (TREE_CODE (gnu_result
) == MODIFY_EXPR
5639 && Is_Array_Type (Etype (Name (gnat_node
)))
5640 && !Is_Bit_Packed_Array (Etype (Name (gnat_node
)))
5641 && !(Forwards_OK (gnat_node
) && Backwards_OK (gnat_node
)))
5643 tree to
, from
, size
, to_ptr
, from_ptr
, t
;
5645 to
= TREE_OPERAND (gnu_result
, 0);
5646 from
= TREE_OPERAND (gnu_result
, 1);
5648 size
= TYPE_SIZE_UNIT (TREE_TYPE (from
));
5649 size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, from
);
5651 to_ptr
= build_fold_addr_expr (to
);
5652 from_ptr
= build_fold_addr_expr (from
);
5654 t
= builtin_decl_implicit (BUILT_IN_MEMMOVE
);
5655 gnu_result
= build_call_expr (t
, 3, to_ptr
, from_ptr
, size
);
5660 case N_If_Statement
:
5662 tree
*gnu_else_ptr
; /* Point to put next "else if" or "else". */
5664 /* Make the outer COND_EXPR. Avoid non-determinism. */
5665 gnu_result
= build3 (COND_EXPR
, void_type_node
,
5666 gnat_to_gnu (Condition (gnat_node
)),
5667 NULL_TREE
, NULL_TREE
);
5668 COND_EXPR_THEN (gnu_result
)
5669 = build_stmt_group (Then_Statements (gnat_node
), false);
5670 TREE_SIDE_EFFECTS (gnu_result
) = 1;
5671 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_result
);
5673 /* Now make a COND_EXPR for each of the "else if" parts. Put each
5674 into the previous "else" part and point to where to put any
5675 outer "else". Also avoid non-determinism. */
5676 if (Present (Elsif_Parts (gnat_node
)))
5677 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
5678 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
5680 gnu_expr
= build3 (COND_EXPR
, void_type_node
,
5681 gnat_to_gnu (Condition (gnat_temp
)),
5682 NULL_TREE
, NULL_TREE
);
5683 COND_EXPR_THEN (gnu_expr
)
5684 = build_stmt_group (Then_Statements (gnat_temp
), false);
5685 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
5686 set_expr_location_from_node (gnu_expr
, gnat_temp
);
5687 *gnu_else_ptr
= gnu_expr
;
5688 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
5691 *gnu_else_ptr
= build_stmt_group (Else_Statements (gnat_node
), false);
5695 case N_Case_Statement
:
5696 gnu_result
= Case_Statement_to_gnu (gnat_node
);
5699 case N_Loop_Statement
:
5700 gnu_result
= Loop_Statement_to_gnu (gnat_node
);
5703 case N_Block_Statement
:
5704 start_stmt_group ();
5706 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
5707 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
5709 gnu_result
= end_stmt_group ();
5711 if (Present (Identifier (gnat_node
)))
5712 mark_out_of_scope (Entity (Identifier (gnat_node
)));
5715 case N_Exit_Statement
:
5717 = build2 (EXIT_STMT
, void_type_node
,
5718 (Present (Condition (gnat_node
))
5719 ? gnat_to_gnu (Condition (gnat_node
)) : NULL_TREE
),
5720 (Present (Name (gnat_node
))
5721 ? get_gnu_tree (Entity (Name (gnat_node
)))
5722 : VEC_last (loop_info
, gnu_loop_stack
)->label
));
5725 case N_Return_Statement
:
5727 tree gnu_ret_obj
, gnu_ret_val
;
5729 /* If the subprogram is a function, we must return the expression. */
5730 if (Present (Expression (gnat_node
)))
5732 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
5734 /* If this function has copy-in/copy-out parameters, get the real
5735 object for the return. See Subprogram_to_gnu. */
5736 if (TYPE_CI_CO_LIST (gnu_subprog_type
))
5737 gnu_ret_obj
= VEC_last (tree
, gnu_return_var_stack
);
5739 gnu_ret_obj
= DECL_RESULT (current_function_decl
);
5741 /* Get the GCC tree for the expression to be returned. */
5742 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
5744 /* Do not remove the padding from GNU_RET_VAL if the inner type is
5745 self-referential since we want to allocate the fixed size. */
5746 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
5747 && TYPE_IS_PADDING_P
5748 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0)))
5749 && CONTAINS_PLACEHOLDER_P
5750 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
))))
5751 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
5753 /* If the function returns by direct reference, return a pointer
5754 to the return value. */
5755 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type
)
5756 || By_Ref (gnat_node
))
5757 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
5759 /* Otherwise, if it returns an unconstrained array, we have to
5760 allocate a new version of the result and return it. */
5761 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type
))
5763 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
5764 gnu_ret_val
= build_allocator (TREE_TYPE (gnu_ret_val
),
5766 TREE_TYPE (gnu_ret_obj
),
5767 Procedure_To_Call (gnat_node
),
5768 Storage_Pool (gnat_node
),
5772 /* If the function returns by invisible reference, dereference
5773 the pointer it is passed using the type of the return value
5774 and build the copy operation manually. This ensures that we
5775 don't copy too much data, for example if the return type is
5776 unconstrained with a maximum size. */
5777 if (TREE_ADDRESSABLE (gnu_subprog_type
))
5780 = build_unary_op (INDIRECT_REF
, TREE_TYPE (gnu_ret_val
),
5782 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5783 gnu_ret_deref
, gnu_ret_val
);
5784 add_stmt_with_node (gnu_result
, gnat_node
);
5785 gnu_ret_val
= NULL_TREE
;
5790 gnu_ret_obj
= NULL_TREE
;
5791 gnu_ret_val
= NULL_TREE
;
5794 /* If we have a return label defined, convert this into a branch to
5795 that label. The return proper will be handled elsewhere. */
5796 if (VEC_last (tree
, gnu_return_label_stack
))
5799 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_ret_obj
,
5802 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
5803 VEC_last (tree
, gnu_return_label_stack
));
5805 /* When not optimizing, make sure the return is preserved. */
5806 if (!optimize
&& Comes_From_Source (gnat_node
))
5807 DECL_ARTIFICIAL (VEC_last (tree
, gnu_return_label_stack
)) = 0;
5810 /* Otherwise, build a regular return. */
5812 gnu_result
= build_return_expr (gnu_ret_obj
, gnu_ret_val
);
5816 case N_Goto_Statement
:
5817 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
5818 gnat_to_gnu (Name (gnat_node
)));
5821 /***************************/
5822 /* Chapter 6: Subprograms */
5823 /***************************/
5825 case N_Subprogram_Declaration
:
5826 /* Unless there is a freeze node, declare the subprogram. We consider
5827 this a "definition" even though we're not generating code for
5828 the subprogram because we will be making the corresponding GCC
5831 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
5832 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
5834 gnu_result
= alloc_stmt_list ();
5837 case N_Abstract_Subprogram_Declaration
:
5838 /* This subprogram doesn't exist for code generation purposes, but we
5839 have to elaborate the types of any parameters and result, unless
5840 they are imported types (nothing to generate in this case).
5842 The parameter list may contain types with freeze nodes, e.g. not null
5843 subtypes, so the subprogram itself may carry a freeze node, in which
5844 case its elaboration must be deferred. */
5846 /* Process the parameter types first. */
5847 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
5849 = First_Formal_With_Extras
5850 (Defining_Entity (Specification (gnat_node
)));
5851 Present (gnat_temp
);
5852 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
5853 if (Is_Itype (Etype (gnat_temp
))
5854 && !From_With_Type (Etype (gnat_temp
)))
5855 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
5857 /* Then the result type, set to Standard_Void_Type for procedures. */
5859 Entity_Id gnat_temp_type
5860 = Etype (Defining_Entity (Specification (gnat_node
)));
5862 if (Is_Itype (gnat_temp_type
) && !From_With_Type (gnat_temp_type
))
5863 gnat_to_gnu_entity (Etype (gnat_temp_type
), NULL_TREE
, 0);
5866 gnu_result
= alloc_stmt_list ();
5869 case N_Defining_Program_Unit_Name
:
5870 /* For a child unit identifier go up a level to get the specification.
5871 We get this when we try to find the spec of a child unit package
5872 that is the compilation unit being compiled. */
5873 gnu_result
= gnat_to_gnu (Parent (gnat_node
));
5876 case N_Subprogram_Body
:
5877 Subprogram_Body_to_gnu (gnat_node
);
5878 gnu_result
= alloc_stmt_list ();
5881 case N_Function_Call
:
5882 case N_Procedure_Call_Statement
:
5883 gnu_result
= call_to_gnu (gnat_node
, &gnu_result_type
, NULL_TREE
);
5886 /************************/
5887 /* Chapter 7: Packages */
5888 /************************/
5890 case N_Package_Declaration
:
5891 gnu_result
= gnat_to_gnu (Specification (gnat_node
));
5894 case N_Package_Specification
:
5896 start_stmt_group ();
5897 process_decls (Visible_Declarations (gnat_node
),
5898 Private_Declarations (gnat_node
), Empty
, true, true);
5899 gnu_result
= end_stmt_group ();
5902 case N_Package_Body
:
5904 /* If this is the body of a generic package - do nothing. */
5905 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
5907 gnu_result
= alloc_stmt_list ();
5911 start_stmt_group ();
5912 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
5914 if (Present (Handled_Statement_Sequence (gnat_node
)))
5915 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
5917 gnu_result
= end_stmt_group ();
5920 /********************************/
5921 /* Chapter 8: Visibility Rules */
5922 /********************************/
5924 case N_Use_Package_Clause
:
5925 case N_Use_Type_Clause
:
5926 /* Nothing to do here - but these may appear in list of declarations. */
5927 gnu_result
= alloc_stmt_list ();
5930 /*********************/
5931 /* Chapter 9: Tasks */
5932 /*********************/
5934 case N_Protected_Type_Declaration
:
5935 gnu_result
= alloc_stmt_list ();
5938 case N_Single_Task_Declaration
:
5939 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
5940 gnu_result
= alloc_stmt_list ();
5943 /*********************************************************/
5944 /* Chapter 10: Program Structure and Compilation Issues */
5945 /*********************************************************/
5947 case N_Compilation_Unit
:
5948 /* This is not called for the main unit on which gigi is invoked. */
5949 Compilation_Unit_to_gnu (gnat_node
);
5950 gnu_result
= alloc_stmt_list ();
5953 case N_Subprogram_Body_Stub
:
5954 case N_Package_Body_Stub
:
5955 case N_Protected_Body_Stub
:
5956 case N_Task_Body_Stub
:
5957 /* Simply process whatever unit is being inserted. */
5958 gnu_result
= gnat_to_gnu (Unit (Library_Unit (gnat_node
)));
5962 gnu_result
= gnat_to_gnu (Proper_Body (gnat_node
));
5965 /***************************/
5966 /* Chapter 11: Exceptions */
5967 /***************************/
5969 case N_Handled_Sequence_Of_Statements
:
5970 /* If there is an At_End procedure attached to this node, and the EH
5971 mechanism is SJLJ, we must have at least a corresponding At_End
5972 handler, unless the No_Exception_Handlers restriction is set. */
5973 gcc_assert (type_annotate_only
5974 || Exception_Mechanism
!= Setjmp_Longjmp
5975 || No (At_End_Proc (gnat_node
))
5976 || Present (Exception_Handlers (gnat_node
))
5977 || No_Exception_Handlers_Set ());
5979 gnu_result
= Handled_Sequence_Of_Statements_to_gnu (gnat_node
);
5982 case N_Exception_Handler
:
5983 if (Exception_Mechanism
== Setjmp_Longjmp
)
5984 gnu_result
= Exception_Handler_to_gnu_sjlj (gnat_node
);
5985 else if (Exception_Mechanism
== Back_End_Exceptions
)
5986 gnu_result
= Exception_Handler_to_gnu_zcx (gnat_node
);
5991 case N_Raise_Statement
:
5992 /* Only for reraise in back-end exceptions mode. */
5993 gcc_assert (No (Name (gnat_node
))
5994 && Exception_Mechanism
== Back_End_Exceptions
);
5996 start_stmt_group ();
5999 /* Clear the current exception pointer so that the occurrence won't be
6001 gnu_expr
= create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE
,
6002 ptr_type_node
, gnu_incoming_exc_ptr
,
6003 false, false, false, false, NULL
, gnat_node
);
6005 add_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_incoming_exc_ptr
,
6006 convert (ptr_type_node
, integer_zero_node
)));
6007 add_stmt (build_call_n_expr (reraise_zcx_decl
, 1, gnu_expr
));
6009 gnu_result
= end_stmt_group ();
6012 case N_Push_Constraint_Error_Label
:
6013 push_exception_label_stack (&gnu_constraint_error_label_stack
,
6014 Exception_Label (gnat_node
));
6017 case N_Push_Storage_Error_Label
:
6018 push_exception_label_stack (&gnu_storage_error_label_stack
,
6019 Exception_Label (gnat_node
));
6022 case N_Push_Program_Error_Label
:
6023 push_exception_label_stack (&gnu_program_error_label_stack
,
6024 Exception_Label (gnat_node
));
6027 case N_Pop_Constraint_Error_Label
:
6028 VEC_pop (tree
, gnu_constraint_error_label_stack
);
6031 case N_Pop_Storage_Error_Label
:
6032 VEC_pop (tree
, gnu_storage_error_label_stack
);
6035 case N_Pop_Program_Error_Label
:
6036 VEC_pop (tree
, gnu_program_error_label_stack
);
6039 /******************************/
6040 /* Chapter 12: Generic Units */
6041 /******************************/
6043 case N_Generic_Function_Renaming_Declaration
:
6044 case N_Generic_Package_Renaming_Declaration
:
6045 case N_Generic_Procedure_Renaming_Declaration
:
6046 case N_Generic_Package_Declaration
:
6047 case N_Generic_Subprogram_Declaration
:
6048 case N_Package_Instantiation
:
6049 case N_Procedure_Instantiation
:
6050 case N_Function_Instantiation
:
6051 /* These nodes can appear on a declaration list but there is nothing to
6052 to be done with them. */
6053 gnu_result
= alloc_stmt_list ();
6056 /**************************************************/
6057 /* Chapter 13: Representation Clauses and */
6058 /* Implementation-Dependent Features */
6059 /**************************************************/
6061 case N_Attribute_Definition_Clause
:
6062 gnu_result
= alloc_stmt_list ();
6064 /* The only one we need to deal with is 'Address since, for the others,
6065 the front-end puts the information elsewhere. */
6066 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
)
6069 /* And we only deal with 'Address if the object has a Freeze node. */
6070 gnat_temp
= Entity (Name (gnat_node
));
6071 if (No (Freeze_Node (gnat_temp
)))
6074 /* Get the value to use as the address and save it as the equivalent
6075 for the object. When it is frozen, gnat_to_gnu_entity will do the
6077 save_gnu_tree (gnat_temp
, gnat_to_gnu (Expression (gnat_node
)), true);
6080 case N_Enumeration_Representation_Clause
:
6081 case N_Record_Representation_Clause
:
6083 /* We do nothing with these. SEM puts the information elsewhere. */
6084 gnu_result
= alloc_stmt_list ();
6087 case N_Code_Statement
:
6088 if (!type_annotate_only
)
6090 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
6091 tree gnu_inputs
= NULL_TREE
, gnu_outputs
= NULL_TREE
;
6092 tree gnu_clobbers
= NULL_TREE
, tail
;
6093 bool allows_mem
, allows_reg
, fake
;
6094 int ninputs
, noutputs
, i
;
6095 const char **oconstraints
;
6096 const char *constraint
;
6099 /* First retrieve the 3 operand lists built by the front-end. */
6100 Setup_Asm_Outputs (gnat_node
);
6101 while (Present (gnat_temp
= Asm_Output_Variable ()))
6103 tree gnu_value
= gnat_to_gnu (gnat_temp
);
6104 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
6105 (Asm_Output_Constraint ()));
6107 gnu_outputs
= tree_cons (gnu_constr
, gnu_value
, gnu_outputs
);
6111 Setup_Asm_Inputs (gnat_node
);
6112 while (Present (gnat_temp
= Asm_Input_Value ()))
6114 tree gnu_value
= gnat_to_gnu (gnat_temp
);
6115 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
6116 (Asm_Input_Constraint ()));
6118 gnu_inputs
= tree_cons (gnu_constr
, gnu_value
, gnu_inputs
);
6122 Clobber_Setup (gnat_node
);
6123 while ((clobber
= Clobber_Get_Next ()))
6125 = tree_cons (NULL_TREE
,
6126 build_string (strlen (clobber
) + 1, clobber
),
6129 /* Then perform some standard checking and processing on the
6130 operands. In particular, mark them addressable if needed. */
6131 gnu_outputs
= nreverse (gnu_outputs
);
6132 noutputs
= list_length (gnu_outputs
);
6133 gnu_inputs
= nreverse (gnu_inputs
);
6134 ninputs
= list_length (gnu_inputs
);
6135 oconstraints
= XALLOCAVEC (const char *, noutputs
);
6137 for (i
= 0, tail
= gnu_outputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
6139 tree output
= TREE_VALUE (tail
);
6141 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
6142 oconstraints
[i
] = constraint
;
6144 if (parse_output_constraint (&constraint
, i
, ninputs
, noutputs
,
6145 &allows_mem
, &allows_reg
, &fake
))
6147 /* If the operand is going to end up in memory,
6148 mark it addressable. Note that we don't test
6149 allows_mem like in the input case below; this
6150 is modelled on the C front-end. */
6153 output
= remove_conversions (output
, false);
6154 if (TREE_CODE (output
) == CONST_DECL
6155 && DECL_CONST_CORRESPONDING_VAR (output
))
6156 output
= DECL_CONST_CORRESPONDING_VAR (output
);
6157 if (!gnat_mark_addressable (output
))
6158 output
= error_mark_node
;
6162 output
= error_mark_node
;
6164 TREE_VALUE (tail
) = output
;
6167 for (i
= 0, tail
= gnu_inputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
6169 tree input
= TREE_VALUE (tail
);
6171 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
6173 if (parse_input_constraint (&constraint
, i
, ninputs
, noutputs
,
6175 &allows_mem
, &allows_reg
))
6177 /* If the operand is going to end up in memory,
6178 mark it addressable. */
6179 if (!allows_reg
&& allows_mem
)
6181 input
= remove_conversions (input
, false);
6182 if (TREE_CODE (input
) == CONST_DECL
6183 && DECL_CONST_CORRESPONDING_VAR (input
))
6184 input
= DECL_CONST_CORRESPONDING_VAR (input
);
6185 if (!gnat_mark_addressable (input
))
6186 input
= error_mark_node
;
6190 input
= error_mark_node
;
6192 TREE_VALUE (tail
) = input
;
6195 gnu_result
= build5 (ASM_EXPR
, void_type_node
,
6196 gnu_template
, gnu_outputs
,
6197 gnu_inputs
, gnu_clobbers
, NULL_TREE
);
6198 ASM_VOLATILE_P (gnu_result
) = Is_Asm_Volatile (gnat_node
);
6201 gnu_result
= alloc_stmt_list ();
6209 case N_Expression_With_Actions
:
6210 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6211 /* This construct doesn't define a scope so we don't wrap the statement
6212 list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it
6214 gnu_result
= build_stmt_group (Actions (gnat_node
), false);
6215 gnu_result
= build1 (SAVE_EXPR
, void_type_node
, gnu_result
);
6216 TREE_SIDE_EFFECTS (gnu_result
) = 1;
6217 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
6219 = build_compound_expr (TREE_TYPE (gnu_expr
), gnu_result
, gnu_expr
);
6222 case N_Freeze_Entity
:
6223 start_stmt_group ();
6224 process_freeze_entity (gnat_node
);
6225 process_decls (Actions (gnat_node
), Empty
, Empty
, true, true);
6226 gnu_result
= end_stmt_group ();
6229 case N_Itype_Reference
:
6230 if (!present_gnu_tree (Itype (gnat_node
)))
6231 process_type (Itype (gnat_node
));
6233 gnu_result
= alloc_stmt_list ();
6236 case N_Free_Statement
:
6237 if (!type_annotate_only
)
6239 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
6240 tree gnu_ptr_type
= TREE_TYPE (gnu_ptr
);
6242 tree gnu_actual_obj_type
= 0;
6245 /* If this is a thin pointer, we must dereference it to create
6246 a fat pointer, then go back below to a thin pointer. The
6247 reason for this is that we need a fat pointer someplace in
6248 order to properly compute the size. */
6249 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
6250 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
6251 build_unary_op (INDIRECT_REF
, NULL_TREE
,
6254 /* If this is an unconstrained array, we know the object must
6255 have been allocated with the template in front of the object.
6256 So pass the template address, but get the total size. Do this
6257 by converting to a thin pointer. */
6258 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
6260 = convert (build_pointer_type
6261 (TYPE_OBJECT_RECORD_TYPE
6262 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
6265 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
6267 if (Present (Actual_Designated_Subtype (gnat_node
)))
6270 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node
));
6272 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type
))
6274 = build_unc_object_type_from_ptr (gnu_ptr_type
,
6275 gnu_actual_obj_type
,
6276 get_identifier ("DEALLOC"),
6280 gnu_actual_obj_type
= gnu_obj_type
;
6282 gnu_obj_size
= TYPE_SIZE_UNIT (gnu_actual_obj_type
);
6284 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
6285 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
6287 tree gnu_char_ptr_type
6288 = build_pointer_type (unsigned_char_type_node
);
6289 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
6290 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
6291 gnu_ptr
= build_binary_op (POINTER_PLUS_EXPR
, gnu_char_ptr_type
,
6296 = build_call_alloc_dealloc (gnu_ptr
, gnu_obj_size
, gnu_obj_type
,
6297 Procedure_To_Call (gnat_node
),
6298 Storage_Pool (gnat_node
),
6303 case N_Raise_Constraint_Error
:
6304 case N_Raise_Program_Error
:
6305 case N_Raise_Storage_Error
:
6307 const int reason
= UI_To_Int (Reason (gnat_node
));
6308 const Node_Id gnat_cond
= Condition (gnat_node
);
6309 const bool with_extra_info
= Exception_Extra_Info
6310 && !No_Exception_Handlers_Set ()
6311 && !get_exception_label (kind
);
6312 tree gnu_cond
= NULL_TREE
;
6314 if (type_annotate_only
)
6316 gnu_result
= alloc_stmt_list ();
6320 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
6324 case CE_Access_Check_Failed
:
6325 if (with_extra_info
)
6326 gnu_result
= build_call_raise_column (reason
, gnat_node
);
6329 case CE_Index_Check_Failed
:
6330 case CE_Range_Check_Failed
:
6331 case CE_Invalid_Data
:
6332 if (Present (gnat_cond
)
6333 && Nkind (gnat_cond
) == N_Op_Not
6334 && Nkind (Right_Opnd (gnat_cond
)) == N_In
6335 && Nkind (Right_Opnd (Right_Opnd (gnat_cond
))) == N_Range
)
6337 Node_Id gnat_index
= Left_Opnd (Right_Opnd (gnat_cond
));
6338 Node_Id gnat_type
= Etype (gnat_index
);
6339 Node_Id gnat_range
= Right_Opnd (Right_Opnd (gnat_cond
));
6340 tree gnu_index
= gnat_to_gnu (gnat_index
);
6341 tree gnu_low_bound
= gnat_to_gnu (Low_Bound (gnat_range
));
6342 tree gnu_high_bound
= gnat_to_gnu (High_Bound (gnat_range
));
6343 struct range_check_info_d
*rci
;
6346 && Known_Esize (gnat_type
)
6347 && UI_To_Int (Esize (gnat_type
)) <= 32)
6349 = build_call_raise_range (reason
, gnat_node
, gnu_index
,
6350 gnu_low_bound
, gnu_high_bound
);
6352 /* If loop unswitching is enabled, we try to compute invariant
6353 conditions for checks applied to iteration variables, i.e.
6354 conditions that are both independent of the variable and
6355 necessary in order for the check to fail in the course of
6356 some iteration, and prepend them to the original condition
6357 of the checks. This will make it possible later for the
6358 loop unswitching pass to replace the loop with two loops,
6359 one of which has the checks eliminated and the other has
6360 the original checks reinstated, and a run time selection.
6361 The former loop will be suitable for vectorization. */
6362 if (flag_unswitch_loops
6363 && (gnu_low_bound
= gnat_invariant_expr (gnu_low_bound
))
6364 && (gnu_high_bound
= gnat_invariant_expr (gnu_high_bound
))
6365 && (rci
= push_range_check_info (gnu_index
)))
6367 rci
->low_bound
= gnu_low_bound
;
6368 rci
->high_bound
= gnu_high_bound
;
6369 rci
->type
= gnat_to_gnu_type (gnat_type
);
6370 rci
->invariant_cond
= build1 (SAVE_EXPR
, boolean_type_node
,
6372 gnu_cond
= build_binary_op (TRUTH_ANDIF_EXPR
,
6374 rci
->invariant_cond
,
6375 gnat_to_gnu (gnat_cond
));
6384 if (gnu_result
== error_mark_node
)
6385 gnu_result
= build_call_raise (reason
, gnat_node
, kind
);
6387 set_expr_location_from_node (gnu_result
, gnat_node
);
6389 /* If the type is VOID, this is a statement, so we need to generate
6390 the code for the call. Handle a condition, if there is one. */
6391 if (VOID_TYPE_P (gnu_result_type
))
6393 if (Present (gnat_cond
))
6396 gnu_cond
= gnat_to_gnu (gnat_cond
);
6398 = build3 (COND_EXPR
, void_type_node
, gnu_cond
, gnu_result
,
6399 alloc_stmt_list ());
6403 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
, gnu_result
);
6407 case N_Validate_Unchecked_Conversion
:
6409 Entity_Id gnat_target_type
= Target_Type (gnat_node
);
6410 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
6411 tree gnu_target_type
= gnat_to_gnu_type (gnat_target_type
);
6413 /* No need for any warning in this case. */
6414 if (!flag_strict_aliasing
)
6417 /* If the result is a pointer type, see if we are either converting
6418 from a non-pointer or from a pointer to a type with a different
6419 alias set and warn if so. If the result is defined in the same
6420 unit as this unchecked conversion, we can allow this because we
6421 can know to make the pointer type behave properly. */
6422 else if (POINTER_TYPE_P (gnu_target_type
)
6423 && !In_Same_Source_Unit (gnat_target_type
, gnat_node
)
6424 && !No_Strict_Aliasing (Underlying_Type (gnat_target_type
)))
6426 tree gnu_source_desig_type
= POINTER_TYPE_P (gnu_source_type
)
6427 ? TREE_TYPE (gnu_source_type
)
6429 tree gnu_target_desig_type
= TREE_TYPE (gnu_target_type
);
6431 if ((TYPE_DUMMY_P (gnu_target_desig_type
)
6432 || get_alias_set (gnu_target_desig_type
) != 0)
6433 && (!POINTER_TYPE_P (gnu_source_type
)
6434 || (TYPE_DUMMY_P (gnu_source_desig_type
)
6435 != TYPE_DUMMY_P (gnu_target_desig_type
))
6436 || (TYPE_DUMMY_P (gnu_source_desig_type
)
6437 && gnu_source_desig_type
!= gnu_target_desig_type
)
6438 || !alias_sets_conflict_p
6439 (get_alias_set (gnu_source_desig_type
),
6440 get_alias_set (gnu_target_desig_type
))))
6443 ("?possible aliasing problem for type&",
6444 gnat_node
, Target_Type (gnat_node
));
6446 ("\\?use -fno-strict-aliasing switch for references",
6449 ("\\?or use `pragma No_Strict_Aliasing (&);`",
6450 gnat_node
, Target_Type (gnat_node
));
6454 /* But if the result is a fat pointer type, we have no mechanism to
6455 do that, so we unconditionally warn in problematic cases. */
6456 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type
))
6458 tree gnu_source_array_type
6459 = TYPE_IS_FAT_POINTER_P (gnu_source_type
)
6460 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type
)))
6462 tree gnu_target_array_type
6463 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type
)));
6465 if ((TYPE_DUMMY_P (gnu_target_array_type
)
6466 || get_alias_set (gnu_target_array_type
) != 0)
6467 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type
)
6468 || (TYPE_DUMMY_P (gnu_source_array_type
)
6469 != TYPE_DUMMY_P (gnu_target_array_type
))
6470 || (TYPE_DUMMY_P (gnu_source_array_type
)
6471 && gnu_source_array_type
!= gnu_target_array_type
)
6472 || !alias_sets_conflict_p
6473 (get_alias_set (gnu_source_array_type
),
6474 get_alias_set (gnu_target_array_type
))))
6477 ("?possible aliasing problem for type&",
6478 gnat_node
, Target_Type (gnat_node
));
6480 ("\\?use -fno-strict-aliasing switch for references",
6485 gnu_result
= alloc_stmt_list ();
6489 /* SCIL nodes require no processing for GCC. Other nodes should only
6490 be present when annotating types. */
6491 gcc_assert (IN (kind
, N_SCIL_Node
) || type_annotate_only
);
6492 gnu_result
= alloc_stmt_list ();
6495 /* If we pushed the processing of the elaboration routine, pop it back. */
6496 if (went_into_elab_proc
)
6497 current_function_decl
= NULL_TREE
;
6499 /* When not optimizing, turn boolean rvalues B into B != false tests
6500 so that the code just below can put the location information of the
6501 reference to B on the inequality operator for better debug info. */
6503 && TREE_CODE (gnu_result
) != INTEGER_CST
6504 && (kind
== N_Identifier
6505 || kind
== N_Expanded_Name
6506 || kind
== N_Explicit_Dereference
6507 || kind
== N_Function_Call
6508 || kind
== N_Indexed_Component
6509 || kind
== N_Selected_Component
)
6510 && TREE_CODE (get_base_type (gnu_result_type
)) == BOOLEAN_TYPE
6511 && !lvalue_required_p (gnat_node
, gnu_result_type
, false, false, false))
6512 gnu_result
= build_binary_op (NE_EXPR
, gnu_result_type
,
6513 convert (gnu_result_type
, gnu_result
),
6514 convert (gnu_result_type
,
6515 boolean_false_node
));
6517 /* Set the location information on the result. Note that we may have
6518 no result if we tried to build a CALL_EXPR node to a procedure with
6519 no side-effects and optimization is enabled. */
6520 if (gnu_result
&& EXPR_P (gnu_result
))
6521 set_gnu_expr_location_from_node (gnu_result
, gnat_node
);
6523 /* If we're supposed to return something of void_type, it means we have
6524 something we're elaborating for effect, so just return. */
6525 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
6528 /* If the result is a constant that overflowed, raise Constraint_Error. */
6529 if (TREE_CODE (gnu_result
) == INTEGER_CST
&& TREE_OVERFLOW (gnu_result
))
6531 post_error ("?`Constraint_Error` will be raised at run time", gnat_node
);
6533 = build1 (NULL_EXPR
, gnu_result_type
,
6534 build_call_raise (CE_Overflow_Check_Failed
, gnat_node
,
6535 N_Raise_Constraint_Error
));
6538 /* If our result has side-effects and is of an unconstrained type,
6539 make a SAVE_EXPR so that we can be sure it will only be referenced
6540 once. Note we must do this before any conversions. */
6541 if (TREE_SIDE_EFFECTS (gnu_result
)
6542 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
6543 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))))
6544 gnu_result
= gnat_stabilize_reference (gnu_result
, false, NULL
);
6546 /* Now convert the result to the result type, unless we are in one of the
6549 1. If this is the LHS of an assignment or an actual parameter of a
6550 call, return the result almost unmodified since the RHS will have
6551 to be converted to our type in that case, unless the result type
6552 has a simpler size. Likewise if there is just a no-op unchecked
6553 conversion in-between. Similarly, don't convert integral types
6554 that are the operands of an unchecked conversion since we need
6555 to ignore those conversions (for 'Valid).
6557 2. If we have a label (which doesn't have any well-defined type), a
6558 field or an error, return the result almost unmodified. Similarly,
6559 if the two types are record types with the same name, don't convert.
6560 This will be the case when we are converting from a packable version
6561 of a type to its original type and we need those conversions to be
6562 NOPs in order for assignments into these types to work properly.
6564 3. If the type is void or if we have no result, return error_mark_node
6565 to show we have no result.
6567 4. Finally, if the type of the result is already correct. */
6569 if (Present (Parent (gnat_node
))
6570 && (lhs_or_actual_p (gnat_node
)
6571 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
6572 && unchecked_conversion_nop (Parent (gnat_node
)))
6573 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
6574 && !AGGREGATE_TYPE_P (gnu_result_type
)
6575 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
))))
6576 && !(TYPE_SIZE (gnu_result_type
)
6577 && TYPE_SIZE (TREE_TYPE (gnu_result
))
6578 && (AGGREGATE_TYPE_P (gnu_result_type
)
6579 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
6580 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
6581 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
6583 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
6584 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
6585 && (CONTAINS_PLACEHOLDER_P
6586 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
6587 && !(TREE_CODE (gnu_result_type
) == RECORD_TYPE
6588 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type
))))
6590 /* Remove padding only if the inner object is of self-referential
6591 size: in that case it must be an object of unconstrained type
6592 with a default discriminant and we want to avoid copying too
6594 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
6595 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
6596 (TREE_TYPE (gnu_result
))))))
6597 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
6601 else if (TREE_CODE (gnu_result
) == LABEL_DECL
6602 || TREE_CODE (gnu_result
) == FIELD_DECL
6603 || TREE_CODE (gnu_result
) == ERROR_MARK
6604 || (TYPE_NAME (gnu_result_type
)
6605 == TYPE_NAME (TREE_TYPE (gnu_result
))
6606 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
6607 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
))
6609 /* Remove any padding. */
6610 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
6611 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
6615 else if (gnu_result
== error_mark_node
|| gnu_result_type
== void_type_node
)
6616 gnu_result
= error_mark_node
;
6618 else if (gnu_result_type
!= TREE_TYPE (gnu_result
))
6619 gnu_result
= convert (gnu_result_type
, gnu_result
);
6621 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
6622 while ((TREE_CODE (gnu_result
) == NOP_EXPR
6623 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
6624 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
6625 gnu_result
= TREE_OPERAND (gnu_result
, 0);
6630 /* Subroutine of above to push the exception label stack. GNU_STACK is
6631 a pointer to the stack to update and GNAT_LABEL, if present, is the
6632 label to push onto the stack. */
6635 push_exception_label_stack (VEC(tree
,gc
) **gnu_stack
, Entity_Id gnat_label
)
6637 tree gnu_label
= (Present (gnat_label
)
6638 ? gnat_to_gnu_entity (gnat_label
, NULL_TREE
, 0)
6641 VEC_safe_push (tree
, gc
, *gnu_stack
, gnu_label
);
6644 /* Record the current code position in GNAT_NODE. */
6647 record_code_position (Node_Id gnat_node
)
6649 tree stmt_stmt
= build1 (STMT_STMT
, void_type_node
, NULL_TREE
);
6651 add_stmt_with_node (stmt_stmt
, gnat_node
);
6652 save_gnu_tree (gnat_node
, stmt_stmt
, true);
6655 /* Insert the code for GNAT_NODE at the position saved for that node. */
6658 insert_code_for (Node_Id gnat_node
)
6660 STMT_STMT_STMT (get_gnu_tree (gnat_node
)) = gnat_to_gnu (gnat_node
);
6661 save_gnu_tree (gnat_node
, NULL_TREE
, true);
6664 /* Start a new statement group chained to the previous group. */
6667 start_stmt_group (void)
6669 struct stmt_group
*group
= stmt_group_free_list
;
6671 /* First see if we can get one from the free list. */
6673 stmt_group_free_list
= group
->previous
;
6675 group
= ggc_alloc_stmt_group ();
6677 group
->previous
= current_stmt_group
;
6678 group
->stmt_list
= group
->block
= group
->cleanups
= NULL_TREE
;
6679 current_stmt_group
= group
;
6682 /* Add GNU_STMT to the current statement group. If it is an expression with
6683 no effects, it is ignored. */
6686 add_stmt (tree gnu_stmt
)
6688 append_to_statement_list (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
6691 /* Similar, but the statement is always added, regardless of side-effects. */
6694 add_stmt_force (tree gnu_stmt
)
6696 append_to_statement_list_force (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
6699 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
6702 add_stmt_with_node (tree gnu_stmt
, Node_Id gnat_node
)
6704 if (Present (gnat_node
))
6705 set_expr_location_from_node (gnu_stmt
, gnat_node
);
6706 add_stmt (gnu_stmt
);
6709 /* Similar, but the statement is always added, regardless of side-effects. */
6712 add_stmt_with_node_force (tree gnu_stmt
, Node_Id gnat_node
)
6714 if (Present (gnat_node
))
6715 set_expr_location_from_node (gnu_stmt
, gnat_node
);
6716 add_stmt_force (gnu_stmt
);
6719 /* Add a declaration statement for GNU_DECL to the current statement group.
6720 Get SLOC from Entity_Id. */
6723 add_decl_expr (tree gnu_decl
, Entity_Id gnat_entity
)
6725 tree type
= TREE_TYPE (gnu_decl
);
6726 tree gnu_stmt
, gnu_init
, t
;
6728 /* If this is a variable that Gigi is to ignore, we may have been given
6729 an ERROR_MARK. So test for it. We also might have been given a
6730 reference for a renaming. So only do something for a decl. Also
6731 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
6732 if (!DECL_P (gnu_decl
)
6733 || (TREE_CODE (gnu_decl
) == TYPE_DECL
6734 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
))
6737 gnu_stmt
= build1 (DECL_EXPR
, void_type_node
, gnu_decl
);
6739 /* If we are global, we don't want to actually output the DECL_EXPR for
6740 this decl since we already have evaluated the expressions in the
6741 sizes and positions as globals and doing it again would be wrong. */
6742 if (global_bindings_p ())
6744 /* Mark everything as used to prevent node sharing with subprograms.
6745 Note that walk_tree knows how to deal with TYPE_DECL, but neither
6746 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
6747 MARK_VISITED (gnu_stmt
);
6748 if (TREE_CODE (gnu_decl
) == VAR_DECL
6749 || TREE_CODE (gnu_decl
) == CONST_DECL
)
6751 MARK_VISITED (DECL_SIZE (gnu_decl
));
6752 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl
));
6753 MARK_VISITED (DECL_INITIAL (gnu_decl
));
6755 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
6756 else if (TREE_CODE (gnu_decl
) == TYPE_DECL
6757 && RECORD_OR_UNION_TYPE_P (type
)
6758 && !TYPE_FAT_POINTER_P (type
))
6759 MARK_VISITED (TYPE_ADA_SIZE (type
));
6761 else if (!DECL_EXTERNAL (gnu_decl
))
6762 add_stmt_with_node (gnu_stmt
, gnat_entity
);
6764 /* If this is a variable and an initializer is attached to it, it must be
6765 valid for the context. Similar to init_const in create_var_decl_1. */
6766 if (TREE_CODE (gnu_decl
) == VAR_DECL
6767 && (gnu_init
= DECL_INITIAL (gnu_decl
)) != NULL_TREE
6768 && (!gnat_types_compatible_p (type
, TREE_TYPE (gnu_init
))
6769 || (TREE_STATIC (gnu_decl
)
6770 && !initializer_constant_valid_p (gnu_init
,
6771 TREE_TYPE (gnu_init
)))))
6773 /* If GNU_DECL has a padded type, convert it to the unpadded
6774 type so the assignment is done properly. */
6775 if (TYPE_IS_PADDING_P (type
))
6776 t
= convert (TREE_TYPE (TYPE_FIELDS (type
)), gnu_decl
);
6780 gnu_stmt
= build_binary_op (INIT_EXPR
, NULL_TREE
, t
, gnu_init
);
6782 DECL_INITIAL (gnu_decl
) = NULL_TREE
;
6783 if (TREE_READONLY (gnu_decl
))
6785 TREE_READONLY (gnu_decl
) = 0;
6786 DECL_READONLY_ONCE_ELAB (gnu_decl
) = 1;
6789 add_stmt_with_node (gnu_stmt
, gnat_entity
);
6793 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
6796 mark_visited_r (tree
*tp
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
6800 if (TREE_VISITED (t
))
6803 /* Don't mark a dummy type as visited because we want to mark its sizes
6804 and fields once it's filled in. */
6805 else if (!TYPE_IS_DUMMY_P (t
))
6806 TREE_VISITED (t
) = 1;
6809 TYPE_SIZES_GIMPLIFIED (t
) = 1;
6814 /* Mark nodes rooted at T with TREE_VISITED and types as having their
6815 sized gimplified. We use this to indicate all variable sizes and
6816 positions in global types may not be shared by any subprogram. */
6819 mark_visited (tree t
)
6821 walk_tree (&t
, mark_visited_r
, NULL
, NULL
);
6824 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
6825 set its location to that of GNAT_NODE if present. */
6828 add_cleanup (tree gnu_cleanup
, Node_Id gnat_node
)
6830 if (Present (gnat_node
))
6831 set_expr_location_from_node (gnu_cleanup
, gnat_node
);
6832 append_to_statement_list (gnu_cleanup
, ¤t_stmt_group
->cleanups
);
6835 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
6838 set_block_for_group (tree gnu_block
)
6840 gcc_assert (!current_stmt_group
->block
);
6841 current_stmt_group
->block
= gnu_block
;
6844 /* Return code corresponding to the current code group. It is normally
6845 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
6846 BLOCK or cleanups were set. */
6849 end_stmt_group (void)
6851 struct stmt_group
*group
= current_stmt_group
;
6852 tree gnu_retval
= group
->stmt_list
;
6854 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
6855 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
6856 make a BIND_EXPR. Note that we nest in that because the cleanup may
6857 reference variables in the block. */
6858 if (gnu_retval
== NULL_TREE
)
6859 gnu_retval
= alloc_stmt_list ();
6861 if (group
->cleanups
)
6862 gnu_retval
= build2 (TRY_FINALLY_EXPR
, void_type_node
, gnu_retval
,
6865 if (current_stmt_group
->block
)
6866 gnu_retval
= build3 (BIND_EXPR
, void_type_node
, BLOCK_VARS (group
->block
),
6867 gnu_retval
, group
->block
);
6869 /* Remove this group from the stack and add it to the free list. */
6870 current_stmt_group
= group
->previous
;
6871 group
->previous
= stmt_group_free_list
;
6872 stmt_group_free_list
= group
;
6877 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
6881 add_stmt_list (List_Id gnat_list
)
6885 if (Present (gnat_list
))
6886 for (gnat_node
= First (gnat_list
); Present (gnat_node
);
6887 gnat_node
= Next (gnat_node
))
6888 add_stmt (gnat_to_gnu (gnat_node
));
6891 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
6892 If BINDING_P is true, push and pop a binding level around the list. */
6895 build_stmt_group (List_Id gnat_list
, bool binding_p
)
6897 start_stmt_group ();
6901 add_stmt_list (gnat_list
);
6905 return end_stmt_group ();
6908 /* Generate GIMPLE in place for the expression at *EXPR_P. */
6911 gnat_gimplify_expr (tree
*expr_p
, gimple_seq
*pre_p
,
6912 gimple_seq
*post_p ATTRIBUTE_UNUSED
)
6914 tree expr
= *expr_p
;
6917 if (IS_ADA_STMT (expr
))
6918 return gnat_gimplify_stmt (expr_p
);
6920 switch (TREE_CODE (expr
))
6923 /* If this is for a scalar, just make a VAR_DECL for it. If for
6924 an aggregate, get a null pointer of the appropriate type and
6926 if (AGGREGATE_TYPE_P (TREE_TYPE (expr
)))
6927 *expr_p
= build1 (INDIRECT_REF
, TREE_TYPE (expr
),
6928 convert (build_pointer_type (TREE_TYPE (expr
)),
6929 integer_zero_node
));
6932 *expr_p
= create_tmp_var (TREE_TYPE (expr
), NULL
);
6933 TREE_NO_WARNING (*expr_p
) = 1;
6936 gimplify_and_add (TREE_OPERAND (expr
, 0), pre_p
);
6939 case UNCONSTRAINED_ARRAY_REF
:
6940 /* We should only do this if we are just elaborating for side-effects,
6941 but we can't know that yet. */
6942 *expr_p
= TREE_OPERAND (*expr_p
, 0);
6946 op
= TREE_OPERAND (expr
, 0);
6948 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
6949 is put into static memory. We know that it's going to be read-only
6950 given the semantics we have and it must be in static memory when the
6951 reference is in an elaboration procedure. */
6952 if (TREE_CODE (op
) == CONSTRUCTOR
&& TREE_CONSTANT (op
))
6954 tree addr
= build_fold_addr_expr (tree_output_constant_def (op
));
6955 *expr_p
= fold_convert (TREE_TYPE (expr
), addr
);
6959 /* Otherwise, if we are taking the address of a non-constant CONSTRUCTOR
6960 or of a call, explicitly create the local temporary. That's required
6961 if the type is passed by reference. */
6962 if (TREE_CODE (op
) == CONSTRUCTOR
|| TREE_CODE (op
) == CALL_EXPR
)
6964 tree mod
, new_var
= create_tmp_var_raw (TREE_TYPE (op
), "C");
6965 TREE_ADDRESSABLE (new_var
) = 1;
6966 gimple_add_tmp_var (new_var
);
6968 mod
= build2 (INIT_EXPR
, TREE_TYPE (new_var
), new_var
, op
);
6969 gimplify_and_add (mod
, pre_p
);
6971 TREE_OPERAND (expr
, 0) = new_var
;
6972 recompute_tree_invariant_for_addr_expr (expr
);
6976 return GS_UNHANDLED
;
6978 case VIEW_CONVERT_EXPR
:
6979 op
= TREE_OPERAND (expr
, 0);
6981 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
6982 type to a scalar one, explicitly create the local temporary. That's
6983 required if the type is passed by reference. */
6984 if ((TREE_CODE (op
) == CONSTRUCTOR
|| TREE_CODE (op
) == CALL_EXPR
)
6985 && AGGREGATE_TYPE_P (TREE_TYPE (op
))
6986 && !AGGREGATE_TYPE_P (TREE_TYPE (expr
)))
6988 tree mod
, new_var
= create_tmp_var_raw (TREE_TYPE (op
), "C");
6989 gimple_add_tmp_var (new_var
);
6991 mod
= build2 (INIT_EXPR
, TREE_TYPE (new_var
), new_var
, op
);
6992 gimplify_and_add (mod
, pre_p
);
6994 TREE_OPERAND (expr
, 0) = new_var
;
6998 return GS_UNHANDLED
;
7001 op
= DECL_EXPR_DECL (expr
);
7003 /* The expressions for the RM bounds must be gimplified to ensure that
7004 they are properly elaborated. See gimplify_decl_expr. */
7005 if ((TREE_CODE (op
) == TYPE_DECL
|| TREE_CODE (op
) == VAR_DECL
)
7006 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op
)))
7007 switch (TREE_CODE (TREE_TYPE (op
)))
7014 tree type
= TYPE_MAIN_VARIANT (TREE_TYPE (op
)), t
, val
;
7016 val
= TYPE_RM_MIN_VALUE (type
);
7019 gimplify_one_sizepos (&val
, pre_p
);
7020 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
7021 SET_TYPE_RM_MIN_VALUE (t
, val
);
7024 val
= TYPE_RM_MAX_VALUE (type
);
7027 gimplify_one_sizepos (&val
, pre_p
);
7028 for (t
= type
; t
; t
= TYPE_NEXT_VARIANT (t
))
7029 SET_TYPE_RM_MAX_VALUE (t
, val
);
7039 /* ... fall through ... */
7042 return GS_UNHANDLED
;
7046 /* Generate GIMPLE in place for the statement at *STMT_P. */
7048 static enum gimplify_status
7049 gnat_gimplify_stmt (tree
*stmt_p
)
7051 tree stmt
= *stmt_p
;
7053 switch (TREE_CODE (stmt
))
7056 *stmt_p
= STMT_STMT_STMT (stmt
);
7061 tree gnu_start_label
= create_artificial_label (input_location
);
7062 tree gnu_cond
= LOOP_STMT_COND (stmt
);
7063 tree gnu_update
= LOOP_STMT_UPDATE (stmt
);
7064 tree gnu_end_label
= LOOP_STMT_LABEL (stmt
);
7067 /* Build the condition expression from the test, if any. */
7070 = build3 (COND_EXPR
, void_type_node
, gnu_cond
, alloc_stmt_list (),
7071 build1 (GOTO_EXPR
, void_type_node
, gnu_end_label
));
7073 /* Set to emit the statements of the loop. */
7074 *stmt_p
= NULL_TREE
;
7076 /* We first emit the start label and then a conditional jump to the
7077 end label if there's a top condition, then the update if it's at
7078 the top, then the body of the loop, then a conditional jump to
7079 the end label if there's a bottom condition, then the update if
7080 it's at the bottom, and finally a jump to the start label and the
7081 definition of the end label. */
7082 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
7086 if (gnu_cond
&& !LOOP_STMT_BOTTOM_COND_P (stmt
))
7087 append_to_statement_list (gnu_cond
, stmt_p
);
7089 if (gnu_update
&& LOOP_STMT_TOP_UPDATE_P (stmt
))
7090 append_to_statement_list (gnu_update
, stmt_p
);
7092 append_to_statement_list (LOOP_STMT_BODY (stmt
), stmt_p
);
7094 if (gnu_cond
&& LOOP_STMT_BOTTOM_COND_P (stmt
))
7095 append_to_statement_list (gnu_cond
, stmt_p
);
7097 if (gnu_update
&& !LOOP_STMT_TOP_UPDATE_P (stmt
))
7098 append_to_statement_list (gnu_update
, stmt_p
);
7100 t
= build1 (GOTO_EXPR
, void_type_node
, gnu_start_label
);
7101 SET_EXPR_LOCATION (t
, DECL_SOURCE_LOCATION (gnu_end_label
));
7102 append_to_statement_list (t
, stmt_p
);
7104 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
7111 /* Build a statement to jump to the corresponding end label, then
7112 see if it needs to be conditional. */
7113 *stmt_p
= build1 (GOTO_EXPR
, void_type_node
, EXIT_STMT_LABEL (stmt
));
7114 if (EXIT_STMT_COND (stmt
))
7115 *stmt_p
= build3 (COND_EXPR
, void_type_node
,
7116 EXIT_STMT_COND (stmt
), *stmt_p
, alloc_stmt_list ());
7124 /* Force references to each of the entities in packages withed by GNAT_NODE.
7125 Operate recursively but check that we aren't elaborating something more
7128 This routine is exclusively called in type_annotate mode, to compute DDA
7129 information for types in withed units, for ASIS use. */
7132 elaborate_all_entities (Node_Id gnat_node
)
7134 Entity_Id gnat_with_clause
, gnat_entity
;
7136 /* Process each unit only once. As we trace the context of all relevant
7137 units transitively, including generic bodies, we may encounter the
7138 same generic unit repeatedly. */
7139 if (!present_gnu_tree (gnat_node
))
7140 save_gnu_tree (gnat_node
, integer_zero_node
, true);
7142 /* Save entities in all context units. A body may have an implicit_with
7143 on its own spec, if the context includes a child unit, so don't save
7145 for (gnat_with_clause
= First (Context_Items (gnat_node
));
7146 Present (gnat_with_clause
);
7147 gnat_with_clause
= Next (gnat_with_clause
))
7148 if (Nkind (gnat_with_clause
) == N_With_Clause
7149 && !present_gnu_tree (Library_Unit (gnat_with_clause
))
7150 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
7152 elaborate_all_entities (Library_Unit (gnat_with_clause
));
7154 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
7156 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
7157 Present (gnat_entity
);
7158 gnat_entity
= Next_Entity (gnat_entity
))
7159 if (Is_Public (gnat_entity
)
7160 && Convention (gnat_entity
) != Convention_Intrinsic
7161 && Ekind (gnat_entity
) != E_Package
7162 && Ekind (gnat_entity
) != E_Package_Body
7163 && Ekind (gnat_entity
) != E_Operator
7164 && !(IN (Ekind (gnat_entity
), Type_Kind
)
7165 && !Is_Frozen (gnat_entity
))
7166 && !((Ekind (gnat_entity
) == E_Procedure
7167 || Ekind (gnat_entity
) == E_Function
)
7168 && Is_Intrinsic_Subprogram (gnat_entity
))
7169 && !IN (Ekind (gnat_entity
), Named_Kind
)
7170 && !IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
7171 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
7173 else if (Ekind (Entity (Name (gnat_with_clause
))) == E_Generic_Package
)
7176 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause
)));
7178 /* Retrieve compilation unit node of generic body. */
7179 while (Present (gnat_body
)
7180 && Nkind (gnat_body
) != N_Compilation_Unit
)
7181 gnat_body
= Parent (gnat_body
);
7183 /* If body is available, elaborate its context. */
7184 if (Present (gnat_body
))
7185 elaborate_all_entities (gnat_body
);
7189 if (Nkind (Unit (gnat_node
)) == N_Package_Body
)
7190 elaborate_all_entities (Library_Unit (gnat_node
));
7193 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
7196 process_freeze_entity (Node_Id gnat_node
)
7198 const Entity_Id gnat_entity
= Entity (gnat_node
);
7199 const Entity_Kind kind
= Ekind (gnat_entity
);
7200 tree gnu_old
, gnu_new
;
7202 /* If this is a package, we need to generate code for the package. */
7203 if (kind
== E_Package
)
7206 (Parent (Corresponding_Body
7207 (Parent (Declaration_Node (gnat_entity
)))));
7211 /* Don't do anything for class-wide types as they are always transformed
7212 into their root type. */
7213 if (kind
== E_Class_Wide_Type
)
7216 /* Check for an old definition. This freeze node might be for an Itype. */
7218 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : NULL_TREE
;
7220 /* If this entity has an address representation clause, GNU_OLD is the
7221 address, so discard it here. */
7222 if (Present (Address_Clause (gnat_entity
)))
7223 gnu_old
= NULL_TREE
;
7225 /* Don't do anything for subprograms that may have been elaborated before
7226 their freeze nodes. This can happen, for example, because of an inner
7227 call in an instance body or because of previous compilation of a spec
7228 for inlining purposes. */
7230 && ((TREE_CODE (gnu_old
) == FUNCTION_DECL
7231 && (kind
== E_Function
|| kind
== E_Procedure
))
7232 || (TREE_CODE (TREE_TYPE (gnu_old
)) == FUNCTION_TYPE
7233 && kind
== E_Subprogram_Type
)))
7236 /* If we have a non-dummy type old tree, we have nothing to do, except
7237 aborting if this is the public view of a private type whose full view was
7238 not delayed, as this node was never delayed as it should have been. We
7239 let this happen for concurrent types and their Corresponding_Record_Type,
7240 however, because each might legitimately be elaborated before its own
7241 freeze node, e.g. while processing the other. */
7243 && !(TREE_CODE (gnu_old
) == TYPE_DECL
7244 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
7246 gcc_assert ((IN (kind
, Incomplete_Or_Private_Kind
)
7247 && Present (Full_View (gnat_entity
))
7248 && No (Freeze_Node (Full_View (gnat_entity
))))
7249 || Is_Concurrent_Type (gnat_entity
)
7250 || (IN (kind
, Record_Kind
)
7251 && Is_Concurrent_Record_Type (gnat_entity
)));
7255 /* Reset the saved tree, if any, and elaborate the object or type for real.
7256 If there is a full view, elaborate it and use the result. And, if this
7257 is the root type of a class-wide type, reuse it for the latter. */
7260 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
7261 if (IN (kind
, Incomplete_Or_Private_Kind
)
7262 && Present (Full_View (gnat_entity
))
7263 && present_gnu_tree (Full_View (gnat_entity
)))
7264 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, false);
7265 if (IN (kind
, Type_Kind
)
7266 && Present (Class_Wide_Type (gnat_entity
))
7267 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
7268 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, false);
7271 if (IN (kind
, Incomplete_Or_Private_Kind
)
7272 && Present (Full_View (gnat_entity
)))
7274 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
7276 /* Propagate back-annotations from full view to partial view. */
7277 if (Unknown_Alignment (gnat_entity
))
7278 Set_Alignment (gnat_entity
, Alignment (Full_View (gnat_entity
)));
7280 if (Unknown_Esize (gnat_entity
))
7281 Set_Esize (gnat_entity
, Esize (Full_View (gnat_entity
)));
7283 if (Unknown_RM_Size (gnat_entity
))
7284 Set_RM_Size (gnat_entity
, RM_Size (Full_View (gnat_entity
)));
7286 /* The above call may have defined this entity (the simplest example
7287 of this is when we have a private enumeral type since the bounds
7288 will have the public view). */
7289 if (!present_gnu_tree (gnat_entity
))
7290 save_gnu_tree (gnat_entity
, gnu_new
, false);
7295 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
7296 && present_gnu_tree (Declaration_Node (gnat_entity
)))
7297 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
7299 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
7302 if (IN (kind
, Type_Kind
)
7303 && Present (Class_Wide_Type (gnat_entity
))
7304 && Root_Type (Class_Wide_Type (gnat_entity
)) == gnat_entity
)
7305 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, false);
7307 /* If we have an old type and we've made pointers to this type, update those
7308 pointers. If this is a Taft amendment type in the main unit, we need to
7309 mark the type as used since other units referencing it don't see the full
7310 declaration and, therefore, cannot mark it as used themselves. */
7313 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
7314 TREE_TYPE (gnu_new
));
7315 if (DECL_TAFT_TYPE_P (gnu_old
))
7316 used_types_insert (TREE_TYPE (gnu_new
));
7320 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
7321 We make two passes, one to elaborate anything other than bodies (but
7322 we declare a function if there was no spec). The second pass
7323 elaborates the bodies.
7325 GNAT_END_LIST gives the element in the list past the end. Normally,
7326 this is Empty, but can be First_Real_Statement for a
7327 Handled_Sequence_Of_Statements.
7329 We make a complete pass through both lists if PASS1P is true, then make
7330 the second pass over both lists if PASS2P is true. The lists usually
7331 correspond to the public and private parts of a package. */
7334 process_decls (List_Id gnat_decls
, List_Id gnat_decls2
,
7335 Node_Id gnat_end_list
, bool pass1p
, bool pass2p
)
7337 List_Id gnat_decl_array
[2];
7341 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
7344 for (i
= 0; i
<= 1; i
++)
7345 if (Present (gnat_decl_array
[i
]))
7346 for (gnat_decl
= First (gnat_decl_array
[i
]);
7347 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
7349 /* For package specs, we recurse inside the declarations,
7350 thus taking the two pass approach inside the boundary. */
7351 if (Nkind (gnat_decl
) == N_Package_Declaration
7352 && (Nkind (Specification (gnat_decl
)
7353 == N_Package_Specification
)))
7354 process_decls (Visible_Declarations (Specification (gnat_decl
)),
7355 Private_Declarations (Specification (gnat_decl
)),
7356 Empty
, true, false);
7358 /* Similarly for any declarations in the actions of a
7360 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
7362 process_freeze_entity (gnat_decl
);
7363 process_decls (Actions (gnat_decl
), Empty
, Empty
, true, false);
7366 /* Package bodies with freeze nodes get their elaboration deferred
7367 until the freeze node, but the code must be placed in the right
7368 place, so record the code position now. */
7369 else if (Nkind (gnat_decl
) == N_Package_Body
7370 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
7371 record_code_position (gnat_decl
);
7373 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
7374 && Present (Library_Unit (gnat_decl
))
7375 && Present (Freeze_Node
7378 (Library_Unit (gnat_decl
)))))))
7379 record_code_position
7380 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
7382 /* We defer most subprogram bodies to the second pass. */
7383 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
7385 if (Acts_As_Spec (gnat_decl
))
7387 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
7389 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
7390 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
7391 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
7395 /* For bodies and stubs that act as their own specs, the entity
7396 itself must be elaborated in the first pass, because it may
7397 be used in other declarations. */
7398 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
7400 Node_Id gnat_subprog_id
7401 = Defining_Entity (Specification (gnat_decl
));
7403 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
7404 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
7405 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
7406 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
7409 /* Concurrent stubs stand for the corresponding subprogram bodies,
7410 which are deferred like other bodies. */
7411 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
7412 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
7416 add_stmt (gnat_to_gnu (gnat_decl
));
7419 /* Here we elaborate everything we deferred above except for package bodies,
7420 which are elaborated at their freeze nodes. Note that we must also
7421 go inside things (package specs and freeze nodes) the first pass did. */
7423 for (i
= 0; i
<= 1; i
++)
7424 if (Present (gnat_decl_array
[i
]))
7425 for (gnat_decl
= First (gnat_decl_array
[i
]);
7426 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
7428 if (Nkind (gnat_decl
) == N_Subprogram_Body
7429 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
7430 || Nkind (gnat_decl
) == N_Task_Body_Stub
7431 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
7432 add_stmt (gnat_to_gnu (gnat_decl
));
7434 else if (Nkind (gnat_decl
) == N_Package_Declaration
7435 && (Nkind (Specification (gnat_decl
)
7436 == N_Package_Specification
)))
7437 process_decls (Visible_Declarations (Specification (gnat_decl
)),
7438 Private_Declarations (Specification (gnat_decl
)),
7439 Empty
, false, true);
7441 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
7442 process_decls (Actions (gnat_decl
), Empty
, Empty
, false, true);
7446 /* Make a unary operation of kind CODE using build_unary_op, but guard
7447 the operation by an overflow check. CODE can be one of NEGATE_EXPR
7448 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
7449 the operation is to be performed in that type. GNAT_NODE is the gnat
7450 node conveying the source location for which the error should be
7454 build_unary_op_trapv (enum tree_code code
, tree gnu_type
, tree operand
,
7457 gcc_assert (code
== NEGATE_EXPR
|| code
== ABS_EXPR
);
7459 operand
= gnat_protect_expr (operand
);
7461 return emit_check (build_binary_op (EQ_EXPR
, boolean_type_node
,
7462 operand
, TYPE_MIN_VALUE (gnu_type
)),
7463 build_unary_op (code
, gnu_type
, operand
),
7464 CE_Overflow_Check_Failed
, gnat_node
);
7467 /* Make a binary operation of kind CODE using build_binary_op, but guard
7468 the operation by an overflow check. CODE can be one of PLUS_EXPR,
7469 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
7470 Usually the operation is to be performed in that type. GNAT_NODE is
7471 the GNAT node conveying the source location for which the error should
7475 build_binary_op_trapv (enum tree_code code
, tree gnu_type
, tree left
,
7476 tree right
, Node_Id gnat_node
)
7478 tree lhs
= gnat_protect_expr (left
);
7479 tree rhs
= gnat_protect_expr (right
);
7480 tree type_max
= TYPE_MAX_VALUE (gnu_type
);
7481 tree type_min
= TYPE_MIN_VALUE (gnu_type
);
7484 tree zero
= convert (gnu_type
, integer_zero_node
);
7489 int precision
= TYPE_PRECISION (gnu_type
);
7491 gcc_assert (!(precision
& (precision
- 1))); /* ensure power of 2 */
7493 /* Prefer a constant or known-positive rhs to simplify checks. */
7494 if (!TREE_CONSTANT (rhs
)
7495 && commutative_tree_code (code
)
7496 && (TREE_CONSTANT (lhs
) || (!tree_expr_nonnegative_p (rhs
)
7497 && tree_expr_nonnegative_p (lhs
))))
7504 rhs_lt_zero
= tree_expr_nonnegative_p (rhs
)
7505 ? boolean_false_node
7506 : build_binary_op (LT_EXPR
, boolean_type_node
, rhs
, zero
);
7508 /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
7510 /* Try a few strategies that may be cheaper than the general
7511 code at the end of the function, if the rhs is not known.
7513 - Call library function for 64-bit multiplication (complex)
7514 - Widen, if input arguments are sufficiently small
7515 - Determine overflow using wrapped result for addition/subtraction. */
7517 if (!TREE_CONSTANT (rhs
))
7519 /* Even for add/subtract double size to get another base type. */
7520 int needed_precision
= precision
* 2;
7522 if (code
== MULT_EXPR
&& precision
== 64)
7524 tree int_64
= gnat_type_for_size (64, 0);
7526 return convert (gnu_type
, build_call_n_expr (mulv64_decl
, 2,
7527 convert (int_64
, lhs
),
7528 convert (int_64
, rhs
)));
7531 else if (needed_precision
<= BITS_PER_WORD
7532 || (code
== MULT_EXPR
7533 && needed_precision
<= LONG_LONG_TYPE_SIZE
))
7535 tree wide_type
= gnat_type_for_size (needed_precision
, 0);
7537 tree wide_result
= build_binary_op (code
, wide_type
,
7538 convert (wide_type
, lhs
),
7539 convert (wide_type
, rhs
));
7541 tree check
= build_binary_op
7542 (TRUTH_ORIF_EXPR
, boolean_type_node
,
7543 build_binary_op (LT_EXPR
, boolean_type_node
, wide_result
,
7544 convert (wide_type
, type_min
)),
7545 build_binary_op (GT_EXPR
, boolean_type_node
, wide_result
,
7546 convert (wide_type
, type_max
)));
7548 tree result
= convert (gnu_type
, wide_result
);
7551 emit_check (check
, result
, CE_Overflow_Check_Failed
, gnat_node
);
7554 else if (code
== PLUS_EXPR
|| code
== MINUS_EXPR
)
7556 tree unsigned_type
= gnat_type_for_size (precision
, 1);
7557 tree wrapped_expr
= convert
7558 (gnu_type
, build_binary_op (code
, unsigned_type
,
7559 convert (unsigned_type
, lhs
),
7560 convert (unsigned_type
, rhs
)));
7562 tree result
= convert
7563 (gnu_type
, build_binary_op (code
, gnu_type
, lhs
, rhs
));
7565 /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
7566 or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */
7567 tree check
= build_binary_op
7568 (TRUTH_XOR_EXPR
, boolean_type_node
, rhs_lt_zero
,
7569 build_binary_op (code
== PLUS_EXPR
? LT_EXPR
: GT_EXPR
,
7570 boolean_type_node
, wrapped_expr
, lhs
));
7573 emit_check (check
, result
, CE_Overflow_Check_Failed
, gnat_node
);
7580 /* When rhs >= 0, overflow when lhs > type_max - rhs. */
7581 check_pos
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
7582 build_binary_op (MINUS_EXPR
, gnu_type
,
7585 /* When rhs < 0, overflow when lhs < type_min - rhs. */
7586 check_neg
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
7587 build_binary_op (MINUS_EXPR
, gnu_type
,
7592 /* When rhs >= 0, overflow when lhs < type_min + rhs. */
7593 check_pos
= build_binary_op (LT_EXPR
, boolean_type_node
, lhs
,
7594 build_binary_op (PLUS_EXPR
, gnu_type
,
7597 /* When rhs < 0, overflow when lhs > type_max + rhs. */
7598 check_neg
= build_binary_op (GT_EXPR
, boolean_type_node
, lhs
,
7599 build_binary_op (PLUS_EXPR
, gnu_type
,
7604 /* The check here is designed to be efficient if the rhs is constant,
7605 but it will work for any rhs by using integer division.
7606 Four different check expressions determine whether X * C overflows,
7609 C > 0 => X > type_max / C || X < type_min / C
7610 C == -1 => X == type_min
7611 C < -1 => X > type_min / C || X < type_max / C */
7613 tmp1
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_max
, rhs
);
7614 tmp2
= build_binary_op (TRUNC_DIV_EXPR
, gnu_type
, type_min
, rhs
);
7617 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
7618 build_binary_op (NE_EXPR
, boolean_type_node
, zero
,
7620 build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
7621 build_binary_op (GT_EXPR
,
7624 build_binary_op (LT_EXPR
,
7629 = fold_build3 (COND_EXPR
, boolean_type_node
,
7630 build_binary_op (EQ_EXPR
, boolean_type_node
, rhs
,
7631 build_int_cst (gnu_type
, -1)),
7632 build_binary_op (EQ_EXPR
, boolean_type_node
, lhs
,
7634 build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
7635 build_binary_op (GT_EXPR
,
7638 build_binary_op (LT_EXPR
,
7647 gnu_expr
= build_binary_op (code
, gnu_type
, lhs
, rhs
);
7649 /* If we can fold the expression to a constant, just return it.
7650 The caller will deal with overflow, no need to generate a check. */
7651 if (TREE_CONSTANT (gnu_expr
))
7654 check
= fold_build3 (COND_EXPR
, boolean_type_node
, rhs_lt_zero
, check_neg
,
7657 return emit_check (check
, gnu_expr
, CE_Overflow_Check_Failed
, gnat_node
);
7660 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
7661 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
7662 which we have to check. GNAT_NODE is the GNAT node conveying the source
7663 location for which the error should be signaled. */
7666 emit_range_check (tree gnu_expr
, Entity_Id gnat_range_type
, Node_Id gnat_node
)
7668 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
7669 tree gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
7670 tree gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
7671 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
7673 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
7674 This can for example happen when translating 'Val or 'Value. */
7675 if (gnu_compare_type
== gnu_range_type
)
7678 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
7679 we can't do anything since we might be truncating the bounds. No
7680 check is needed in this case. */
7681 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
7682 && (TYPE_PRECISION (gnu_compare_type
)
7683 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
7686 /* Checked expressions must be evaluated only once. */
7687 gnu_expr
= gnat_protect_expr (gnu_expr
);
7689 /* Note that the form of the check is
7690 (not (expr >= lo)) or (not (expr <= hi))
7691 the reason for this slightly convoluted form is that NaNs
7692 are not considered to be in range in the float case. */
7694 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
7696 (build_binary_op (GE_EXPR
, boolean_type_node
,
7697 convert (gnu_compare_type
, gnu_expr
),
7698 convert (gnu_compare_type
, gnu_low
))),
7700 (build_binary_op (LE_EXPR
, boolean_type_node
,
7701 convert (gnu_compare_type
, gnu_expr
),
7702 convert (gnu_compare_type
,
7704 gnu_expr
, CE_Range_Check_Failed
, gnat_node
);
7707 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which
7708 we are about to index, GNU_EXPR is the index expression to be checked,
7709 GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
7710 has to be checked. Note that for index checking we cannot simply use the
7711 emit_range_check function (although very similar code needs to be generated
7712 in both cases) since for index checking the array type against which we are
7713 checking the indices may be unconstrained and consequently we need to get
7714 the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
7715 The place where we need to do that is in subprograms having unconstrained
7716 array formal parameters. GNAT_NODE is the GNAT node conveying the source
7717 location for which the error should be signaled. */
7720 emit_index_check (tree gnu_array_object
, tree gnu_expr
, tree gnu_low
,
7721 tree gnu_high
, Node_Id gnat_node
)
7723 tree gnu_expr_check
;
7725 /* Checked expressions must be evaluated only once. */
7726 gnu_expr
= gnat_protect_expr (gnu_expr
);
7728 /* Must do this computation in the base type in case the expression's
7729 type is an unsigned subtypes. */
7730 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
7732 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
7733 the object we are handling. */
7734 gnu_low
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low
, gnu_array_object
);
7735 gnu_high
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high
, gnu_array_object
);
7738 (build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
,
7739 build_binary_op (LT_EXPR
, boolean_type_node
,
7741 convert (TREE_TYPE (gnu_expr_check
),
7743 build_binary_op (GT_EXPR
, boolean_type_node
,
7745 convert (TREE_TYPE (gnu_expr_check
),
7747 gnu_expr
, CE_Index_Check_Failed
, gnat_node
);
7750 /* GNU_COND contains the condition corresponding to an access, discriminant or
7751 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
7752 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
7753 REASON is the code that says why the exception was raised. GNAT_NODE is
7754 the GNAT node conveying the source location for which the error should be
7758 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
, Node_Id gnat_node
)
7761 = build_call_raise (reason
, gnat_node
, N_Raise_Constraint_Error
);
7763 = fold_build3 (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
7764 build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_call
,
7765 convert (TREE_TYPE (gnu_expr
), integer_zero_node
)),
7768 /* GNU_RESULT has side effects if and only if GNU_EXPR has:
7769 we don't need to evaluate it just for the check. */
7770 TREE_SIDE_EFFECTS (gnu_result
) = TREE_SIDE_EFFECTS (gnu_expr
);
7775 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
7776 checks if OVERFLOW_P is true and range checks if RANGE_P is true.
7777 GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
7778 float to integer conversion with truncation; otherwise round.
7779 GNAT_NODE is the GNAT node conveying the source location for which the
7780 error should be signaled. */
7783 convert_with_check (Entity_Id gnat_type
, tree gnu_expr
, bool overflowp
,
7784 bool rangep
, bool truncatep
, Node_Id gnat_node
)
7786 tree gnu_type
= get_unpadded_type (gnat_type
);
7787 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
7788 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
7789 tree gnu_base_type
= get_base_type (gnu_type
);
7790 tree gnu_result
= gnu_expr
;
7792 /* If we are not doing any checks, the output is an integral type, and
7793 the input is not a floating type, just do the conversion. This
7794 shortcut is required to avoid problems with packed array types
7795 and simplifies code in all cases anyway. */
7796 if (!rangep
&& !overflowp
&& INTEGRAL_TYPE_P (gnu_base_type
)
7797 && !FLOAT_TYPE_P (gnu_in_type
))
7798 return convert (gnu_type
, gnu_expr
);
7800 /* First convert the expression to its base type. This
7801 will never generate code, but makes the tests below much simpler.
7802 But don't do this if converting from an integer type to an unconstrained
7803 array type since then we need to get the bounds from the original
7805 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
7806 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
7808 /* If overflow checks are requested, we need to be sure the result will
7809 fit in the output base type. But don't do this if the input
7810 is integer and the output floating-point. */
7812 && !(FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
7814 /* Ensure GNU_EXPR only gets evaluated once. */
7815 tree gnu_input
= gnat_protect_expr (gnu_result
);
7816 tree gnu_cond
= boolean_false_node
;
7817 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
7818 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
7819 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
7820 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
7822 /* Convert the lower bounds to signed types, so we're sure we're
7823 comparing them properly. Likewise, convert the upper bounds
7824 to unsigned types. */
7825 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TYPE_UNSIGNED (gnu_in_basetype
))
7826 gnu_in_lb
= convert (gnat_signed_type (gnu_in_basetype
), gnu_in_lb
);
7828 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
7829 && !TYPE_UNSIGNED (gnu_in_basetype
))
7830 gnu_in_ub
= convert (gnat_unsigned_type (gnu_in_basetype
), gnu_in_ub
);
7832 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
7833 gnu_out_lb
= convert (gnat_signed_type (gnu_base_type
), gnu_out_lb
);
7835 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
7836 gnu_out_ub
= convert (gnat_unsigned_type (gnu_base_type
), gnu_out_ub
);
7838 /* Check each bound separately and only if the result bound
7839 is tighter than the bound on the input type. Note that all the
7840 types are base types, so the bounds must be constant. Also,
7841 the comparison is done in the base type of the input, which
7842 always has the proper signedness. First check for input
7843 integer (which means output integer), output float (which means
7844 both float), or mixed, in which case we always compare.
7845 Note that we have to do the comparison which would *fail* in the
7846 case of an error since if it's an FP comparison and one of the
7847 values is a NaN or Inf, the comparison will fail. */
7848 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
7849 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
7850 : (FLOAT_TYPE_P (gnu_base_type
)
7851 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
7852 TREE_REAL_CST (gnu_out_lb
))
7856 (build_binary_op (GE_EXPR
, boolean_type_node
,
7857 gnu_input
, convert (gnu_in_basetype
,
7860 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
7861 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
7862 : (FLOAT_TYPE_P (gnu_base_type
)
7863 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
7864 TREE_REAL_CST (gnu_in_lb
))
7867 = build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, gnu_cond
,
7869 (build_binary_op (LE_EXPR
, boolean_type_node
,
7871 convert (gnu_in_basetype
,
7874 if (!integer_zerop (gnu_cond
))
7875 gnu_result
= emit_check (gnu_cond
, gnu_input
,
7876 CE_Overflow_Check_Failed
, gnat_node
);
7879 /* Now convert to the result base type. If this is a non-truncating
7880 float-to-integer conversion, round. */
7881 if (INTEGRAL_TYPE_P (gnu_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
7884 REAL_VALUE_TYPE half_minus_pred_half
, pred_half
;
7885 tree gnu_conv
, gnu_zero
, gnu_comp
, calc_type
;
7886 tree gnu_pred_half
, gnu_add_pred_half
, gnu_subtract_pred_half
;
7887 const struct real_format
*fmt
;
7889 /* The following calculations depend on proper rounding to even
7890 of each arithmetic operation. In order to prevent excess
7891 precision from spoiling this property, use the widest hardware
7892 floating-point type if FP_ARITH_MAY_WIDEN is true. */
7894 = FP_ARITH_MAY_WIDEN
? longest_float_type_node
: gnu_in_basetype
;
7896 /* FIXME: Should not have padding in the first place. */
7897 if (TYPE_IS_PADDING_P (calc_type
))
7898 calc_type
= TREE_TYPE (TYPE_FIELDS (calc_type
));
7900 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
7901 fmt
= REAL_MODE_FORMAT (TYPE_MODE (calc_type
));
7902 real_2expN (&half_minus_pred_half
, -(fmt
->p
) - 1, TYPE_MODE (calc_type
));
7903 REAL_ARITHMETIC (pred_half
, MINUS_EXPR
, dconsthalf
,
7904 half_minus_pred_half
);
7905 gnu_pred_half
= build_real (calc_type
, pred_half
);
7907 /* If the input is strictly negative, subtract this value
7908 and otherwise add it from the input. For 0.5, the result
7909 is exactly between 1.0 and the machine number preceding 1.0
7910 (for calc_type). Since the last bit of 1.0 is even, this 0.5
7911 will round to 1.0, while all other number with an absolute
7912 value less than 0.5 round to 0.0. For larger numbers exactly
7913 halfway between integers, rounding will always be correct as
7914 the true mathematical result will be closer to the higher
7915 integer compared to the lower one. So, this constant works
7916 for all floating-point numbers.
7918 The reason to use the same constant with subtract/add instead
7919 of a positive and negative constant is to allow the comparison
7920 to be scheduled in parallel with retrieval of the constant and
7921 conversion of the input to the calc_type (if necessary). */
7923 gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
7924 gnu_result
= gnat_protect_expr (gnu_result
);
7925 gnu_conv
= convert (calc_type
, gnu_result
);
7927 = fold_build2 (GE_EXPR
, boolean_type_node
, gnu_result
, gnu_zero
);
7929 = fold_build2 (PLUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
7930 gnu_subtract_pred_half
7931 = fold_build2 (MINUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
7932 gnu_result
= fold_build3 (COND_EXPR
, calc_type
, gnu_comp
,
7933 gnu_add_pred_half
, gnu_subtract_pred_half
);
7936 if (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
7937 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type
)
7938 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
7939 gnu_result
= unchecked_convert (gnu_base_type
, gnu_result
, false);
7941 gnu_result
= convert (gnu_base_type
, gnu_result
);
7943 /* Finally, do the range check if requested. Note that if the result type
7944 is a modular type, the range check is actually an overflow check. */
7946 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
7947 && TYPE_MODULAR_P (gnu_base_type
) && overflowp
))
7948 gnu_result
= emit_range_check (gnu_result
, gnat_type
, gnat_node
);
7950 return convert (gnu_type
, gnu_result
);
7953 /* Return true if GNU_EXPR can be directly addressed. This is the case
7954 unless it is an expression involving computation or if it involves a
7955 reference to a bitfield or to an object not sufficiently aligned for
7956 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
7957 be directly addressed as an object of this type.
7959 *** Notes on addressability issues in the Ada compiler ***
7961 This predicate is necessary in order to bridge the gap between Gigi
7962 and the middle-end about addressability of GENERIC trees. A tree
7963 is said to be addressable if it can be directly addressed, i.e. if
7964 its address can be taken, is a multiple of the type's alignment on
7965 strict-alignment architectures and returns the first storage unit
7966 assigned to the object represented by the tree.
7968 In the C family of languages, everything is in practice addressable
7969 at the language level, except for bit-fields. This means that these
7970 compilers will take the address of any tree that doesn't represent
7971 a bit-field reference and expect the result to be the first storage
7972 unit assigned to the object. Even in cases where this will result
7973 in unaligned accesses at run time, nothing is supposed to be done
7974 and the program is considered as erroneous instead (see PR c/18287).
7976 The implicit assumptions made in the middle-end are in keeping with
7977 the C viewpoint described above:
7978 - the address of a bit-field reference is supposed to be never
7979 taken; the compiler (generally) will stop on such a construct,
7980 - any other tree is addressable if it is formally addressable,
7981 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
7983 In Ada, the viewpoint is the opposite one: nothing is addressable
7984 at the language level unless explicitly declared so. This means
7985 that the compiler will both make sure that the trees representing
7986 references to addressable ("aliased" in Ada parlance) objects are
7987 addressable and make no real attempts at ensuring that the trees
7988 representing references to non-addressable objects are addressable.
7990 In the first case, Ada is effectively equivalent to C and handing
7991 down the direct result of applying ADDR_EXPR to these trees to the
7992 middle-end works flawlessly. In the second case, Ada cannot afford
7993 to consider the program as erroneous if the address of trees that
7994 are not addressable is requested for technical reasons, unlike C;
7995 as a consequence, the Ada compiler must arrange for either making
7996 sure that this address is not requested in the middle-end or for
7997 compensating by inserting temporaries if it is requested in Gigi.
7999 The first goal can be achieved because the middle-end should not
8000 request the address of non-addressable trees on its own; the only
8001 exception is for the invocation of low-level block operations like
8002 memcpy, for which the addressability requirements are lower since
8003 the type's alignment can be disregarded. In practice, this means
8004 that Gigi must make sure that such operations cannot be applied to
8005 non-BLKmode bit-fields.
8007 The second goal is achieved by means of the addressable_p predicate,
8008 which computes whether a temporary must be inserted by Gigi when the
8009 address of a tree is requested; if so, the address of the temporary
8010 will be used in lieu of that of the original tree and some glue code
8011 generated to connect everything together. */
8014 addressable_p (tree gnu_expr
, tree gnu_type
)
8016 /* For an integral type, the size of the actual type of the object may not
8017 be greater than that of the expected type, otherwise an indirect access
8018 in the latter type wouldn't correctly set all the bits of the object. */
8020 && INTEGRAL_TYPE_P (gnu_type
)
8021 && smaller_form_type_p (gnu_type
, TREE_TYPE (gnu_expr
)))
8024 /* The size of the actual type of the object may not be smaller than that
8025 of the expected type, otherwise an indirect access in the latter type
8026 would be larger than the object. But only record types need to be
8027 considered in practice for this case. */
8029 && TREE_CODE (gnu_type
) == RECORD_TYPE
8030 && smaller_form_type_p (TREE_TYPE (gnu_expr
), gnu_type
))
8033 switch (TREE_CODE (gnu_expr
))
8039 /* All DECLs are addressable: if they are in a register, we can force
8043 case UNCONSTRAINED_ARRAY_REF
:
8045 /* Taking the address of a dereference yields the original pointer. */
8050 /* Taking the address yields a pointer to the constant pool. */
8054 /* Taking the address of a static constructor yields a pointer to the
8055 tree constant pool. */
8056 return TREE_STATIC (gnu_expr
) ? true : false;
8067 /* All rvalues are deemed addressable since taking their address will
8068 force a temporary to be created by the middle-end. */
8072 /* The address of a compound expression is that of its 2nd operand. */
8073 return addressable_p (TREE_OPERAND (gnu_expr
, 1), gnu_type
);
8076 /* We accept &COND_EXPR as soon as both operands are addressable and
8077 expect the outcome to be the address of the selected operand. */
8078 return (addressable_p (TREE_OPERAND (gnu_expr
, 1), NULL_TREE
)
8079 && addressable_p (TREE_OPERAND (gnu_expr
, 2), NULL_TREE
));
8082 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
8083 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
8084 the field is sufficiently aligned, in case it is subject
8085 to a pragma Component_Alignment. But we don't need to
8086 check the alignment of the containing record, as it is
8087 guaranteed to be not smaller than that of its most
8088 aligned field that is not a bit-field. */
8089 && (!STRICT_ALIGNMENT
8090 || DECL_ALIGN (TREE_OPERAND (gnu_expr
, 1))
8091 >= TYPE_ALIGN (TREE_TYPE (gnu_expr
))))
8092 /* The field of a padding record is always addressable. */
8093 || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
8094 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
8096 case ARRAY_REF
: case ARRAY_RANGE_REF
:
8097 case REALPART_EXPR
: case IMAGPART_EXPR
:
8099 return addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
);
8102 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
8103 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
8105 case VIEW_CONVERT_EXPR
:
8107 /* This is addressable if we can avoid a copy. */
8108 tree type
= TREE_TYPE (gnu_expr
);
8109 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
8110 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
8111 && (!STRICT_ALIGNMENT
8112 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
8113 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
8114 || ((TYPE_MODE (type
) == BLKmode
8115 || TYPE_MODE (inner_type
) == BLKmode
)
8116 && (!STRICT_ALIGNMENT
8117 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
8118 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
8119 || TYPE_ALIGN_OK (type
)
8120 || TYPE_ALIGN_OK (inner_type
))))
8121 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
8129 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
8130 a separate Freeze node exists, delay the bulk of the processing. Otherwise
8131 make a GCC type for GNAT_ENTITY and set up the correspondence. */
8134 process_type (Entity_Id gnat_entity
)
8137 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
8140 /* If we are to delay elaboration of this type, just do any
8141 elaborations needed for expressions within the declaration and
8142 make a dummy type entry for this node and its Full_View (if
8143 any) in case something points to it. Don't do this if it
8144 has already been done (the only way that can happen is if
8145 the private completion is also delayed). */
8146 if (Present (Freeze_Node (gnat_entity
))
8147 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
8148 && Present (Full_View (gnat_entity
))
8149 && Freeze_Node (Full_View (gnat_entity
))
8150 && !present_gnu_tree (Full_View (gnat_entity
))))
8152 elaborate_entity (gnat_entity
);
8156 tree gnu_decl
= TYPE_STUB_DECL (make_dummy_type (gnat_entity
));
8157 save_gnu_tree (gnat_entity
, gnu_decl
, false);
8158 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
8159 && Present (Full_View (gnat_entity
)))
8161 if (Has_Completion_In_Body (gnat_entity
))
8162 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
8163 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, false);
8170 /* If we saved away a dummy type for this node it means that this
8171 made the type that corresponds to the full type of an incomplete
8172 type. Clear that type for now and then update the type in the
8176 gcc_assert (TREE_CODE (gnu_old
) == TYPE_DECL
8177 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)));
8179 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
8182 /* Now fully elaborate the type. */
8183 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
8184 gcc_assert (TREE_CODE (gnu_new
) == TYPE_DECL
);
8186 /* If we have an old type and we've made pointers to this type, update those
8187 pointers. If this is a Taft amendment type in the main unit, we need to
8188 mark the type as used since other units referencing it don't see the full
8189 declaration and, therefore, cannot mark it as used themselves. */
8192 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
8193 TREE_TYPE (gnu_new
));
8194 if (DECL_TAFT_TYPE_P (gnu_old
))
8195 used_types_insert (TREE_TYPE (gnu_new
));
8198 /* If this is a record type corresponding to a task or protected type
8199 that is a completion of an incomplete type, perform a similar update
8200 on the type. ??? Including protected types here is a guess. */
8201 if (IN (Ekind (gnat_entity
), Record_Kind
)
8202 && Is_Concurrent_Record_Type (gnat_entity
)
8203 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
8206 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
8208 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
8210 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
8213 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
8214 TREE_TYPE (gnu_new
));
8218 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
8219 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
8220 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
8223 assoc_to_constructor (Entity_Id gnat_entity
, Node_Id gnat_assoc
, tree gnu_type
)
8225 tree gnu_list
= NULL_TREE
, gnu_result
;
8227 /* We test for GNU_FIELD being empty in the case where a variant
8228 was the last thing since we don't take things off GNAT_ASSOC in
8229 that case. We check GNAT_ASSOC in case we have a variant, but it
8232 for (; Present (gnat_assoc
); gnat_assoc
= Next (gnat_assoc
))
8234 Node_Id gnat_field
= First (Choices (gnat_assoc
));
8235 tree gnu_field
= gnat_to_gnu_field_decl (Entity (gnat_field
));
8236 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
8238 /* The expander is supposed to put a single component selector name
8239 in every record component association. */
8240 gcc_assert (No (Next (gnat_field
)));
8242 /* Ignore fields that have Corresponding_Discriminants since we'll
8243 be setting that field in the parent. */
8244 if (Present (Corresponding_Discriminant (Entity (gnat_field
)))
8245 && Is_Tagged_Type (Scope (Entity (gnat_field
))))
8248 /* Also ignore discriminants of Unchecked_Unions. */
8249 if (Is_Unchecked_Union (gnat_entity
)
8250 && Ekind (Entity (gnat_field
)) == E_Discriminant
)
8253 /* Before assigning a value in an aggregate make sure range checks
8254 are done if required. Then convert to the type of the field. */
8255 if (Do_Range_Check (Expression (gnat_assoc
)))
8256 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
), Empty
);
8258 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
8260 /* Add the field and expression to the list. */
8261 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
8264 gnu_result
= extract_values (gnu_list
, gnu_type
);
8266 #ifdef ENABLE_CHECKING
8267 /* Verify that every entry in GNU_LIST was used. */
8268 for (; gnu_list
; gnu_list
= TREE_CHAIN (gnu_list
))
8269 gcc_assert (TREE_ADDRESSABLE (gnu_list
));
8275 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
8276 the first element of an array aggregate. It may itself be an aggregate.
8277 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
8278 GNAT_COMPONENT_TYPE is the type of the array component; it is needed
8279 for range checking. */
8282 pos_to_constructor (Node_Id gnat_expr
, tree gnu_array_type
,
8283 Entity_Id gnat_component_type
)
8285 tree gnu_index
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type
));
8287 VEC(constructor_elt
,gc
) *gnu_expr_vec
= NULL
;
8289 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
8291 /* If the expression is itself an array aggregate then first build the
8292 innermost constructor if it is part of our array (multi-dimensional
8294 if (Nkind (gnat_expr
) == N_Aggregate
8295 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
8296 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
8297 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
8298 TREE_TYPE (gnu_array_type
),
8299 gnat_component_type
);
8302 gnu_expr
= gnat_to_gnu (gnat_expr
);
8304 /* Before assigning the element to the array, make sure it is
8306 if (Do_Range_Check (gnat_expr
))
8307 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
, Empty
);
8310 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec
, gnu_index
,
8311 convert (TREE_TYPE (gnu_array_type
), gnu_expr
));
8313 gnu_index
= int_const_binop (PLUS_EXPR
, gnu_index
, integer_one_node
);
8316 return gnat_build_constructor (gnu_array_type
, gnu_expr_vec
);
8319 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
8320 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
8321 of the associations that are from RECORD_TYPE. If we see an internal
8322 record, make a recursive call to fill it in as well. */
8325 extract_values (tree values
, tree record_type
)
8328 VEC(constructor_elt
,gc
) *v
= NULL
;
8330 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
8334 /* _Parent is an internal field, but may have values in the aggregate,
8335 so check for values first. */
8336 if ((tem
= purpose_member (field
, values
)))
8338 value
= TREE_VALUE (tem
);
8339 TREE_ADDRESSABLE (tem
) = 1;
8342 else if (DECL_INTERNAL_P (field
))
8344 value
= extract_values (values
, TREE_TYPE (field
));
8345 if (TREE_CODE (value
) == CONSTRUCTOR
8346 && VEC_empty (constructor_elt
, CONSTRUCTOR_ELTS (value
)))
8350 /* If we have a record subtype, the names will match, but not the
8351 actual FIELD_DECLs. */
8352 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
8353 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
8355 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
8356 TREE_ADDRESSABLE (tem
) = 1;
8362 CONSTRUCTOR_APPEND_ELT (v
, field
, value
);
8365 return gnat_build_constructor (record_type
, v
);
8368 /* EXP is to be treated as an array or record. Handle the cases when it is
8369 an access object and perform the required dereferences. */
8372 maybe_implicit_deref (tree exp
)
8374 /* If the type is a pointer, dereference it. */
8375 if (POINTER_TYPE_P (TREE_TYPE (exp
))
8376 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp
)))
8377 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
8379 /* If we got a padded type, remove it too. */
8380 if (TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
8381 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
8386 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
8387 location and false if it doesn't. In the former case, set the Gigi global
8388 variable REF_FILENAME to the simple debug file name as given by sinput. */
8391 Sloc_to_locus (Source_Ptr Sloc
, location_t
*locus
)
8393 if (Sloc
== No_Location
)
8396 if (Sloc
<= Standard_Location
)
8398 *locus
= BUILTINS_LOCATION
;
8403 Source_File_Index file
= Get_Source_File_Index (Sloc
);
8404 Logical_Line_Number line
= Get_Logical_Line_Number (Sloc
);
8405 Column_Number column
= Get_Column_Number (Sloc
);
8406 struct line_map
*map
= LINEMAPS_ORDINARY_MAP_AT (line_table
, file
- 1);
8408 /* We can have zero if pragma Source_Reference is in effect. */
8412 /* Translate the location. */
8413 *locus
= linemap_position_for_line_and_column (map
, line
, column
);
8417 = IDENTIFIER_POINTER
8419 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc
)))));;
8424 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
8425 don't do anything if it doesn't correspond to a source location. */
8428 set_expr_location_from_node (tree node
, Node_Id gnat_node
)
8432 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
))
8435 SET_EXPR_LOCATION (node
, locus
);
8438 /* More elaborate version of set_expr_location_from_node to be used in more
8439 general contexts, for example the result of the translation of a generic
8443 set_gnu_expr_location_from_node (tree node
, Node_Id gnat_node
)
8445 /* Set the location information on the node if it is a real expression.
8446 References can be reused for multiple GNAT nodes and they would get
8447 the location information of their last use. Also make sure not to
8448 overwrite an existing location as it is probably more precise. */
8450 switch (TREE_CODE (node
))
8453 case NON_LVALUE_EXPR
:
8457 if (EXPR_P (TREE_OPERAND (node
, 1)))
8458 set_gnu_expr_location_from_node (TREE_OPERAND (node
, 1), gnat_node
);
8460 /* ... fall through ... */
8463 if (!REFERENCE_CLASS_P (node
) && !EXPR_HAS_LOCATION (node
))
8465 set_expr_location_from_node (node
, gnat_node
);
8466 set_end_locus_from_node (node
, gnat_node
);
8472 /* Return a colon-separated list of encodings contained in encoded Ada
8476 extract_encoding (const char *name
)
8478 char *encoding
= (char *) ggc_alloc_atomic (strlen (name
));
8479 get_encoding (name
, encoding
);
8483 /* Extract the Ada name from an encoded name. */
8486 decode_name (const char *name
)
8488 char *decoded
= (char *) ggc_alloc_atomic (strlen (name
) * 2 + 60);
8489 __gnat_decode (name
, decoded
, 0);
8493 /* Post an error message. MSG is the error message, properly annotated.
8494 NODE is the node at which to post the error and the node to use for the
8495 '&' substitution. */
8498 post_error (const char *msg
, Node_Id node
)
8500 String_Template temp
;
8503 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
8504 fp
.Array
= msg
, fp
.Bounds
= &temp
;
8506 Error_Msg_N (fp
, node
);
8509 /* Similar to post_error, but NODE is the node at which to post the error and
8510 ENT is the node to use for the '&' substitution. */
8513 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
8515 String_Template temp
;
8518 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
8519 fp
.Array
= msg
, fp
.Bounds
= &temp
;
8521 Error_Msg_NE (fp
, node
, ent
);
8524 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
8527 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int num
)
8529 Error_Msg_Uint_1
= UI_From_Int (num
);
8530 post_error_ne (msg
, node
, ent
);
8533 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
8534 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
8535 most sense. Return true if a sensible assignment was performed. */
8538 set_end_locus_from_node (tree gnu_node
, Node_Id gnat_node
)
8540 Node_Id gnat_end_label
= Empty
;
8541 location_t end_locus
;
8543 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
8544 end_locus when there is one. We consider only GNAT nodes with a possible
8545 End_Label attached. If the End_Label actually was unassigned, fallback
8546 on the orginal node. We'd better assign an explicit sloc associated with
8547 the outer construct in any case. */
8549 switch (Nkind (gnat_node
))
8551 case N_Package_Body
:
8552 case N_Subprogram_Body
:
8553 case N_Block_Statement
:
8554 gnat_end_label
= End_Label (Handled_Statement_Sequence (gnat_node
));
8557 case N_Package_Declaration
:
8558 gnat_end_label
= End_Label (Specification (gnat_node
));
8565 gnat_node
= Present (gnat_end_label
) ? gnat_end_label
: gnat_node
;
8567 /* Some expanded subprograms have neither an End_Label nor a Sloc
8568 attached. Notify that to callers. */
8570 if (!Sloc_to_locus (Sloc (gnat_node
), &end_locus
))
8573 switch (TREE_CODE (gnu_node
))
8576 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node
)) = end_locus
;
8580 DECL_STRUCT_FUNCTION (gnu_node
)->function_end_locus
= end_locus
;
8588 /* Similar to post_error_ne, but T is a GCC tree representing the number to
8589 write. If T represents a constant, the text inside curly brackets in
8590 MSG will be output (presumably including a '^'). Otherwise it will not
8591 be output and the text inside square brackets will be output instead. */
8594 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
8596 char *new_msg
= XALLOCAVEC (char, strlen (msg
) + 1);
8597 char start_yes
, end_yes
, start_no
, end_no
;
8601 if (TREE_CODE (t
) == INTEGER_CST
)
8603 Error_Msg_Uint_1
= UI_From_gnu (t
);
8604 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
8607 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
8609 for (p
= msg
, q
= new_msg
; *p
; p
++)
8611 if (*p
== start_yes
)
8612 for (p
++; *p
!= end_yes
; p
++)
8614 else if (*p
== start_no
)
8615 for (p
++; *p
!= end_no
; p
++)
8623 post_error_ne (new_msg
, node
, ent
);
8626 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
8629 post_error_ne_tree_2 (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
,
8632 Error_Msg_Uint_2
= UI_From_Int (num
);
8633 post_error_ne_tree (msg
, node
, ent
, t
);
8636 /* Initialize the table that maps GNAT codes to GCC codes for simple
8637 binary and unary operations. */
8640 init_code_table (void)
8642 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
8643 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
8645 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
8646 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
8647 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
8648 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
8649 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
8650 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
8651 gnu_codes
[N_Op_Le
] = LE_EXPR
;
8652 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
8653 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
8654 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
8655 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
8656 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
8657 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
8658 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
8659 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
8660 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
8661 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
8662 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
8663 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
8664 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
8665 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
8666 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
8669 /* Return a label to branch to for the exception type in KIND or NULL_TREE
8673 get_exception_label (char kind
)
8675 if (kind
== N_Raise_Constraint_Error
)
8676 return VEC_last (tree
, gnu_constraint_error_label_stack
);
8677 else if (kind
== N_Raise_Storage_Error
)
8678 return VEC_last (tree
, gnu_storage_error_label_stack
);
8679 else if (kind
== N_Raise_Program_Error
)
8680 return VEC_last (tree
, gnu_program_error_label_stack
);
8685 /* Return the decl for the current elaboration procedure. */
8688 get_elaboration_procedure (void)
8690 return VEC_last (tree
, gnu_elab_proc_stack
);
8693 #include "gt-ada-trans.h"