* fe.h (Set_Present_Expr): Move around.
[official-gcc.git] / gcc / ada / gcc-interface / trans.c
blob581c57f93a4357e86f3bff22ec85bba100096e12
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * T R A N S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2014, Free Software Foundation, Inc. *
10 * *
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/>. *
20 * *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
23 * *
24 ****************************************************************************/
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "tm.h"
30 #include "tree.h"
31 #include "stringpool.h"
32 #include "stor-layout.h"
33 #include "stmt.h"
34 #include "varasm.h"
35 #include "flags.h"
36 #include "output.h"
37 #include "libfuncs.h" /* For set_stack_check_libfunc. */
38 #include "tree-iterator.h"
39 #include "pointer-set.h"
40 #include "gimple-expr.h"
41 #include "gimplify.h"
42 #include "bitmap.h"
43 #include "cgraph.h"
44 #include "diagnostic.h"
45 #include "opts.h"
46 #include "target.h"
47 #include "common/common-target.h"
49 #include "ada.h"
50 #include "adadecode.h"
51 #include "types.h"
52 #include "atree.h"
53 #include "elists.h"
54 #include "namet.h"
55 #include "nlists.h"
56 #include "snames.h"
57 #include "stringt.h"
58 #include "uintp.h"
59 #include "urealp.h"
60 #include "fe.h"
61 #include "sinfo.h"
62 #include "einfo.h"
63 #include "gadaint.h"
64 #include "ada-tree.h"
65 #include "gigi.h"
67 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
68 for fear of running out of stack space. If we need more, we use xmalloc
69 instead. */
70 #define ALLOCA_THRESHOLD 1000
72 /* In configurations where blocks have no end_locus attached, just
73 sink assignments into a dummy global. */
74 #ifndef BLOCK_SOURCE_END_LOCATION
75 static location_t block_end_locus_sink;
76 #define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink
77 #endif
79 /* For efficient float-to-int rounding, it is necessary to know whether
80 floating-point arithmetic may use wider intermediate results. When
81 FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
82 that arithmetic does not widen if double precision is emulated. */
83 #ifndef FP_ARITH_MAY_WIDEN
84 #if defined(HAVE_extendsfdf2)
85 #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
86 #else
87 #define FP_ARITH_MAY_WIDEN 0
88 #endif
89 #endif
91 /* Pointers to front-end tables accessed through macros. */
92 struct Node *Nodes_Ptr;
93 struct Flags *Flags_Ptr;
94 Node_Id *Next_Node_Ptr;
95 Node_Id *Prev_Node_Ptr;
96 struct Elist_Header *Elists_Ptr;
97 struct Elmt_Item *Elmts_Ptr;
98 struct String_Entry *Strings_Ptr;
99 Char_Code *String_Chars_Ptr;
100 struct List_Header *List_Headers_Ptr;
102 /* Highest number in the front-end node table. */
103 int max_gnat_nodes;
105 /* Current node being treated, in case abort called. */
106 Node_Id error_gnat_node;
108 /* True when gigi is being called on an analyzed but unexpanded
109 tree, and the only purpose of the call is to properly annotate
110 types with representation information. */
111 bool type_annotate_only;
113 /* Current filename without path. */
114 const char *ref_filename;
117 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
118 static vec<Node_Id> gnat_validate_uc_list;
120 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
121 of unconstrained array IN parameters to avoid emitting a great deal of
122 redundant instructions to recompute them each time. */
123 struct GTY (()) parm_attr_d {
124 int id; /* GTY doesn't like Entity_Id. */
125 int dim;
126 tree first;
127 tree last;
128 tree length;
131 typedef struct parm_attr_d *parm_attr;
134 struct GTY(()) language_function {
135 vec<parm_attr, va_gc> *parm_attr_cache;
136 bitmap named_ret_val;
137 vec<tree, va_gc> *other_ret_val;
138 int gnat_ret;
141 #define f_parm_attr_cache \
142 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
144 #define f_named_ret_val \
145 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
147 #define f_other_ret_val \
148 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
150 #define f_gnat_ret \
151 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
153 /* A structure used to gather together information about a statement group.
154 We use this to gather related statements, for example the "then" part
155 of a IF. In the case where it represents a lexical scope, we may also
156 have a BLOCK node corresponding to it and/or cleanups. */
158 struct GTY((chain_next ("%h.previous"))) stmt_group {
159 struct stmt_group *previous; /* Previous code group. */
160 tree stmt_list; /* List of statements for this code group. */
161 tree block; /* BLOCK for this code group, if any. */
162 tree cleanups; /* Cleanups for this code group, if any. */
165 static GTY(()) struct stmt_group *current_stmt_group;
167 /* List of unused struct stmt_group nodes. */
168 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
170 /* A structure used to record information on elaboration procedures
171 we've made and need to process.
173 ??? gnat_node should be Node_Id, but gengtype gets confused. */
175 struct GTY((chain_next ("%h.next"))) elab_info {
176 struct elab_info *next; /* Pointer to next in chain. */
177 tree elab_proc; /* Elaboration procedure. */
178 int gnat_node; /* The N_Compilation_Unit. */
181 static GTY(()) struct elab_info *elab_info_list;
183 /* Stack of exception pointer variables. Each entry is the VAR_DECL
184 that stores the address of the raised exception. Nonzero means we
185 are in an exception handler. Not used in the zero-cost case. */
186 static GTY(()) vec<tree, va_gc> *gnu_except_ptr_stack;
188 /* In ZCX case, current exception pointer. Used to re-raise it. */
189 static GTY(()) tree gnu_incoming_exc_ptr;
191 /* Stack for storing the current elaboration procedure decl. */
192 static GTY(()) vec<tree, va_gc> *gnu_elab_proc_stack;
194 /* Stack of labels to be used as a goto target instead of a return in
195 some functions. See processing for N_Subprogram_Body. */
196 static GTY(()) vec<tree, va_gc> *gnu_return_label_stack;
198 /* Stack of variable for the return value of a function with copy-in/copy-out
199 parameters. See processing for N_Subprogram_Body. */
200 static GTY(()) vec<tree, va_gc> *gnu_return_var_stack;
202 /* Structure used to record information for a range check. */
203 struct GTY(()) range_check_info_d {
204 tree low_bound;
205 tree high_bound;
206 tree type;
207 tree invariant_cond;
210 typedef struct range_check_info_d *range_check_info;
213 /* Structure used to record information for a loop. */
214 struct GTY(()) loop_info_d {
215 tree stmt;
216 tree loop_var;
217 vec<range_check_info, va_gc> *checks;
220 typedef struct loop_info_d *loop_info;
223 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
224 static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
226 /* The stacks for N_{Push,Pop}_*_Label. */
227 static GTY(()) vec<tree, va_gc> *gnu_constraint_error_label_stack;
228 static GTY(()) vec<tree, va_gc> *gnu_storage_error_label_stack;
229 static GTY(()) vec<tree, va_gc> *gnu_program_error_label_stack;
231 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
232 static enum tree_code gnu_codes[Number_Node_Kinds];
234 static void init_code_table (void);
235 static void Compilation_Unit_to_gnu (Node_Id);
236 static void record_code_position (Node_Id);
237 static void insert_code_for (Node_Id);
238 static void add_cleanup (tree, Node_Id);
239 static void add_stmt_list (List_Id);
240 static void push_exception_label_stack (vec<tree, va_gc> **, Entity_Id);
241 static tree build_stmt_group (List_Id, bool);
242 static inline bool stmt_group_may_fallthru (void);
243 static enum gimplify_status gnat_gimplify_stmt (tree *);
244 static void elaborate_all_entities (Node_Id);
245 static void process_freeze_entity (Node_Id);
246 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
247 static tree emit_range_check (tree, Node_Id, Node_Id);
248 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
249 static tree emit_check (tree, tree, int, Node_Id);
250 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
251 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
252 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
253 static bool addressable_p (tree, tree);
254 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
255 static tree extract_values (tree, tree);
256 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
257 static void validate_unchecked_conversion (Node_Id);
258 static tree maybe_implicit_deref (tree);
259 static void set_expr_location_from_node (tree, Node_Id);
260 static void set_expr_location_from_node1 (tree, Node_Id, bool);
261 static bool Sloc_to_locus1 (Source_Ptr, location_t *, bool);
262 static bool set_end_locus_from_node (tree, Node_Id);
263 static void set_gnu_expr_location_from_node (tree, Node_Id);
264 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
265 static tree build_raise_check (int, enum exception_info_kind);
266 static tree create_init_temporary (const char *, tree, tree *, Node_Id);
268 /* Hooks for debug info back-ends, only supported and used in a restricted set
269 of configurations. */
270 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
271 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
273 /* This is the main program of the back-end. It sets up all the table
274 structures and then generates code. */
276 void
277 gigi (Node_Id gnat_root,
278 int max_gnat_node,
279 int number_name ATTRIBUTE_UNUSED,
280 struct Node *nodes_ptr,
281 struct Flags *flags_ptr,
282 Node_Id *next_node_ptr,
283 Node_Id *prev_node_ptr,
284 struct Elist_Header *elists_ptr,
285 struct Elmt_Item *elmts_ptr,
286 struct String_Entry *strings_ptr,
287 Char_Code *string_chars_ptr,
288 struct List_Header *list_headers_ptr,
289 Nat number_file,
290 struct File_Info_Type *file_info_ptr,
291 Entity_Id standard_boolean,
292 Entity_Id standard_integer,
293 Entity_Id standard_character,
294 Entity_Id standard_long_long_float,
295 Entity_Id standard_exception_type,
296 Int gigi_operating_mode)
298 Node_Id gnat_iter;
299 Entity_Id gnat_literal;
300 tree long_long_float_type, exception_type, t, ftype;
301 tree int64_type = gnat_type_for_size (64, 0);
302 struct elab_info *info;
303 int i;
305 max_gnat_nodes = max_gnat_node;
307 Nodes_Ptr = nodes_ptr;
308 Flags_Ptr = flags_ptr;
309 Next_Node_Ptr = next_node_ptr;
310 Prev_Node_Ptr = prev_node_ptr;
311 Elists_Ptr = elists_ptr;
312 Elmts_Ptr = elmts_ptr;
313 Strings_Ptr = strings_ptr;
314 String_Chars_Ptr = string_chars_ptr;
315 List_Headers_Ptr = list_headers_ptr;
317 type_annotate_only = (gigi_operating_mode == 1);
319 #if TARGET_ABI_OPEN_VMS
320 vms_float_format = Float_Format;
321 #endif
323 for (i = 0; i < number_file; i++)
325 /* Use the identifier table to make a permanent copy of the filename as
326 the name table gets reallocated after Gigi returns but before all the
327 debugging information is output. The __gnat_to_canonical_file_spec
328 call translates filenames from pragmas Source_Reference that contain
329 host style syntax not understood by gdb. */
330 const char *filename
331 = IDENTIFIER_POINTER
332 (get_identifier
333 (__gnat_to_canonical_file_spec
334 (Get_Name_String (file_info_ptr[i].File_Name))));
336 /* We rely on the order isomorphism between files and line maps. */
337 gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i);
339 /* We create the line map for a source file at once, with a fixed number
340 of columns chosen to avoid jumping over the next power of 2. */
341 linemap_add (line_table, LC_ENTER, 0, filename, 1);
342 linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
343 linemap_position_for_column (line_table, 252 - 1);
344 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
347 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
349 /* Declare the name of the compilation unit as the first global
350 name in order to make the middle-end fully deterministic. */
351 t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
352 first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
354 /* Initialize ourselves. */
355 init_code_table ();
356 init_gnat_decl ();
357 init_gnat_utils ();
359 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
360 errors. */
361 if (type_annotate_only)
363 TYPE_SIZE (void_type_node) = bitsize_zero_node;
364 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
367 /* Enable GNAT stack checking method if needed */
368 if (!Stack_Check_Probes_On_Target)
369 set_stack_check_libfunc ("_gnat_stack_check");
371 /* Retrieve alignment settings. */
372 double_float_alignment = get_target_double_float_alignment ();
373 double_scalar_alignment = get_target_double_scalar_alignment ();
375 /* Record the builtin types. Define `integer' and `character' first so that
376 dbx will output them first. */
377 record_builtin_type ("integer", integer_type_node, false);
378 record_builtin_type ("character", unsigned_char_type_node, false);
379 record_builtin_type ("boolean", boolean_type_node, false);
380 record_builtin_type ("void", void_type_node, false);
382 /* Save the type we made for integer as the type for Standard.Integer. */
383 save_gnu_tree (Base_Type (standard_integer),
384 TYPE_NAME (integer_type_node),
385 false);
387 /* Likewise for character as the type for Standard.Character. */
388 save_gnu_tree (Base_Type (standard_character),
389 TYPE_NAME (unsigned_char_type_node),
390 false);
392 /* Likewise for boolean as the type for Standard.Boolean. */
393 save_gnu_tree (Base_Type (standard_boolean),
394 TYPE_NAME (boolean_type_node),
395 false);
396 gnat_literal = First_Literal (Base_Type (standard_boolean));
397 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
398 gcc_assert (t == boolean_false_node);
399 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
400 boolean_type_node, t, true, false, false, false,
401 NULL, gnat_literal);
402 DECL_IGNORED_P (t) = 1;
403 save_gnu_tree (gnat_literal, t, false);
404 gnat_literal = Next_Literal (gnat_literal);
405 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
406 gcc_assert (t == boolean_true_node);
407 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
408 boolean_type_node, t, true, false, false, false,
409 NULL, gnat_literal);
410 DECL_IGNORED_P (t) = 1;
411 save_gnu_tree (gnat_literal, t, false);
413 void_ftype = build_function_type_list (void_type_node, NULL_TREE);
414 ptr_void_ftype = build_pointer_type (void_ftype);
416 /* Now declare run-time functions. */
417 ftype = build_function_type_list (ptr_void_type_node, sizetype, NULL_TREE);
419 /* malloc is a function declaration tree for a function to allocate
420 memory. */
421 malloc_decl
422 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
423 ftype, NULL_TREE, is_disabled, true, true, true,
424 NULL, Empty);
425 DECL_IS_MALLOC (malloc_decl) = 1;
427 /* malloc32 is a function declaration tree for a function to allocate
428 32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */
429 malloc32_decl
430 = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
431 ftype, NULL_TREE, is_disabled, true, true, true,
432 NULL, Empty);
433 DECL_IS_MALLOC (malloc32_decl) = 1;
435 /* free is a function declaration tree for a function to free memory. */
436 free_decl
437 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
438 build_function_type_list (void_type_node,
439 ptr_void_type_node,
440 NULL_TREE),
441 NULL_TREE, is_disabled, true, true, true, NULL,
442 Empty);
444 /* This is used for 64-bit multiplication with overflow checking. */
445 mulv64_decl
446 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
447 build_function_type_list (int64_type, int64_type,
448 int64_type, NULL_TREE),
449 NULL_TREE, is_disabled, true, true, true, NULL,
450 Empty);
452 /* Name of the _Parent field in tagged record types. */
453 parent_name_id = get_identifier (Get_Name_String (Name_uParent));
455 /* Name of the Exception_Data type defined in System.Standard_Library. */
456 exception_data_name_id
457 = get_identifier ("system__standard_library__exception_data");
459 /* Make the types and functions used for exception processing. */
460 jmpbuf_type
461 = build_array_type (gnat_type_for_mode (Pmode, 0),
462 build_index_type (size_int (5)));
463 record_builtin_type ("JMPBUF_T", jmpbuf_type, true);
464 jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
466 /* Functions to get and set the jumpbuf pointer for the current thread. */
467 get_jmpbuf_decl
468 = create_subprog_decl
469 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
470 NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
471 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
472 DECL_IGNORED_P (get_jmpbuf_decl) = 1;
474 set_jmpbuf_decl
475 = create_subprog_decl
476 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
477 NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
478 NULL_TREE),
479 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
480 DECL_IGNORED_P (set_jmpbuf_decl) = 1;
482 /* setjmp returns an integer and has one operand, which is a pointer to
483 a jmpbuf. */
484 setjmp_decl
485 = create_subprog_decl
486 (get_identifier ("__builtin_setjmp"), NULL_TREE,
487 build_function_type_list (integer_type_node, jmpbuf_ptr_type,
488 NULL_TREE),
489 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
490 DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
491 DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
493 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
494 address. */
495 update_setjmp_buf_decl
496 = create_subprog_decl
497 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
498 build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
499 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
500 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
501 DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
503 /* Hooks to call when entering/leaving an exception handler. */
504 ftype
505 = build_function_type_list (void_type_node, ptr_void_type_node, NULL_TREE);
507 begin_handler_decl
508 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
509 ftype, NULL_TREE, is_disabled, true, true, true,
510 NULL, Empty);
511 DECL_IGNORED_P (begin_handler_decl) = 1;
513 end_handler_decl
514 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
515 ftype, NULL_TREE, is_disabled, true, true, true,
516 NULL, Empty);
517 DECL_IGNORED_P (end_handler_decl) = 1;
519 unhandled_except_decl
520 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
521 NULL_TREE,
522 ftype, NULL_TREE, is_disabled, true, true, true,
523 NULL, Empty);
524 DECL_IGNORED_P (unhandled_except_decl) = 1;
526 reraise_zcx_decl
527 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
528 ftype, NULL_TREE, is_disabled, true, true, true,
529 NULL, Empty);
530 /* Indicate that these never return. */
531 DECL_IGNORED_P (reraise_zcx_decl) = 1;
532 TREE_THIS_VOLATILE (reraise_zcx_decl) = 1;
533 TREE_SIDE_EFFECTS (reraise_zcx_decl) = 1;
534 TREE_TYPE (reraise_zcx_decl)
535 = build_qualified_type (TREE_TYPE (reraise_zcx_decl), TYPE_QUAL_VOLATILE);
537 /* If in no exception handlers mode, all raise statements are redirected to
538 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
539 this procedure will never be called in this mode. */
540 if (No_Exception_Handlers_Set ())
542 tree decl
543 = create_subprog_decl
544 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
545 build_function_type_list (void_type_node,
546 build_pointer_type
547 (unsigned_char_type_node),
548 integer_type_node, NULL_TREE),
549 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
550 TREE_THIS_VOLATILE (decl) = 1;
551 TREE_SIDE_EFFECTS (decl) = 1;
552 TREE_TYPE (decl)
553 = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
554 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
555 gnat_raise_decls[i] = decl;
557 else
559 /* Otherwise, make one decl for each exception reason. */
560 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
561 gnat_raise_decls[i] = build_raise_check (i, exception_simple);
562 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
563 gnat_raise_decls_ext[i]
564 = build_raise_check (i,
565 i == CE_Index_Check_Failed
566 || i == CE_Range_Check_Failed
567 || i == CE_Invalid_Data
568 ? exception_range : exception_column);
571 /* Set the types that GCC and Gigi use from the front end. */
572 exception_type
573 = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
574 except_type_node = TREE_TYPE (exception_type);
576 /* Make other functions used for exception processing. */
577 get_excptr_decl
578 = create_subprog_decl
579 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
580 build_function_type_list (build_pointer_type (except_type_node),
581 NULL_TREE),
582 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
583 DECL_IGNORED_P (get_excptr_decl) = 1;
585 set_exception_parameter_decl
586 = create_subprog_decl
587 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
588 build_function_type_list (void_type_node,
589 ptr_void_type_node,
590 ptr_void_type_node,
591 NULL_TREE),
592 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
594 raise_nodefer_decl
595 = create_subprog_decl
596 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
597 build_function_type_list (void_type_node,
598 build_pointer_type (except_type_node),
599 NULL_TREE),
600 NULL_TREE, is_disabled, true, true, true, NULL, Empty);
602 /* Indicate that it never returns. */
603 TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
604 TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
605 TREE_TYPE (raise_nodefer_decl)
606 = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
607 TYPE_QUAL_VOLATILE);
609 /* Build the special descriptor type and its null node if needed. */
610 if (TARGET_VTABLE_USES_DESCRIPTORS)
612 tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
613 tree field_list = NULL_TREE;
614 int j;
615 vec<constructor_elt, va_gc> *null_vec = NULL;
616 constructor_elt *elt;
618 fdesc_type_node = make_node (RECORD_TYPE);
619 vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS);
620 elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
622 for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
624 tree field
625 = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
626 NULL_TREE, NULL_TREE, 0, 1);
627 DECL_CHAIN (field) = field_list;
628 field_list = field;
629 elt->index = field;
630 elt->value = null_node;
631 elt--;
634 finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
635 record_builtin_type ("descriptor", fdesc_type_node, true);
636 null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
639 long_long_float_type
640 = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
642 if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
644 /* In this case, the builtin floating point types are VAX float,
645 so make up a type for use. */
646 longest_float_type_node = make_node (REAL_TYPE);
647 TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
648 layout_type (longest_float_type_node);
649 record_builtin_type ("longest float type", longest_float_type_node,
650 false);
652 else
653 longest_float_type_node = TREE_TYPE (long_long_float_type);
655 /* Dummy objects to materialize "others" and "all others" in the exception
656 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
657 the types to use. */
658 others_decl
659 = create_var_decl (get_identifier ("OTHERS"),
660 get_identifier ("__gnat_others_value"),
661 unsigned_char_type_node,
662 NULL_TREE, true, false, true, false, NULL, Empty);
664 all_others_decl
665 = create_var_decl (get_identifier ("ALL_OTHERS"),
666 get_identifier ("__gnat_all_others_value"),
667 unsigned_char_type_node,
668 NULL_TREE, true, false, true, false, NULL, Empty);
670 unhandled_others_decl
671 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
672 get_identifier ("__gnat_unhandled_others_value"),
673 unsigned_char_type_node,
674 NULL_TREE, true, false, true, false, NULL, Empty);
676 main_identifier_node = get_identifier ("main");
678 /* Install the builtins we might need, either internally or as
679 user available facilities for Intrinsic imports. */
680 gnat_install_builtins ();
682 vec_safe_push (gnu_except_ptr_stack, NULL_TREE);
683 vec_safe_push (gnu_constraint_error_label_stack, NULL_TREE);
684 vec_safe_push (gnu_storage_error_label_stack, NULL_TREE);
685 vec_safe_push (gnu_program_error_label_stack, NULL_TREE);
687 /* Process any Pragma Ident for the main unit. */
688 if (Present (Ident_String (Main_Unit)))
689 targetm.asm_out.output_ident
690 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
692 /* If we are using the GCC exception mechanism, let GCC know. */
693 if (Exception_Mechanism == Back_End_Exceptions)
694 gnat_init_gcc_eh ();
696 /* Initialize the GCC support for FP operations. */
697 gnat_init_gcc_fp ();
699 /* Now translate the compilation unit proper. */
700 Compilation_Unit_to_gnu (gnat_root);
702 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
703 the very end to avoid having to second-guess the front-end when we run
704 into dummy nodes during the regular processing. */
705 for (i = 0; gnat_validate_uc_list.iterate (i, &gnat_iter); i++)
706 validate_unchecked_conversion (gnat_iter);
707 gnat_validate_uc_list.release ();
709 /* Finally see if we have any elaboration procedures to deal with. */
710 for (info = elab_info_list; info; info = info->next)
712 tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
714 /* We should have a BIND_EXPR but it may not have any statements in it.
715 If it doesn't have any, we have nothing to do except for setting the
716 flag on the GNAT node. Otherwise, process the function as others. */
717 gnu_stmts = gnu_body;
718 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
719 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
720 if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
721 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
722 else
724 begin_subprog_body (info->elab_proc);
725 end_subprog_body (gnu_body);
726 rest_of_subprog_body_compilation (info->elab_proc);
730 /* Destroy ourselves. */
731 destroy_gnat_decl ();
732 destroy_gnat_utils ();
734 /* We cannot track the location of errors past this point. */
735 error_gnat_node = Empty;
738 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
739 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
741 static tree
742 build_raise_check (int check, enum exception_info_kind kind)
744 tree result, ftype;
745 const char pfx[] = "__gnat_rcheck_";
747 strcpy (Name_Buffer, pfx);
748 Name_Len = sizeof (pfx) - 1;
749 Get_RT_Exception_Name (check);
751 if (kind == exception_simple)
753 Name_Buffer[Name_Len] = 0;
754 ftype
755 = build_function_type_list (void_type_node,
756 build_pointer_type
757 (unsigned_char_type_node),
758 integer_type_node, NULL_TREE);
760 else
762 tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
764 strcpy (Name_Buffer + Name_Len, "_ext");
765 Name_Buffer[Name_Len + 4] = 0;
766 ftype
767 = build_function_type_list (void_type_node,
768 build_pointer_type
769 (unsigned_char_type_node),
770 integer_type_node, integer_type_node,
771 t, t, NULL_TREE);
774 result
775 = create_subprog_decl (get_identifier (Name_Buffer),
776 NULL_TREE, ftype, NULL_TREE,
777 is_disabled, true, true, true, NULL, Empty);
779 /* Indicate that it never returns. */
780 TREE_THIS_VOLATILE (result) = 1;
781 TREE_SIDE_EFFECTS (result) = 1;
782 TREE_TYPE (result)
783 = build_qualified_type (TREE_TYPE (result), TYPE_QUAL_VOLATILE);
785 return result;
788 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
789 an N_Attribute_Reference. */
791 static int
792 lvalue_required_for_attribute_p (Node_Id gnat_node)
794 switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
796 case Attr_Pos:
797 case Attr_Val:
798 case Attr_Pred:
799 case Attr_Succ:
800 case Attr_First:
801 case Attr_Last:
802 case Attr_Range_Length:
803 case Attr_Length:
804 case Attr_Object_Size:
805 case Attr_Value_Size:
806 case Attr_Component_Size:
807 case Attr_Max_Size_In_Storage_Elements:
808 case Attr_Min:
809 case Attr_Max:
810 case Attr_Null_Parameter:
811 case Attr_Passed_By_Reference:
812 case Attr_Mechanism_Code:
813 return 0;
815 case Attr_Address:
816 case Attr_Access:
817 case Attr_Unchecked_Access:
818 case Attr_Unrestricted_Access:
819 case Attr_Code_Address:
820 case Attr_Pool_Address:
821 case Attr_Size:
822 case Attr_Alignment:
823 case Attr_Bit_Position:
824 case Attr_Position:
825 case Attr_First_Bit:
826 case Attr_Last_Bit:
827 case Attr_Bit:
828 case Attr_Asm_Input:
829 case Attr_Asm_Output:
830 default:
831 return 1;
835 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
836 is the type that will be used for GNAT_NODE in the translated GNU tree.
837 CONSTANT indicates whether the underlying object represented by GNAT_NODE
838 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
839 whether its value is the address of a constant and ALIASED whether it is
840 aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
842 The function climbs up the GNAT tree starting from the node and returns 1
843 upon encountering a node that effectively requires an lvalue downstream.
844 It returns int instead of bool to facilitate usage in non-purely binary
845 logic contexts. */
847 static int
848 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
849 bool address_of_constant, bool aliased)
851 Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
853 switch (Nkind (gnat_parent))
855 case N_Reference:
856 return 1;
858 case N_Attribute_Reference:
859 return lvalue_required_for_attribute_p (gnat_parent);
861 case N_Parameter_Association:
862 case N_Function_Call:
863 case N_Procedure_Call_Statement:
864 /* If the parameter is by reference, an lvalue is required. */
865 return (!constant
866 || must_pass_by_ref (gnu_type)
867 || default_pass_by_ref (gnu_type));
869 case N_Indexed_Component:
870 /* Only the array expression can require an lvalue. */
871 if (Prefix (gnat_parent) != gnat_node)
872 return 0;
874 /* ??? Consider that referencing an indexed component with a
875 non-constant index forces the whole aggregate to memory.
876 Note that N_Integer_Literal is conservative, any static
877 expression in the RM sense could probably be accepted. */
878 for (gnat_temp = First (Expressions (gnat_parent));
879 Present (gnat_temp);
880 gnat_temp = Next (gnat_temp))
881 if (Nkind (gnat_temp) != N_Integer_Literal)
882 return 1;
884 /* ... fall through ... */
886 case N_Slice:
887 /* Only the array expression can require an lvalue. */
888 if (Prefix (gnat_parent) != gnat_node)
889 return 0;
891 aliased |= Has_Aliased_Components (Etype (gnat_node));
892 return lvalue_required_p (gnat_parent, gnu_type, constant,
893 address_of_constant, aliased);
895 case N_Selected_Component:
896 aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
897 return lvalue_required_p (gnat_parent, gnu_type, constant,
898 address_of_constant, aliased);
900 case N_Object_Renaming_Declaration:
901 /* We need to preserve addresses through a renaming. */
902 return 1;
904 case N_Object_Declaration:
905 /* We cannot use a constructor if this is an atomic object because
906 the actual assignment might end up being done component-wise. */
907 return (!constant
908 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
909 && Is_Atomic (Defining_Entity (gnat_parent)))
910 /* We don't use a constructor if this is a class-wide object
911 because the effective type of the object is the equivalent
912 type of the class-wide subtype and it smashes most of the
913 data into an array of bytes to which we cannot convert. */
914 || Ekind ((Etype (Defining_Entity (gnat_parent))))
915 == E_Class_Wide_Subtype);
917 case N_Assignment_Statement:
918 /* We cannot use a constructor if the LHS is an atomic object because
919 the actual assignment might end up being done component-wise. */
920 return (!constant
921 || Name (gnat_parent) == gnat_node
922 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
923 && Is_Atomic (Entity (Name (gnat_parent)))));
925 case N_Unchecked_Type_Conversion:
926 if (!constant)
927 return 1;
929 /* ... fall through ... */
931 case N_Type_Conversion:
932 case N_Qualified_Expression:
933 /* We must look through all conversions because we may need to bypass
934 an intermediate conversion that is meant to be purely formal. */
935 return lvalue_required_p (gnat_parent,
936 get_unpadded_type (Etype (gnat_parent)),
937 constant, address_of_constant, aliased);
939 case N_Allocator:
940 /* We should only reach here through the N_Qualified_Expression case.
941 Force an lvalue for composite types since a block-copy to the newly
942 allocated area of memory is made. */
943 return Is_Composite_Type (Underlying_Type (Etype (gnat_node)));
945 case N_Explicit_Dereference:
946 /* We look through dereferences for address of constant because we need
947 to handle the special cases listed above. */
948 if (constant && address_of_constant)
949 return lvalue_required_p (gnat_parent,
950 get_unpadded_type (Etype (gnat_parent)),
951 true, false, true);
953 /* ... fall through ... */
955 default:
956 return 0;
959 gcc_unreachable ();
962 /* Return true if T is a constant DECL node that can be safely replaced
963 by its initializer. */
965 static bool
966 constant_decl_with_initializer_p (tree t)
968 if (!TREE_CONSTANT (t) || !DECL_P (t) || !DECL_INITIAL (t))
969 return false;
971 /* Return false for aggregate types that contain a placeholder since
972 their initializers cannot be manipulated easily. */
973 if (AGGREGATE_TYPE_P (TREE_TYPE (t))
974 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t))
975 && type_contains_placeholder_p (TREE_TYPE (t)))
976 return false;
978 return true;
981 /* Return an expression equivalent to EXP but where constant DECL nodes
982 have been replaced by their initializer. */
984 static tree
985 fold_constant_decl_in_expr (tree exp)
987 enum tree_code code = TREE_CODE (exp);
988 tree op0;
990 switch (code)
992 case CONST_DECL:
993 case VAR_DECL:
994 if (!constant_decl_with_initializer_p (exp))
995 return exp;
997 return DECL_INITIAL (exp);
999 case BIT_FIELD_REF:
1000 case COMPONENT_REF:
1001 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1002 if (op0 == TREE_OPERAND (exp, 0))
1003 return exp;
1005 return fold_build3 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
1006 TREE_OPERAND (exp, 2));
1008 case ARRAY_REF:
1009 case ARRAY_RANGE_REF:
1010 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1011 if (op0 == TREE_OPERAND (exp, 0))
1012 return exp;
1014 return fold (build4 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
1015 TREE_OPERAND (exp, 2), TREE_OPERAND (exp, 3)));
1017 case VIEW_CONVERT_EXPR:
1018 case REALPART_EXPR:
1019 case IMAGPART_EXPR:
1020 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1021 if (op0 == TREE_OPERAND (exp, 0))
1022 return exp;
1024 return fold_build1 (code, TREE_TYPE (exp), op0);
1026 default:
1027 return exp;
1030 gcc_unreachable ();
1033 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
1034 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
1035 to where we should place the result type. */
1037 static tree
1038 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
1040 Node_Id gnat_temp, gnat_temp_type;
1041 tree gnu_result, gnu_result_type;
1043 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1044 specific circumstances only, so evaluated lazily. < 0 means
1045 unknown, > 0 means known true, 0 means known false. */
1046 int require_lvalue = -1;
1048 /* If GNAT_NODE is a constant, whether we should use the initialization
1049 value instead of the constant entity, typically for scalars with an
1050 address clause when the parent doesn't require an lvalue. */
1051 bool use_constant_initializer = false;
1053 /* If the Etype of this node does not equal the Etype of the Entity,
1054 something is wrong with the entity map, probably in generic
1055 instantiation. However, this does not apply to types. Since we sometime
1056 have strange Ekind's, just do this test for objects. Also, if the Etype of
1057 the Entity is private, the Etype of the N_Identifier is allowed to be the
1058 full type and also we consider a packed array type to be the same as the
1059 original type. Similarly, a class-wide type is equivalent to a subtype of
1060 itself. Finally, if the types are Itypes, one may be a copy of the other,
1061 which is also legal. */
1062 gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
1063 ? gnat_node : Entity (gnat_node));
1064 gnat_temp_type = Etype (gnat_temp);
1066 gcc_assert (Etype (gnat_node) == gnat_temp_type
1067 || (Is_Packed (gnat_temp_type)
1068 && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
1069 || (Is_Class_Wide_Type (Etype (gnat_node)))
1070 || (IN (Ekind (gnat_temp_type), Private_Kind)
1071 && Present (Full_View (gnat_temp_type))
1072 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
1073 || (Is_Packed (Full_View (gnat_temp_type))
1074 && (Etype (gnat_node)
1075 == Packed_Array_Type (Full_View
1076 (gnat_temp_type))))))
1077 || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
1078 || !(Ekind (gnat_temp) == E_Variable
1079 || Ekind (gnat_temp) == E_Component
1080 || Ekind (gnat_temp) == E_Constant
1081 || Ekind (gnat_temp) == E_Loop_Parameter
1082 || IN (Ekind (gnat_temp), Formal_Kind)));
1084 /* If this is a reference to a deferred constant whose partial view is an
1085 unconstrained private type, the proper type is on the full view of the
1086 constant, not on the full view of the type, which may be unconstrained.
1088 This may be a reference to a type, for example in the prefix of the
1089 attribute Position, generated for dispatching code (see Make_DT in
1090 exp_disp,adb). In that case we need the type itself, not is parent,
1091 in particular if it is a derived type */
1092 if (Ekind (gnat_temp) == E_Constant
1093 && Is_Private_Type (gnat_temp_type)
1094 && (Has_Unknown_Discriminants (gnat_temp_type)
1095 || (Present (Full_View (gnat_temp_type))
1096 && Has_Discriminants (Full_View (gnat_temp_type))))
1097 && Present (Full_View (gnat_temp)))
1099 gnat_temp = Full_View (gnat_temp);
1100 gnat_temp_type = Etype (gnat_temp);
1102 else
1104 /* We want to use the Actual_Subtype if it has already been elaborated,
1105 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
1106 simplify things. */
1107 if ((Ekind (gnat_temp) == E_Constant
1108 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
1109 && !(Is_Array_Type (Etype (gnat_temp))
1110 && Present (Packed_Array_Type (Etype (gnat_temp))))
1111 && Present (Actual_Subtype (gnat_temp))
1112 && present_gnu_tree (Actual_Subtype (gnat_temp)))
1113 gnat_temp_type = Actual_Subtype (gnat_temp);
1114 else
1115 gnat_temp_type = Etype (gnat_node);
1118 /* Expand the type of this identifier first, in case it is an enumeral
1119 literal, which only get made when the type is expanded. There is no
1120 order-of-elaboration issue here. */
1121 gnu_result_type = get_unpadded_type (gnat_temp_type);
1123 /* If this is a non-imported elementary constant with an address clause,
1124 retrieve the value instead of a pointer to be dereferenced unless
1125 an lvalue is required. This is generally more efficient and actually
1126 required if this is a static expression because it might be used
1127 in a context where a dereference is inappropriate, such as a case
1128 statement alternative or a record discriminant. There is no possible
1129 volatile-ness short-circuit here since Volatile constants must be
1130 imported per C.6. */
1131 if (Ekind (gnat_temp) == E_Constant
1132 && Is_Elementary_Type (gnat_temp_type)
1133 && !Is_Imported (gnat_temp)
1134 && Present (Address_Clause (gnat_temp)))
1136 require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
1137 false, Is_Aliased (gnat_temp));
1138 use_constant_initializer = !require_lvalue;
1141 if (use_constant_initializer)
1143 /* If this is a deferred constant, the initializer is attached to
1144 the full view. */
1145 if (Present (Full_View (gnat_temp)))
1146 gnat_temp = Full_View (gnat_temp);
1148 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
1150 else
1151 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
1153 /* Some objects (such as parameters passed by reference, globals of
1154 variable size, and renamed objects) actually represent the address
1155 of the object. In that case, we must do the dereference. Likewise,
1156 deal with parameters to foreign convention subprograms. */
1157 if (DECL_P (gnu_result)
1158 && (DECL_BY_REF_P (gnu_result)
1159 || (TREE_CODE (gnu_result) == PARM_DECL
1160 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
1162 const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
1164 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1165 if (TREE_CODE (gnu_result) == PARM_DECL
1166 && DECL_BY_COMPONENT_PTR_P (gnu_result))
1167 gnu_result
1168 = convert (build_pointer_type (gnu_result_type), gnu_result);
1170 /* If it's a CONST_DECL, return the underlying constant like below. */
1171 else if (TREE_CODE (gnu_result) == CONST_DECL
1172 && !(DECL_CONST_ADDRESS_P (gnu_result)
1173 && lvalue_required_p (gnat_node, gnu_result_type, true,
1174 true, false)))
1175 gnu_result = DECL_INITIAL (gnu_result);
1177 /* If it's a renaming pointer and, either the renamed object is constant
1178 or we are at the right binding level, we can reference the renamed
1179 object directly, since it is constant or has been protected against
1180 multiple evaluations. */
1181 if (TREE_CODE (gnu_result) == VAR_DECL
1182 && !DECL_LOOP_PARM_P (gnu_result)
1183 && DECL_RENAMED_OBJECT (gnu_result)
1184 && (TREE_CONSTANT (DECL_RENAMED_OBJECT (gnu_result))
1185 || !DECL_RENAMING_GLOBAL_P (gnu_result)
1186 || global_bindings_p ()))
1187 gnu_result = DECL_RENAMED_OBJECT (gnu_result);
1189 /* Otherwise, do the final dereference. */
1190 else
1192 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1194 if ((TREE_CODE (gnu_result) == INDIRECT_REF
1195 || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
1196 && No (Address_Clause (gnat_temp)))
1197 TREE_THIS_NOTRAP (gnu_result) = 1;
1199 if (read_only)
1200 TREE_READONLY (gnu_result) = 1;
1204 /* If we have a constant declaration and its initializer, try to return the
1205 latter to avoid the need to call fold in lots of places and the need for
1206 elaboration code if this identifier is used as an initializer itself. */
1207 if (constant_decl_with_initializer_p (gnu_result))
1209 bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1210 && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1211 bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1212 && DECL_CONST_ADDRESS_P (gnu_result));
1214 /* If there is a (corresponding) variable or this is the address of a
1215 constant, we only want to return the initializer if an lvalue isn't
1216 required. Evaluate this now if we have not already done so. */
1217 if ((!constant_only || address_of_constant) && require_lvalue < 0)
1218 require_lvalue
1219 = lvalue_required_p (gnat_node, gnu_result_type, true,
1220 address_of_constant, Is_Aliased (gnat_temp));
1222 /* Finally retrieve the initializer if this is deemed valid. */
1223 if ((constant_only && !address_of_constant) || !require_lvalue)
1224 gnu_result = DECL_INITIAL (gnu_result);
1227 /* But for a constant renaming we couldn't do that incrementally for its
1228 definition because of the need to return an lvalue so, if the present
1229 context doesn't itself require an lvalue, we try again here. */
1230 else if (Ekind (gnat_temp) == E_Constant
1231 && Is_Elementary_Type (gnat_temp_type)
1232 && Present (Renamed_Object (gnat_temp)))
1234 if (require_lvalue < 0)
1235 require_lvalue
1236 = lvalue_required_p (gnat_node, gnu_result_type, true, false,
1237 Is_Aliased (gnat_temp));
1238 if (!require_lvalue)
1239 gnu_result = fold_constant_decl_in_expr (gnu_result);
1242 /* The GNAT tree has the type of a function set to its result type, so we
1243 adjust here. Also use the type of the result if the Etype is a subtype
1244 that is nominally unconstrained. Likewise if this is a deferred constant
1245 of a discriminated type whose full view can be elaborated statically, to
1246 avoid problematic conversions to the nominal subtype. But remove any
1247 padding from the resulting type. */
1248 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1249 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)
1250 || (Ekind (gnat_temp) == E_Constant
1251 && Present (Full_View (gnat_temp))
1252 && Has_Discriminants (gnat_temp_type)
1253 && TREE_CODE (gnu_result) == CONSTRUCTOR))
1255 gnu_result_type = TREE_TYPE (gnu_result);
1256 if (TYPE_IS_PADDING_P (gnu_result_type))
1257 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1260 *gnu_result_type_p = gnu_result_type;
1262 return gnu_result;
1265 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1266 any statements we generate. */
1268 static tree
1269 Pragma_to_gnu (Node_Id gnat_node)
1271 tree gnu_result = alloc_stmt_list ();
1272 unsigned char pragma_id;
1273 Node_Id gnat_temp;
1275 /* Do nothing if we are just annotating types and check for (and ignore)
1276 unrecognized pragmas. */
1277 if (type_annotate_only
1278 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1279 return gnu_result;
1281 pragma_id = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
1282 switch (pragma_id)
1284 case Pragma_Inspection_Point:
1285 /* Do nothing at top level: all such variables are already viewable. */
1286 if (global_bindings_p ())
1287 break;
1289 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1290 Present (gnat_temp);
1291 gnat_temp = Next (gnat_temp))
1293 Node_Id gnat_expr = Expression (gnat_temp);
1294 tree gnu_expr = gnat_to_gnu (gnat_expr);
1295 int use_address;
1296 enum machine_mode mode;
1297 tree asm_constraint = NULL_TREE;
1298 #ifdef ASM_COMMENT_START
1299 char *comment;
1300 #endif
1302 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1303 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1305 /* Use the value only if it fits into a normal register,
1306 otherwise use the address. */
1307 mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1308 use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1309 && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1310 || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1312 if (use_address)
1313 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1315 #ifdef ASM_COMMENT_START
1316 comment = concat (ASM_COMMENT_START,
1317 " inspection point: ",
1318 Get_Name_String (Chars (gnat_expr)),
1319 use_address ? " address" : "",
1320 " is in %0",
1321 NULL);
1322 asm_constraint = build_string (strlen (comment), comment);
1323 free (comment);
1324 #endif
1325 gnu_expr = build5 (ASM_EXPR, void_type_node,
1326 asm_constraint,
1327 NULL_TREE,
1328 tree_cons
1329 (build_tree_list (NULL_TREE,
1330 build_string (1, "g")),
1331 gnu_expr, NULL_TREE),
1332 NULL_TREE, NULL_TREE);
1333 ASM_VOLATILE_P (gnu_expr) = 1;
1334 set_expr_location_from_node (gnu_expr, gnat_node);
1335 append_to_statement_list (gnu_expr, &gnu_result);
1337 break;
1339 case Pragma_Loop_Optimize:
1340 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1341 Present (gnat_temp);
1342 gnat_temp = Next (gnat_temp))
1344 tree gnu_loop_stmt = gnu_loop_stack->last ()->stmt;
1346 switch (Chars (Expression (gnat_temp)))
1348 case Name_Ivdep:
1349 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
1350 break;
1352 case Name_No_Unroll:
1353 LOOP_STMT_NO_UNROLL (gnu_loop_stmt) = 1;
1354 break;
1356 case Name_Unroll:
1357 LOOP_STMT_UNROLL (gnu_loop_stmt) = 1;
1358 break;
1360 case Name_No_Vector:
1361 LOOP_STMT_NO_VECTOR (gnu_loop_stmt) = 1;
1362 break;
1364 case Name_Vector:
1365 LOOP_STMT_VECTOR (gnu_loop_stmt) = 1;
1366 break;
1368 default:
1369 gcc_unreachable ();
1372 break;
1374 case Pragma_Optimize:
1375 switch (Chars (Expression
1376 (First (Pragma_Argument_Associations (gnat_node)))))
1378 case Name_Off:
1379 if (optimize)
1380 post_error ("must specify -O0?", gnat_node);
1381 break;
1383 case Name_Space:
1384 if (!optimize_size)
1385 post_error ("must specify -Os?", gnat_node);
1386 break;
1388 case Name_Time:
1389 if (!optimize)
1390 post_error ("insufficient -O value?", gnat_node);
1391 break;
1393 default:
1394 gcc_unreachable ();
1396 break;
1398 case Pragma_Reviewable:
1399 if (write_symbols == NO_DEBUG)
1400 post_error ("must specify -g?", gnat_node);
1401 break;
1403 case Pragma_Warning_As_Error:
1404 case Pragma_Warnings:
1406 Node_Id gnat_expr;
1407 /* Preserve the location of the pragma. */
1408 const location_t location = input_location;
1409 struct cl_option_handlers handlers;
1410 unsigned int option_index;
1411 diagnostic_t kind;
1412 bool imply;
1414 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1416 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1417 if (Nkind (Expression (gnat_temp)) == N_String_Literal)
1419 switch (pragma_id)
1421 case Pragma_Warning_As_Error:
1422 kind = DK_ERROR;
1423 imply = false;
1424 break;
1426 case Pragma_Warnings:
1427 kind = DK_WARNING;
1428 imply = true;
1429 break;
1431 default:
1432 gcc_unreachable ();
1435 gnat_expr = Expression (gnat_temp);
1438 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1439 else if (Nkind (Expression (gnat_temp)) == N_Identifier)
1441 switch (Chars (Expression (gnat_temp)))
1443 case Name_Off:
1444 kind = DK_IGNORED;
1445 break;
1447 case Name_On:
1448 kind = DK_WARNING;
1449 break;
1451 default:
1452 gcc_unreachable ();
1455 if (Present (Next (gnat_temp)))
1457 /* pragma Warnings (On | Off, Name) is handled differently. */
1458 if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal)
1459 break;
1461 gnat_expr = Expression (Next (gnat_temp));
1463 else
1464 gnat_expr = Empty;
1466 imply = false;
1469 else
1470 gcc_unreachable ();
1472 /* This is the same implementation as in the C family of compilers. */
1473 if (Present (gnat_expr))
1475 tree gnu_expr = gnat_to_gnu (gnat_expr);
1476 const char *opt_string = TREE_STRING_POINTER (gnu_expr);
1477 const int len = TREE_STRING_LENGTH (gnu_expr);
1478 if (len < 3 || opt_string[0] != '-' || opt_string[1] != 'W')
1479 break;
1480 for (option_index = 0;
1481 option_index < cl_options_count;
1482 option_index++)
1483 if (strcmp (cl_options[option_index].opt_text, opt_string) == 0)
1484 break;
1485 if (option_index == cl_options_count)
1487 post_error ("unknown -W switch", gnat_node);
1488 break;
1491 else
1492 option_index = 0;
1494 set_default_handlers (&handlers);
1495 control_warning_option (option_index, (int) kind, imply, location,
1496 CL_Ada, &handlers, &global_options,
1497 &global_options_set, global_dc);
1499 break;
1501 default:
1502 break;
1505 return gnu_result;
1508 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1509 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1510 where we should place the result type. ATTRIBUTE is the attribute ID. */
1512 static tree
1513 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1515 const Node_Id gnat_prefix = Prefix (gnat_node);
1516 tree gnu_prefix, gnu_type, gnu_expr;
1517 tree gnu_result_type, gnu_result = error_mark_node;
1518 bool prefix_unused = false;
1520 /* ??? If this is an access attribute for a public subprogram to be used in
1521 a dispatch table, do not translate its type as it's useless there and the
1522 parameter types might be incomplete types coming from a limited with. */
1523 if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
1524 && Is_Dispatch_Table_Entity (Etype (gnat_node))
1525 && Nkind (gnat_prefix) == N_Identifier
1526 && Is_Subprogram (Entity (gnat_prefix))
1527 && Is_Public (Entity (gnat_prefix))
1528 && !present_gnu_tree (Entity (gnat_prefix)))
1529 gnu_prefix = get_minimal_subprog_decl (Entity (gnat_prefix));
1530 else
1531 gnu_prefix = gnat_to_gnu (gnat_prefix);
1532 gnu_type = TREE_TYPE (gnu_prefix);
1534 /* If the input is a NULL_EXPR, make a new one. */
1535 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1537 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1538 *gnu_result_type_p = gnu_result_type;
1539 return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1542 switch (attribute)
1544 case Attr_Pos:
1545 case Attr_Val:
1546 /* These are just conversions since representation clauses for
1547 enumeration types are handled in the front-end. */
1549 bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1550 gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1551 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1552 gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1553 checkp, checkp, true, gnat_node);
1555 break;
1557 case Attr_Pred:
1558 case Attr_Succ:
1559 /* These just add or subtract the constant 1 since representation
1560 clauses for enumeration types are handled in the front-end. */
1561 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1562 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1564 if (Do_Range_Check (First (Expressions (gnat_node))))
1566 gnu_expr = gnat_protect_expr (gnu_expr);
1567 gnu_expr
1568 = emit_check
1569 (build_binary_op (EQ_EXPR, boolean_type_node,
1570 gnu_expr,
1571 attribute == Attr_Pred
1572 ? TYPE_MIN_VALUE (gnu_result_type)
1573 : TYPE_MAX_VALUE (gnu_result_type)),
1574 gnu_expr, CE_Range_Check_Failed, gnat_node);
1577 gnu_result
1578 = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1579 gnu_result_type, gnu_expr,
1580 convert (gnu_result_type, integer_one_node));
1581 break;
1583 case Attr_Address:
1584 case Attr_Unrestricted_Access:
1585 /* Conversions don't change addresses but can cause us to miss the
1586 COMPONENT_REF case below, so strip them off. */
1587 gnu_prefix = remove_conversions (gnu_prefix,
1588 !Must_Be_Byte_Aligned (gnat_node));
1590 /* If we are taking 'Address of an unconstrained object, this is the
1591 pointer to the underlying array. */
1592 if (attribute == Attr_Address)
1593 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1595 /* If we are building a static dispatch table, we have to honor
1596 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1597 with the C++ ABI. We do it in the non-static case as well,
1598 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1599 else if (TARGET_VTABLE_USES_DESCRIPTORS
1600 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1602 tree gnu_field, t;
1603 /* Descriptors can only be built here for top-level functions. */
1604 bool build_descriptor = (global_bindings_p () != 0);
1605 int i;
1606 vec<constructor_elt, va_gc> *gnu_vec = NULL;
1607 constructor_elt *elt;
1609 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1611 /* If we're not going to build the descriptor, we have to retrieve
1612 the one which will be built by the linker (or by the compiler
1613 later if a static chain is requested). */
1614 if (!build_descriptor)
1616 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1617 gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1618 gnu_result);
1619 gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1622 vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS);
1623 elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1624 for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1625 i < TARGET_VTABLE_USES_DESCRIPTORS;
1626 gnu_field = DECL_CHAIN (gnu_field), i++)
1628 if (build_descriptor)
1630 t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1631 build_int_cst (NULL_TREE, i));
1632 TREE_CONSTANT (t) = 1;
1634 else
1635 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1636 gnu_field, NULL_TREE);
1638 elt->index = gnu_field;
1639 elt->value = t;
1640 elt--;
1643 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1644 break;
1647 /* ... fall through ... */
1649 case Attr_Access:
1650 case Attr_Unchecked_Access:
1651 case Attr_Code_Address:
1652 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1653 gnu_result
1654 = build_unary_op (((attribute == Attr_Address
1655 || attribute == Attr_Unrestricted_Access)
1656 && !Must_Be_Byte_Aligned (gnat_node))
1657 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1658 gnu_result_type, gnu_prefix);
1660 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1661 don't try to build a trampoline. */
1662 if (attribute == Attr_Code_Address)
1664 gnu_expr = remove_conversions (gnu_result, false);
1666 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1667 TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1670 /* For 'Access, issue an error message if the prefix is a C++ method
1671 since it can use a special calling convention on some platforms,
1672 which cannot be propagated to the access type. */
1673 else if (attribute == Attr_Access
1674 && Nkind (gnat_prefix) == N_Identifier
1675 && is_cplusplus_method (Entity (gnat_prefix)))
1676 post_error ("access to C++ constructor or member function not allowed",
1677 gnat_node);
1679 /* For other address attributes applied to a nested function,
1680 find an inner ADDR_EXPR and annotate it so that we can issue
1681 a useful warning with -Wtrampolines. */
1682 else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1684 gnu_expr = remove_conversions (gnu_result, false);
1686 if (TREE_CODE (gnu_expr) == ADDR_EXPR
1687 && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1689 set_expr_location_from_node (gnu_expr, gnat_node);
1691 /* Check that we're not violating the No_Implicit_Dynamic_Code
1692 restriction. Be conservative if we don't know anything
1693 about the trampoline strategy for the target. */
1694 Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1697 break;
1699 case Attr_Pool_Address:
1701 tree gnu_ptr = gnu_prefix;
1702 tree gnu_obj_type;
1704 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1706 /* If this is fat pointer, the object must have been allocated with the
1707 template in front of the array. So compute the template address; do
1708 it by converting to a thin pointer. */
1709 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1710 gnu_ptr
1711 = convert (build_pointer_type
1712 (TYPE_OBJECT_RECORD_TYPE
1713 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1714 gnu_ptr);
1716 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1718 /* If this is a thin pointer, the object must have been allocated with
1719 the template in front of the array. So compute the template address
1720 and return it. */
1721 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
1722 gnu_ptr
1723 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
1724 gnu_ptr,
1725 fold_build1 (NEGATE_EXPR, sizetype,
1726 byte_position
1727 (DECL_CHAIN
1728 TYPE_FIELDS ((gnu_obj_type)))));
1730 gnu_result = convert (gnu_result_type, gnu_ptr);
1732 break;
1734 case Attr_Size:
1735 case Attr_Object_Size:
1736 case Attr_Value_Size:
1737 case Attr_Max_Size_In_Storage_Elements:
1738 gnu_expr = gnu_prefix;
1740 /* Remove NOPs and conversions between original and packable version
1741 from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
1742 to see if a COMPONENT_REF was involved. */
1743 while (TREE_CODE (gnu_expr) == NOP_EXPR
1744 || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1745 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1746 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1747 == RECORD_TYPE
1748 && TYPE_NAME (TREE_TYPE (gnu_expr))
1749 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1750 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1752 gnu_prefix = remove_conversions (gnu_prefix, true);
1753 prefix_unused = true;
1754 gnu_type = TREE_TYPE (gnu_prefix);
1756 /* Replace an unconstrained array type with the type of the underlying
1757 array. We can't do this with a call to maybe_unconstrained_array
1758 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
1759 use the record type that will be used to allocate the object and its
1760 template. */
1761 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1763 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1764 if (attribute != Attr_Max_Size_In_Storage_Elements)
1765 gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
1768 /* If we're looking for the size of a field, return the field size. */
1769 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1770 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1772 /* Otherwise, if the prefix is an object, or if we are looking for
1773 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1774 GCC size of the type. We make an exception for padded objects,
1775 as we do not take into account alignment promotions for the size.
1776 This is in keeping with the object case of gnat_to_gnu_entity. */
1777 else if ((TREE_CODE (gnu_prefix) != TYPE_DECL
1778 && !(TYPE_IS_PADDING_P (gnu_type)
1779 && TREE_CODE (gnu_expr) == COMPONENT_REF))
1780 || attribute == Attr_Object_Size
1781 || attribute == Attr_Max_Size_In_Storage_Elements)
1783 /* If this is a dereference and we have a special dynamic constrained
1784 subtype on the prefix, use it to compute the size; otherwise, use
1785 the designated subtype. */
1786 if (Nkind (gnat_prefix) == N_Explicit_Dereference)
1788 Node_Id gnat_actual_subtype
1789 = Actual_Designated_Subtype (gnat_prefix);
1790 tree gnu_ptr_type
1791 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
1793 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1794 && Present (gnat_actual_subtype))
1796 tree gnu_actual_obj_type
1797 = gnat_to_gnu_type (gnat_actual_subtype);
1798 gnu_type
1799 = build_unc_object_type_from_ptr (gnu_ptr_type,
1800 gnu_actual_obj_type,
1801 get_identifier ("SIZE"),
1802 false);
1806 gnu_result = TYPE_SIZE (gnu_type);
1809 /* Otherwise, the result is the RM size of the type. */
1810 else
1811 gnu_result = rm_size (gnu_type);
1813 /* Deal with a self-referential size by returning the maximum size for
1814 a type and by qualifying the size with the object otherwise. */
1815 if (CONTAINS_PLACEHOLDER_P (gnu_result))
1817 if (TREE_CODE (gnu_prefix) == TYPE_DECL)
1818 gnu_result = max_size (gnu_result, true);
1819 else
1820 gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1823 /* If the type contains a template, subtract its size. */
1824 if (TREE_CODE (gnu_type) == RECORD_TYPE
1825 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1826 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1827 DECL_SIZE (TYPE_FIELDS (gnu_type)));
1829 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
1830 if (attribute == Attr_Max_Size_In_Storage_Elements)
1831 gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
1833 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1834 break;
1836 case Attr_Alignment:
1838 unsigned int align;
1840 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1841 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1842 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1844 gnu_type = TREE_TYPE (gnu_prefix);
1845 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1846 prefix_unused = true;
1848 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1849 align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1850 else
1852 Entity_Id gnat_type = Etype (gnat_prefix);
1853 unsigned int double_align;
1854 bool is_capped_double, align_clause;
1856 /* If the default alignment of "double" or larger scalar types is
1857 specifically capped and there is an alignment clause neither
1858 on the type nor on the prefix itself, return the cap. */
1859 if ((double_align = double_float_alignment) > 0)
1860 is_capped_double
1861 = is_double_float_or_array (gnat_type, &align_clause);
1862 else if ((double_align = double_scalar_alignment) > 0)
1863 is_capped_double
1864 = is_double_scalar_or_array (gnat_type, &align_clause);
1865 else
1866 is_capped_double = align_clause = false;
1868 if (is_capped_double
1869 && Nkind (gnat_prefix) == N_Identifier
1870 && Present (Alignment_Clause (Entity (gnat_prefix))))
1871 align_clause = true;
1873 if (is_capped_double && !align_clause)
1874 align = double_align;
1875 else
1876 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1879 gnu_result = size_int (align);
1881 break;
1883 case Attr_First:
1884 case Attr_Last:
1885 case Attr_Range_Length:
1886 prefix_unused = true;
1888 if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1890 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1892 if (attribute == Attr_First)
1893 gnu_result = TYPE_MIN_VALUE (gnu_type);
1894 else if (attribute == Attr_Last)
1895 gnu_result = TYPE_MAX_VALUE (gnu_type);
1896 else
1897 gnu_result
1898 = build_binary_op
1899 (MAX_EXPR, get_base_type (gnu_result_type),
1900 build_binary_op
1901 (PLUS_EXPR, get_base_type (gnu_result_type),
1902 build_binary_op (MINUS_EXPR,
1903 get_base_type (gnu_result_type),
1904 convert (gnu_result_type,
1905 TYPE_MAX_VALUE (gnu_type)),
1906 convert (gnu_result_type,
1907 TYPE_MIN_VALUE (gnu_type))),
1908 convert (gnu_result_type, integer_one_node)),
1909 convert (gnu_result_type, integer_zero_node));
1911 break;
1914 /* ... fall through ... */
1916 case Attr_Length:
1918 int Dimension = (Present (Expressions (gnat_node))
1919 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1920 : 1), i;
1921 struct parm_attr_d *pa = NULL;
1922 Entity_Id gnat_param = Empty;
1923 bool unconstrained_ptr_deref = false;
1925 /* Make sure any implicit dereference gets done. */
1926 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1927 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1929 /* We treat unconstrained array In parameters specially. We also note
1930 whether we are dereferencing a pointer to unconstrained array. */
1931 if (!Is_Constrained (Etype (gnat_prefix)))
1932 switch (Nkind (gnat_prefix))
1934 case N_Identifier:
1935 /* This is the direct case. */
1936 if (Ekind (Entity (gnat_prefix)) == E_In_Parameter)
1937 gnat_param = Entity (gnat_prefix);
1938 break;
1940 case N_Explicit_Dereference:
1941 /* This is the indirect case. Note that we need to be sure that
1942 the access value cannot be null as we'll hoist the load. */
1943 if (Nkind (Prefix (gnat_prefix)) == N_Identifier
1944 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter)
1946 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
1947 gnat_param = Entity (Prefix (gnat_prefix));
1949 else
1950 unconstrained_ptr_deref = true;
1951 break;
1953 default:
1954 break;
1957 /* If the prefix is the view conversion of a constrained array to an
1958 unconstrained form, we retrieve the constrained array because we
1959 might not be able to substitute the PLACEHOLDER_EXPR coming from
1960 the conversion. This can occur with the 'Old attribute applied
1961 to a parameter with an unconstrained type, which gets rewritten
1962 into a constrained local variable very late in the game. */
1963 if (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
1964 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix)))
1965 && !CONTAINS_PLACEHOLDER_P
1966 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1967 gnu_type = TREE_TYPE (TREE_OPERAND (gnu_prefix, 0));
1968 else
1969 gnu_type = TREE_TYPE (gnu_prefix);
1971 prefix_unused = true;
1972 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1974 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1976 int ndim;
1977 tree gnu_type_temp;
1979 for (ndim = 1, gnu_type_temp = gnu_type;
1980 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1981 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1982 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1985 Dimension = ndim + 1 - Dimension;
1988 for (i = 1; i < Dimension; i++)
1989 gnu_type = TREE_TYPE (gnu_type);
1991 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1993 /* When not optimizing, look up the slot associated with the parameter
1994 and the dimension in the cache and create a new one on failure. */
1995 if (!optimize && Present (gnat_param))
1997 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa)
1998 if (pa->id == gnat_param && pa->dim == Dimension)
1999 break;
2001 if (!pa)
2003 pa = ggc_cleared_alloc<parm_attr_d> ();
2004 pa->id = gnat_param;
2005 pa->dim = Dimension;
2006 vec_safe_push (f_parm_attr_cache, pa);
2010 /* Return the cached expression or build a new one. */
2011 if (attribute == Attr_First)
2013 if (pa && pa->first)
2015 gnu_result = pa->first;
2016 break;
2019 gnu_result
2020 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2023 else if (attribute == Attr_Last)
2025 if (pa && pa->last)
2027 gnu_result = pa->last;
2028 break;
2031 gnu_result
2032 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2035 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2037 if (pa && pa->length)
2039 gnu_result = pa->length;
2040 break;
2042 else
2044 /* We used to compute the length as max (hb - lb + 1, 0),
2045 which could overflow for some cases of empty arrays, e.g.
2046 when lb == index_type'first. We now compute the length as
2047 (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
2048 much rarer cases, for extremely large arrays we expect
2049 never to encounter in practice. In addition, the former
2050 computation required the use of potentially constraining
2051 signed arithmetic while the latter doesn't. Note that
2052 the comparison must be done in the original index type,
2053 to avoid any overflow during the conversion. */
2054 tree comp_type = get_base_type (gnu_result_type);
2055 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
2056 tree lb = TYPE_MIN_VALUE (index_type);
2057 tree hb = TYPE_MAX_VALUE (index_type);
2058 gnu_result
2059 = build_binary_op (PLUS_EXPR, comp_type,
2060 build_binary_op (MINUS_EXPR,
2061 comp_type,
2062 convert (comp_type, hb),
2063 convert (comp_type, lb)),
2064 convert (comp_type, integer_one_node));
2065 gnu_result
2066 = build_cond_expr (comp_type,
2067 build_binary_op (GE_EXPR,
2068 boolean_type_node,
2069 hb, lb),
2070 gnu_result,
2071 convert (comp_type, integer_zero_node));
2075 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2076 handling. Note that these attributes could not have been used on
2077 an unconstrained array type. */
2078 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2080 /* Cache the expression we have just computed. Since we want to do it
2081 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2082 create the temporary in the outermost binding level. We will make
2083 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2084 paths by forcing its evaluation on entry of the function. */
2085 if (pa)
2087 gnu_result
2088 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2089 switch (attribute)
2091 case Attr_First:
2092 pa->first = gnu_result;
2093 break;
2095 case Attr_Last:
2096 pa->last = gnu_result;
2097 break;
2099 case Attr_Length:
2100 case Attr_Range_Length:
2101 pa->length = gnu_result;
2102 break;
2104 default:
2105 gcc_unreachable ();
2109 /* Otherwise, evaluate it each time it is referenced. */
2110 else
2111 switch (attribute)
2113 case Attr_First:
2114 case Attr_Last:
2115 /* If we are dereferencing a pointer to unconstrained array, we
2116 need to capture the value because the pointed-to bounds may
2117 subsequently be released. */
2118 if (unconstrained_ptr_deref)
2119 gnu_result
2120 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2121 break;
2123 case Attr_Length:
2124 case Attr_Range_Length:
2125 /* Set the source location onto the predicate of the condition
2126 but not if the expression is cached to avoid messing up the
2127 debug info. */
2128 if (TREE_CODE (gnu_result) == COND_EXPR
2129 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
2130 set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
2131 gnat_node);
2132 break;
2134 default:
2135 gcc_unreachable ();
2138 break;
2141 case Attr_Bit_Position:
2142 case Attr_Position:
2143 case Attr_First_Bit:
2144 case Attr_Last_Bit:
2145 case Attr_Bit:
2147 HOST_WIDE_INT bitsize;
2148 HOST_WIDE_INT bitpos;
2149 tree gnu_offset;
2150 tree gnu_field_bitpos;
2151 tree gnu_field_offset;
2152 tree gnu_inner;
2153 enum machine_mode mode;
2154 int unsignedp, volatilep;
2156 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2157 gnu_prefix = remove_conversions (gnu_prefix, true);
2158 prefix_unused = true;
2160 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2161 the result is 0. Don't allow 'Bit on a bare component, though. */
2162 if (attribute == Attr_Bit
2163 && TREE_CODE (gnu_prefix) != COMPONENT_REF
2164 && TREE_CODE (gnu_prefix) != FIELD_DECL)
2166 gnu_result = integer_zero_node;
2167 break;
2170 else
2171 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
2172 || (attribute == Attr_Bit_Position
2173 && TREE_CODE (gnu_prefix) == FIELD_DECL));
2175 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
2176 &mode, &unsignedp, &volatilep, false);
2178 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2180 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
2181 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
2183 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
2184 TREE_CODE (gnu_inner) == COMPONENT_REF
2185 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
2186 gnu_inner = TREE_OPERAND (gnu_inner, 0))
2188 gnu_field_bitpos
2189 = size_binop (PLUS_EXPR, gnu_field_bitpos,
2190 bit_position (TREE_OPERAND (gnu_inner, 1)));
2191 gnu_field_offset
2192 = size_binop (PLUS_EXPR, gnu_field_offset,
2193 byte_position (TREE_OPERAND (gnu_inner, 1)));
2196 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
2198 gnu_field_bitpos = bit_position (gnu_prefix);
2199 gnu_field_offset = byte_position (gnu_prefix);
2201 else
2203 gnu_field_bitpos = bitsize_zero_node;
2204 gnu_field_offset = size_zero_node;
2207 switch (attribute)
2209 case Attr_Position:
2210 gnu_result = gnu_field_offset;
2211 break;
2213 case Attr_First_Bit:
2214 case Attr_Bit:
2215 gnu_result = size_int (bitpos % BITS_PER_UNIT);
2216 break;
2218 case Attr_Last_Bit:
2219 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
2220 gnu_result = size_binop (PLUS_EXPR, gnu_result,
2221 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
2222 /* ??? Avoid a large unsigned result that will overflow when
2223 converted to the signed universal_integer. */
2224 if (integer_zerop (gnu_result))
2225 gnu_result = integer_minus_one_node;
2226 else
2227 gnu_result
2228 = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node);
2229 break;
2231 case Attr_Bit_Position:
2232 gnu_result = gnu_field_bitpos;
2233 break;
2236 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2237 handling. */
2238 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2239 break;
2242 case Attr_Min:
2243 case Attr_Max:
2245 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
2246 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
2248 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2249 gnu_result = build_binary_op (attribute == Attr_Min
2250 ? MIN_EXPR : MAX_EXPR,
2251 gnu_result_type, gnu_lhs, gnu_rhs);
2253 break;
2255 case Attr_Passed_By_Reference:
2256 gnu_result = size_int (default_pass_by_ref (gnu_type)
2257 || must_pass_by_ref (gnu_type));
2258 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2259 break;
2261 case Attr_Component_Size:
2262 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
2263 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
2264 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
2266 gnu_prefix = maybe_implicit_deref (gnu_prefix);
2267 gnu_type = TREE_TYPE (gnu_prefix);
2269 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
2270 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
2272 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2273 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
2274 gnu_type = TREE_TYPE (gnu_type);
2276 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2278 /* Note this size cannot be self-referential. */
2279 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
2280 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2281 prefix_unused = true;
2282 break;
2284 case Attr_Descriptor_Size:
2285 gnu_type = TREE_TYPE (gnu_prefix);
2286 gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
2288 /* What we want is the offset of the ARRAY field in the record
2289 that the thin pointer designates. */
2290 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
2291 gnu_result = bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
2292 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2293 prefix_unused = true;
2294 break;
2296 case Attr_Null_Parameter:
2297 /* This is just a zero cast to the pointer type for our prefix and
2298 dereferenced. */
2299 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2300 gnu_result
2301 = build_unary_op (INDIRECT_REF, NULL_TREE,
2302 convert (build_pointer_type (gnu_result_type),
2303 integer_zero_node));
2304 TREE_PRIVATE (gnu_result) = 1;
2305 break;
2307 case Attr_Mechanism_Code:
2309 Entity_Id gnat_obj = Entity (gnat_prefix);
2310 int code;
2312 prefix_unused = true;
2313 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2314 if (Present (Expressions (gnat_node)))
2316 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
2318 for (gnat_obj = First_Formal (gnat_obj); i > 1;
2319 i--, gnat_obj = Next_Formal (gnat_obj))
2323 code = Mechanism (gnat_obj);
2324 if (code == Default)
2325 code = ((present_gnu_tree (gnat_obj)
2326 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
2327 || ((TREE_CODE (get_gnu_tree (gnat_obj))
2328 == PARM_DECL)
2329 && (DECL_BY_COMPONENT_PTR_P
2330 (get_gnu_tree (gnat_obj))))))
2331 ? By_Reference : By_Copy);
2332 gnu_result = convert (gnu_result_type, size_int (- code));
2334 break;
2336 default:
2337 /* This abort means that we have an unimplemented attribute. */
2338 gcc_unreachable ();
2341 /* If this is an attribute where the prefix was unused, force a use of it if
2342 it has a side-effect. But don't do it if the prefix is just an entity
2343 name. However, if an access check is needed, we must do it. See second
2344 example in AARM 11.6(5.e). */
2345 if (prefix_unused
2346 && TREE_SIDE_EFFECTS (gnu_prefix)
2347 && !Is_Entity_Name (gnat_prefix))
2348 gnu_result
2349 = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result);
2351 *gnu_result_type_p = gnu_result_type;
2352 return gnu_result;
2355 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2356 to a GCC tree, which is returned. */
2358 static tree
2359 Case_Statement_to_gnu (Node_Id gnat_node)
2361 tree gnu_result, gnu_expr, gnu_label;
2362 Node_Id gnat_when;
2363 location_t end_locus;
2364 bool may_fallthru = false;
2366 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2367 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2369 /* The range of values in a case statement is determined by the rules in
2370 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
2371 of the expression. One exception arises in the case of a simple name that
2372 is parenthesized. This still has the Etype of the name, but since it is
2373 not a name, para 7 does not apply, and we need to go to the base type.
2374 This is the only case where parenthesization affects the dynamic
2375 semantics (i.e. the range of possible values at run time that is covered
2376 by the others alternative).
2378 Another exception is if the subtype of the expression is non-static. In
2379 that case, we also have to use the base type. */
2380 if (Paren_Count (Expression (gnat_node)) != 0
2381 || !Is_OK_Static_Subtype (Underlying_Type
2382 (Etype (Expression (gnat_node)))))
2383 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2385 /* We build a SWITCH_EXPR that contains the code with interspersed
2386 CASE_LABEL_EXPRs for each label. */
2387 if (!Sloc_to_locus (End_Location (gnat_node), &end_locus))
2388 end_locus = input_location;
2389 gnu_label = create_artificial_label (end_locus);
2390 start_stmt_group ();
2392 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2393 Present (gnat_when);
2394 gnat_when = Next_Non_Pragma (gnat_when))
2396 bool choices_added_p = false;
2397 Node_Id gnat_choice;
2399 /* First compile all the different case choices for the current WHEN
2400 alternative. */
2401 for (gnat_choice = First (Discrete_Choices (gnat_when));
2402 Present (gnat_choice); gnat_choice = Next (gnat_choice))
2404 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2406 switch (Nkind (gnat_choice))
2408 case N_Range:
2409 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2410 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2411 break;
2413 case N_Subtype_Indication:
2414 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2415 (Constraint (gnat_choice))));
2416 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2417 (Constraint (gnat_choice))));
2418 break;
2420 case N_Identifier:
2421 case N_Expanded_Name:
2422 /* This represents either a subtype range or a static value of
2423 some kind; Ekind says which. */
2424 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
2426 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2428 gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
2429 gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
2430 break;
2433 /* ... fall through ... */
2435 case N_Character_Literal:
2436 case N_Integer_Literal:
2437 gnu_low = gnat_to_gnu (gnat_choice);
2438 break;
2440 case N_Others_Choice:
2441 break;
2443 default:
2444 gcc_unreachable ();
2447 /* If the case value is a subtype that raises Constraint_Error at
2448 run time because of a wrong bound, then gnu_low or gnu_high is
2449 not translated into an INTEGER_CST. In such a case, we need
2450 to ensure that the when statement is not added in the tree,
2451 otherwise it will crash the gimplifier. */
2452 if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
2453 && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
2455 add_stmt_with_node (build_case_label
2456 (gnu_low, gnu_high,
2457 create_artificial_label (input_location)),
2458 gnat_choice);
2459 choices_added_p = true;
2463 /* This construct doesn't define a scope so we shouldn't push a binding
2464 level around the statement list. Except that we have always done so
2465 historically and this makes it possible to reduce stack usage. As a
2466 compromise, we keep doing it for case statements, for which this has
2467 never been problematic, but not for case expressions in Ada 2012. */
2468 if (choices_added_p)
2470 const bool is_case_expression
2471 = (Nkind (Parent (gnat_node)) == N_Expression_With_Actions);
2472 tree group
2473 = build_stmt_group (Statements (gnat_when), !is_case_expression);
2474 bool group_may_fallthru = block_may_fallthru (group);
2475 add_stmt (group);
2476 if (group_may_fallthru)
2478 tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2479 SET_EXPR_LOCATION (stmt, end_locus);
2480 add_stmt (stmt);
2481 may_fallthru = true;
2486 /* Now emit a definition of the label the cases branch to, if any. */
2487 if (may_fallthru)
2488 add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2489 gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2490 end_stmt_group (), NULL_TREE);
2492 return gnu_result;
2495 /* Find out whether VAR is an iteration variable of an enclosing loop in the
2496 current function. If so, push a range_check_info structure onto the stack
2497 of this enclosing loop and return it. Otherwise, return NULL. */
2499 static struct range_check_info_d *
2500 push_range_check_info (tree var)
2502 struct loop_info_d *iter = NULL;
2503 unsigned int i;
2505 if (vec_safe_is_empty (gnu_loop_stack))
2506 return NULL;
2508 var = remove_conversions (var, false);
2510 if (TREE_CODE (var) != VAR_DECL)
2511 return NULL;
2513 if (decl_function_context (var) != current_function_decl)
2514 return NULL;
2516 for (i = vec_safe_length (gnu_loop_stack) - 1;
2517 vec_safe_iterate (gnu_loop_stack, i, &iter);
2518 i--)
2519 if (var == iter->loop_var)
2520 break;
2522 if (iter)
2524 struct range_check_info_d *rci = ggc_alloc<range_check_info_d> ();
2525 vec_safe_push (iter->checks, rci);
2526 return rci;
2529 return NULL;
2532 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2533 false, or the maximum value if MAX is true, of TYPE. */
2535 static bool
2536 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2538 tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2540 if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2541 return true;
2543 if (TREE_CODE (val) == NOP_EXPR)
2544 val = (max
2545 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2546 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2548 if (TREE_CODE (val) != INTEGER_CST)
2549 return true;
2551 if (max)
2552 return tree_int_cst_lt (val, min_or_max_val) == 0;
2553 else
2554 return tree_int_cst_lt (min_or_max_val, val) == 0;
2557 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2558 If REVERSE is true, minimum value is taken as maximum value. */
2560 static inline bool
2561 can_equal_min_val_p (tree val, tree type, bool reverse)
2563 return can_equal_min_or_max_val_p (val, type, reverse);
2566 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2567 If REVERSE is true, maximum value is taken as minimum value. */
2569 static inline bool
2570 can_equal_max_val_p (tree val, tree type, bool reverse)
2572 return can_equal_min_or_max_val_p (val, type, !reverse);
2575 /* Return true if VAL1 can be lower than VAL2. */
2577 static bool
2578 can_be_lower_p (tree val1, tree val2)
2580 if (TREE_CODE (val1) == NOP_EXPR)
2581 val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0)));
2583 if (TREE_CODE (val1) != INTEGER_CST)
2584 return true;
2586 if (TREE_CODE (val2) == NOP_EXPR)
2587 val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0)));
2589 if (TREE_CODE (val2) != INTEGER_CST)
2590 return true;
2592 return tree_int_cst_lt (val1, val2);
2595 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2596 to a GCC tree, which is returned. */
2598 static tree
2599 Loop_Statement_to_gnu (Node_Id gnat_node)
2601 const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2602 struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> ();
2603 tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2604 NULL_TREE, NULL_TREE, NULL_TREE);
2605 tree gnu_loop_label = create_artificial_label (input_location);
2606 tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2607 tree gnu_result;
2609 /* Push the loop_info structure associated with the LOOP_STMT. */
2610 vec_safe_push (gnu_loop_stack, gnu_loop_info);
2612 /* Set location information for statement and end label. */
2613 set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2614 Sloc_to_locus (Sloc (End_Label (gnat_node)),
2615 &DECL_SOURCE_LOCATION (gnu_loop_label));
2616 LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2618 /* Save the statement for later reuse. */
2619 gnu_loop_info->stmt = gnu_loop_stmt;
2621 /* Set the condition under which the loop must keep going.
2622 For the case "LOOP .... END LOOP;" the condition is always true. */
2623 if (No (gnat_iter_scheme))
2626 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2627 else if (Present (Condition (gnat_iter_scheme)))
2628 LOOP_STMT_COND (gnu_loop_stmt)
2629 = gnat_to_gnu (Condition (gnat_iter_scheme));
2631 /* Otherwise we have an iteration scheme and the condition is given by the
2632 bounds of the subtype of the iteration variable. */
2633 else
2635 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2636 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2637 Entity_Id gnat_type = Etype (gnat_loop_var);
2638 tree gnu_type = get_unpadded_type (gnat_type);
2639 tree gnu_base_type = get_base_type (gnu_type);
2640 tree gnu_one_node = convert (gnu_base_type, integer_one_node);
2641 tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
2642 enum tree_code update_code, test_code, shift_code;
2643 bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
2645 gnu_low = TYPE_MIN_VALUE (gnu_type);
2646 gnu_high = TYPE_MAX_VALUE (gnu_type);
2648 /* We must disable modulo reduction for the iteration variable, if any,
2649 in order for the loop comparison to be effective. */
2650 if (reverse)
2652 gnu_first = gnu_high;
2653 gnu_last = gnu_low;
2654 update_code = MINUS_NOMOD_EXPR;
2655 test_code = GE_EXPR;
2656 shift_code = PLUS_NOMOD_EXPR;
2658 else
2660 gnu_first = gnu_low;
2661 gnu_last = gnu_high;
2662 update_code = PLUS_NOMOD_EXPR;
2663 test_code = LE_EXPR;
2664 shift_code = MINUS_NOMOD_EXPR;
2667 /* We use two different strategies to translate the loop, depending on
2668 whether optimization is enabled.
2670 If it is, we generate the canonical loop form expected by the loop
2671 optimizer and the loop vectorizer, which is the do-while form:
2673 ENTRY_COND
2674 loop:
2675 TOP_UPDATE
2676 BODY
2677 BOTTOM_COND
2678 GOTO loop
2680 This avoids an implicit dependency on loop header copying and makes
2681 it possible to turn BOTTOM_COND into an inequality test.
2683 If optimization is disabled, loop header copying doesn't come into
2684 play and we try to generate the loop form with the fewer conditional
2685 branches. First, the default form, which is:
2687 loop:
2688 TOP_COND
2689 BODY
2690 BOTTOM_UPDATE
2691 GOTO loop
2693 It should catch most loops with constant ending point. Then, if we
2694 cannot, we try to generate the shifted form:
2696 loop:
2697 TOP_COND
2698 TOP_UPDATE
2699 BODY
2700 GOTO loop
2702 which should catch loops with constant starting point. Otherwise, if
2703 we cannot, we generate the fallback form:
2705 ENTRY_COND
2706 loop:
2707 BODY
2708 BOTTOM_COND
2709 BOTTOM_UPDATE
2710 GOTO loop
2712 which works in all cases. */
2714 if (optimize)
2716 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
2717 overflow. */
2718 if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
2721 /* Otherwise, use the do-while form with the help of a special
2722 induction variable in the unsigned version of the base type
2723 or the unsigned version of the size type, whichever is the
2724 largest, in order to have wrap-around arithmetics for it. */
2725 else
2727 if (TYPE_PRECISION (gnu_base_type)
2728 > TYPE_PRECISION (size_type_node))
2729 gnu_base_type
2730 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type), 1);
2731 else
2732 gnu_base_type = size_type_node;
2734 gnu_first = convert (gnu_base_type, gnu_first);
2735 gnu_last = convert (gnu_base_type, gnu_last);
2736 gnu_one_node = convert (gnu_base_type, integer_one_node);
2737 use_iv = true;
2740 gnu_first
2741 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2742 gnu_one_node);
2743 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2744 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2746 else
2748 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
2749 if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
2752 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
2753 GNU_LAST-1 does. */
2754 else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
2755 && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
2757 gnu_first
2758 = build_binary_op (shift_code, gnu_base_type, gnu_first,
2759 gnu_one_node);
2760 gnu_last
2761 = build_binary_op (shift_code, gnu_base_type, gnu_last,
2762 gnu_one_node);
2763 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
2766 /* Otherwise, use the fallback form. */
2767 else
2768 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
2771 /* If we use the BOTTOM_COND, we can turn the test into an inequality
2772 test but we may have to add ENTRY_COND to protect the empty loop. */
2773 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
2775 test_code = NE_EXPR;
2776 if (can_be_lower_p (gnu_high, gnu_low))
2778 gnu_cond_expr
2779 = build3 (COND_EXPR, void_type_node,
2780 build_binary_op (LE_EXPR, boolean_type_node,
2781 gnu_low, gnu_high),
2782 NULL_TREE, alloc_stmt_list ());
2783 set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2787 /* Open a new nesting level that will surround the loop to declare the
2788 iteration variable. */
2789 start_stmt_group ();
2790 gnat_pushlevel ();
2792 /* If we use the special induction variable, create it and set it to
2793 its initial value. Morever, the regular iteration variable cannot
2794 itself be initialized, lest the initial value wrapped around. */
2795 if (use_iv)
2797 gnu_loop_iv
2798 = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
2799 add_stmt (gnu_stmt);
2800 gnu_first = NULL_TREE;
2802 else
2803 gnu_loop_iv = NULL_TREE;
2805 /* Declare the iteration variable and set it to its initial value. */
2806 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2807 if (DECL_BY_REF_P (gnu_loop_var))
2808 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2809 else if (use_iv)
2811 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
2812 SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
2814 gnu_loop_info->loop_var = gnu_loop_var;
2816 /* Do all the arithmetics in the base type. */
2817 gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
2819 /* Set either the top or bottom exit condition. */
2820 if (use_iv)
2821 LOOP_STMT_COND (gnu_loop_stmt)
2822 = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
2823 gnu_last);
2824 else
2825 LOOP_STMT_COND (gnu_loop_stmt)
2826 = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
2827 gnu_last);
2829 /* Set either the top or bottom update statement and give it the source
2830 location of the iteration for better coverage info. */
2831 if (use_iv)
2833 gnu_stmt
2834 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
2835 build_binary_op (update_code, gnu_base_type,
2836 gnu_loop_iv, gnu_one_node));
2837 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2838 append_to_statement_list (gnu_stmt,
2839 &LOOP_STMT_UPDATE (gnu_loop_stmt));
2840 gnu_stmt
2841 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2842 gnu_loop_iv);
2843 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2844 append_to_statement_list (gnu_stmt,
2845 &LOOP_STMT_UPDATE (gnu_loop_stmt));
2847 else
2849 gnu_stmt
2850 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
2851 build_binary_op (update_code, gnu_base_type,
2852 gnu_loop_var, gnu_one_node));
2853 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
2854 LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
2858 /* If the loop was named, have the name point to this loop. In this case,
2859 the association is not a DECL node, but the end label of the loop. */
2860 if (Present (Identifier (gnat_node)))
2861 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
2863 /* Make the loop body into its own block, so any allocated storage will be
2864 released every iteration. This is needed for stack allocation. */
2865 LOOP_STMT_BODY (gnu_loop_stmt)
2866 = build_stmt_group (Statements (gnat_node), true);
2867 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2869 /* If we have an iteration scheme, then we are in a statement group. Add
2870 the LOOP_STMT to it, finish it and make it the "loop". */
2871 if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
2873 struct range_check_info_d *rci;
2874 unsigned n_checks = vec_safe_length (gnu_loop_info->checks);
2875 unsigned int i;
2877 /* First, if we have computed a small number of invariant conditions for
2878 range checks applied to the iteration variable, then initialize these
2879 conditions in front of the loop. Otherwise, leave them set to true.
2881 ??? The heuristics need to be improved, by taking into account the
2882 following datapoints:
2883 - loop unswitching is disabled for big loops. The cap is the
2884 parameter PARAM_MAX_UNSWITCH_INSNS (50).
2885 - loop unswitching can only be applied a small number of times
2886 to a given loop. The cap is PARAM_MAX_UNSWITCH_LEVEL (3).
2887 - the front-end quickly generates useless or redundant checks
2888 that can be entirely optimized away in the end. */
2889 if (1 <= n_checks && n_checks <= 4)
2890 for (i = 0;
2891 vec_safe_iterate (gnu_loop_info->checks, i, &rci);
2892 i++)
2894 tree low_ok
2895 = rci->low_bound
2896 ? build_binary_op (GE_EXPR, boolean_type_node,
2897 convert (rci->type, gnu_low),
2898 rci->low_bound)
2899 : boolean_true_node;
2901 tree high_ok
2902 = rci->high_bound
2903 ? build_binary_op (LE_EXPR, boolean_type_node,
2904 convert (rci->type, gnu_high),
2905 rci->high_bound)
2906 : boolean_true_node;
2908 tree range_ok
2909 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
2910 low_ok, high_ok);
2912 TREE_OPERAND (rci->invariant_cond, 0)
2913 = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
2915 add_stmt_with_node_force (rci->invariant_cond, gnat_node);
2918 add_stmt (gnu_loop_stmt);
2919 gnat_poplevel ();
2920 gnu_loop_stmt = end_stmt_group ();
2923 /* If we have an outer COND_EXPR, that's our result and this loop is its
2924 "true" statement. Otherwise, the result is the LOOP_STMT. */
2925 if (gnu_cond_expr)
2927 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2928 TREE_SIDE_EFFECTS (gnu_cond_expr) = 1;
2929 gnu_result = gnu_cond_expr;
2931 else
2932 gnu_result = gnu_loop_stmt;
2934 gnu_loop_stack->pop ();
2936 return gnu_result;
2939 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2940 handler for the current function. */
2942 /* This is implemented by issuing a call to the appropriate VMS specific
2943 builtin. To avoid having VMS specific sections in the global gigi decls
2944 array, we maintain the decls of interest here. We can't declare them
2945 inside the function because we must mark them never to be GC'd, which we
2946 can only do at the global level. */
2948 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2949 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2951 static void
2952 establish_gnat_vms_condition_handler (void)
2954 tree establish_stmt;
2956 /* Elaborate the required decls on the first call. Check on the decl for
2957 the gnat condition handler to decide, as this is one we create so we are
2958 sure that it will be non null on subsequent calls. The builtin decl is
2959 looked up so remains null on targets where it is not implemented yet. */
2960 if (gnat_vms_condition_handler_decl == NULL_TREE)
2962 vms_builtin_establish_handler_decl
2963 = builtin_decl_for
2964 (get_identifier ("__builtin_establish_vms_condition_handler"));
2966 gnat_vms_condition_handler_decl
2967 = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2968 NULL_TREE,
2969 build_function_type_list (boolean_type_node,
2970 ptr_void_type_node,
2971 ptr_void_type_node,
2972 NULL_TREE),
2973 NULL_TREE, is_disabled, true, true, true, NULL,
2974 Empty);
2976 /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */
2977 DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2980 /* Do nothing if the establish builtin is not available, which might happen
2981 on targets where the facility is not implemented. */
2982 if (vms_builtin_establish_handler_decl == NULL_TREE)
2983 return;
2985 establish_stmt
2986 = build_call_n_expr (vms_builtin_establish_handler_decl, 1,
2987 build_unary_op
2988 (ADDR_EXPR, NULL_TREE,
2989 gnat_vms_condition_handler_decl));
2991 add_stmt (establish_stmt);
2994 /* This page implements a form of Named Return Value optimization modelled
2995 on the C++ optimization of the same name. The main difference is that
2996 we disregard any semantical considerations when applying it here, the
2997 counterpart being that we don't try to apply it to semantically loaded
2998 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3000 We consider a function body of the following GENERIC form:
3002 return_type R1;
3003 [...]
3004 RETURN_EXPR [<retval> = ...]
3005 [...]
3006 RETURN_EXPR [<retval> = R1]
3007 [...]
3008 return_type Ri;
3009 [...]
3010 RETURN_EXPR [<retval> = ...]
3011 [...]
3012 RETURN_EXPR [<retval> = Ri]
3013 [...]
3015 and we try to fulfill a simple criterion that would make it possible to
3016 replace one or several Ri variables with the RESULT_DECL of the function.
3018 The first observation is that RETURN_EXPRs that don't directly reference
3019 any of the Ri variables on the RHS of their assignment are transparent wrt
3020 the optimization. This is because the Ri variables aren't addressable so
3021 any transformation applied to them doesn't affect the RHS; moreover, the
3022 assignment writes the full <retval> object so existing values are entirely
3023 discarded.
3025 This property can be extended to some forms of RETURN_EXPRs that reference
3026 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3027 case, in particular when function calls are involved.
3029 Therefore the algorithm is as follows:
3031 1. Collect the list of candidates for a Named Return Value (Ri variables
3032 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3033 other expressions on the RHS of such assignments.
3035 2. Prune the members of the first list (candidates) that are referenced
3036 by a member of the second list (expressions).
3038 3. Extract a set of candidates with non-overlapping live ranges from the
3039 first list. These are the Named Return Values.
3041 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3042 Named Return Values in the function with the RESULT_DECL.
3044 If the function returns an unconstrained type, things are a bit different
3045 because the anonymous return object is allocated on the secondary stack
3046 and RESULT_DECL is only a pointer to it. Each return object can be of a
3047 different size and is allocated separately so we need not care about the
3048 aforementioned overlapping issues. Therefore, we don't collect the other
3049 expressions and skip step #2 in the algorithm. */
3051 struct nrv_data
3053 bitmap nrv;
3054 tree result;
3055 Node_Id gnat_ret;
3056 struct pointer_set_t *visited;
3059 /* Return true if T is a Named Return Value. */
3061 static inline bool
3062 is_nrv_p (bitmap nrv, tree t)
3064 return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t));
3067 /* Helper function for walk_tree, used by finalize_nrv below. */
3069 static tree
3070 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
3072 struct nrv_data *dp = (struct nrv_data *)data;
3073 tree t = *tp;
3075 /* No need to walk into types or decls. */
3076 if (IS_TYPE_OR_DECL_P (t))
3077 *walk_subtrees = 0;
3079 if (is_nrv_p (dp->nrv, t))
3080 bitmap_clear_bit (dp->nrv, DECL_UID (t));
3082 return NULL_TREE;
3085 /* Prune Named Return Values in BLOCK and return true if there is still a
3086 Named Return Value in BLOCK or one of its sub-blocks. */
3088 static bool
3089 prune_nrv_in_block (bitmap nrv, tree block)
3091 bool has_nrv = false;
3092 tree t;
3094 /* First recurse on the sub-blocks. */
3095 for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
3096 has_nrv |= prune_nrv_in_block (nrv, t);
3098 /* Then make sure to keep at most one NRV per block. */
3099 for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
3100 if (is_nrv_p (nrv, t))
3102 if (has_nrv)
3103 bitmap_clear_bit (nrv, DECL_UID (t));
3104 else
3105 has_nrv = true;
3108 return has_nrv;
3111 /* Helper function for walk_tree, used by finalize_nrv below. */
3113 static tree
3114 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
3116 struct nrv_data *dp = (struct nrv_data *)data;
3117 tree t = *tp;
3119 /* No need to walk into types. */
3120 if (TYPE_P (t))
3121 *walk_subtrees = 0;
3123 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3124 nop, but differs from using NULL_TREE in that it indicates that we care
3125 about the value of the RESULT_DECL. */
3126 else if (TREE_CODE (t) == RETURN_EXPR
3127 && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR)
3129 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1), init_expr;
3131 /* If this is the temporary created for a return value with variable
3132 size in Call_to_gnu, we replace the RHS with the init expression. */
3133 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3134 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
3135 && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
3136 == TREE_OPERAND (ret_val, 1))
3138 init_expr = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3139 ret_val = TREE_OPERAND (ret_val, 1);
3141 else
3142 init_expr = NULL_TREE;
3144 /* Strip useless conversions around the return value. */
3145 if (gnat_useless_type_conversion (ret_val))
3146 ret_val = TREE_OPERAND (ret_val, 0);
3148 if (is_nrv_p (dp->nrv, ret_val))
3150 if (init_expr)
3151 TREE_OPERAND (TREE_OPERAND (t, 0), 1) = init_expr;
3152 else
3153 TREE_OPERAND (t, 0) = dp->result;
3157 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3158 if needed. */
3159 else if (TREE_CODE (t) == DECL_EXPR
3160 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3162 tree var = DECL_EXPR_DECL (t), init;
3164 if (DECL_INITIAL (var))
3166 init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
3167 DECL_INITIAL (var));
3168 SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
3169 DECL_INITIAL (var) = NULL_TREE;
3171 else
3172 init = build_empty_stmt (EXPR_LOCATION (t));
3173 *tp = init;
3175 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3176 SET_DECL_VALUE_EXPR (var, dp->result);
3177 DECL_HAS_VALUE_EXPR_P (var) = 1;
3178 /* ??? Kludge to avoid an assertion failure during inlining. */
3179 DECL_SIZE (var) = bitsize_unit_node;
3180 DECL_SIZE_UNIT (var) = size_one_node;
3183 /* And replace all uses of NRVs with the RESULT_DECL. */
3184 else if (is_nrv_p (dp->nrv, t))
3185 *tp = convert (TREE_TYPE (t), dp->result);
3187 /* Avoid walking into the same tree more than once. Unfortunately, we
3188 can't just use walk_tree_without_duplicates because it would only
3189 call us for the first occurrence of NRVs in the function body. */
3190 if (pointer_set_insert (dp->visited, *tp))
3191 *walk_subtrees = 0;
3193 return NULL_TREE;
3196 /* Likewise, but used when the function returns an unconstrained type. */
3198 static tree
3199 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
3201 struct nrv_data *dp = (struct nrv_data *)data;
3202 tree t = *tp;
3204 /* No need to walk into types. */
3205 if (TYPE_P (t))
3206 *walk_subtrees = 0;
3208 /* We need to see the DECL_EXPR of NRVs before any other references so we
3209 walk the body of BIND_EXPR before walking its variables. */
3210 else if (TREE_CODE (t) == BIND_EXPR)
3211 walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
3213 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3214 return value built by the allocator instead of the whole construct. */
3215 else if (TREE_CODE (t) == RETURN_EXPR
3216 && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR)
3218 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3220 /* This is the construct returned by the allocator. */
3221 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3222 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
3224 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
3225 ret_val
3226 = (*CONSTRUCTOR_ELTS (TREE_OPERAND (TREE_OPERAND (ret_val, 0),
3227 1)))[1].value;
3228 else
3229 ret_val = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3232 /* Strip useless conversions around the return value. */
3233 if (gnat_useless_type_conversion (ret_val)
3234 || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
3235 ret_val = TREE_OPERAND (ret_val, 0);
3237 /* Strip unpadding around the return value. */
3238 if (TREE_CODE (ret_val) == COMPONENT_REF
3239 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
3240 ret_val = TREE_OPERAND (ret_val, 0);
3242 /* Assign the new return value to the RESULT_DECL. */
3243 if (is_nrv_p (dp->nrv, ret_val))
3244 TREE_OPERAND (TREE_OPERAND (t, 0), 1)
3245 = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
3248 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3249 into a new variable. */
3250 else if (TREE_CODE (t) == DECL_EXPR
3251 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3253 tree saved_current_function_decl = current_function_decl;
3254 tree var = DECL_EXPR_DECL (t);
3255 tree alloc, p_array, new_var, new_ret;
3256 vec<constructor_elt, va_gc> *v;
3257 vec_alloc (v, 2);
3259 /* Create an artificial context to build the allocation. */
3260 current_function_decl = decl_function_context (var);
3261 start_stmt_group ();
3262 gnat_pushlevel ();
3264 /* This will return a COMPOUND_EXPR with the allocation in the first
3265 arm and the final return value in the second arm. */
3266 alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
3267 TREE_TYPE (dp->result),
3268 Procedure_To_Call (dp->gnat_ret),
3269 Storage_Pool (dp->gnat_ret),
3270 Empty, false);
3272 /* The new variable is built as a reference to the allocated space. */
3273 new_var
3274 = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
3275 build_reference_type (TREE_TYPE (var)));
3276 DECL_BY_REFERENCE (new_var) = 1;
3278 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
3280 /* The new initial value is a COMPOUND_EXPR with the allocation in
3281 the first arm and the value of P_ARRAY in the second arm. */
3282 DECL_INITIAL (new_var)
3283 = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
3284 TREE_OPERAND (alloc, 0),
3285 (*CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)))[0].value);
3287 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3288 p_array = TYPE_FIELDS (TREE_TYPE (alloc));
3289 CONSTRUCTOR_APPEND_ELT (v, p_array,
3290 fold_convert (TREE_TYPE (p_array), new_var));
3291 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
3292 (*CONSTRUCTOR_ELTS (
3293 TREE_OPERAND (alloc, 1)))[1].value);
3294 new_ret = build_constructor (TREE_TYPE (alloc), v);
3296 else
3298 /* The new initial value is just the allocation. */
3299 DECL_INITIAL (new_var) = alloc;
3300 new_ret = fold_convert (TREE_TYPE (alloc), new_var);
3303 gnat_pushdecl (new_var, Empty);
3305 /* Destroy the artificial context and insert the new statements. */
3306 gnat_zaplevel ();
3307 *tp = end_stmt_group ();
3308 current_function_decl = saved_current_function_decl;
3310 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3311 DECL_CHAIN (new_var) = DECL_CHAIN (var);
3312 DECL_CHAIN (var) = new_var;
3313 DECL_IGNORED_P (var) = 1;
3315 /* Save the new return value and the dereference of NEW_VAR. */
3316 DECL_INITIAL (var)
3317 = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
3318 build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
3319 /* ??? Kludge to avoid messing up during inlining. */
3320 DECL_CONTEXT (var) = NULL_TREE;
3323 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3324 else if (is_nrv_p (dp->nrv, t))
3325 *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
3327 /* Avoid walking into the same tree more than once. Unfortunately, we
3328 can't just use walk_tree_without_duplicates because it would only
3329 call us for the first occurrence of NRVs in the function body. */
3330 if (pointer_set_insert (dp->visited, *tp))
3331 *walk_subtrees = 0;
3333 return NULL_TREE;
3336 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3337 contains the candidates for Named Return Value and OTHER is a list of
3338 the other return values. GNAT_RET is a representative return node. */
3340 static void
3341 finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret)
3343 struct cgraph_node *node;
3344 struct nrv_data data;
3345 walk_tree_fn func;
3346 unsigned int i;
3347 tree iter;
3349 /* We shouldn't be applying the optimization to return types that we aren't
3350 allowed to manipulate freely. */
3351 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3353 /* Prune the candidates that are referenced by other return values. */
3354 data.nrv = nrv;
3355 data.result = NULL_TREE;
3356 data.visited = NULL;
3357 for (i = 0; vec_safe_iterate (other, i, &iter); i++)
3358 walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3359 if (bitmap_empty_p (nrv))
3360 return;
3362 /* Prune also the candidates that are referenced by nested functions. */
3363 node = cgraph_get_create_node (fndecl);
3364 for (node = node->nested; node; node = node->next_nested)
3365 walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r,
3366 &data);
3367 if (bitmap_empty_p (nrv))
3368 return;
3370 /* Extract a set of NRVs with non-overlapping live ranges. */
3371 if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3372 return;
3374 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3375 data.nrv = nrv;
3376 data.result = DECL_RESULT (fndecl);
3377 data.gnat_ret = gnat_ret;
3378 data.visited = pointer_set_create ();
3379 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
3380 func = finalize_nrv_unc_r;
3381 else
3382 func = finalize_nrv_r;
3383 walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3384 pointer_set_destroy (data.visited);
3387 /* Return true if RET_VAL can be used as a Named Return Value for the
3388 anonymous return object RET_OBJ. */
3390 static bool
3391 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3393 if (TREE_CODE (ret_val) != VAR_DECL)
3394 return false;
3396 if (TREE_THIS_VOLATILE (ret_val))
3397 return false;
3399 if (DECL_CONTEXT (ret_val) != current_function_decl)
3400 return false;
3402 if (TREE_STATIC (ret_val))
3403 return false;
3405 if (TREE_ADDRESSABLE (ret_val))
3406 return false;
3408 if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3409 return false;
3411 return true;
3414 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3415 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3416 around RESULT_OBJ, which may be null in this case. */
3418 static tree
3419 build_return_expr (tree ret_obj, tree ret_val)
3421 tree result_expr;
3423 if (ret_val)
3425 /* The gimplifier explicitly enforces the following invariant:
3427 RETURN_EXPR
3429 MODIFY_EXPR
3432 RET_OBJ ...
3434 As a consequence, type consistency dictates that we use the type
3435 of the RET_OBJ as the operation type. */
3436 tree operation_type = TREE_TYPE (ret_obj);
3438 /* Convert the right operand to the operation type. Note that it's the
3439 same transformation as in the MODIFY_EXPR case of build_binary_op,
3440 with the assumption that the type cannot involve a placeholder. */
3441 if (operation_type != TREE_TYPE (ret_val))
3442 ret_val = convert (operation_type, ret_val);
3444 result_expr = build2 (MODIFY_EXPR, void_type_node, ret_obj, ret_val);
3446 /* If the function returns an aggregate type, find out whether this is
3447 a candidate for Named Return Value. If so, record it. Otherwise,
3448 if this is an expression of some kind, record it elsewhere. */
3449 if (optimize
3450 && AGGREGATE_TYPE_P (operation_type)
3451 && !TYPE_IS_FAT_POINTER_P (operation_type)
3452 && TYPE_MODE (operation_type) == BLKmode
3453 && aggregate_value_p (operation_type, current_function_decl))
3455 /* Recognize the temporary created for a return value with variable
3456 size in Call_to_gnu. We want to eliminate it if possible. */
3457 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3458 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR
3459 && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0)
3460 == TREE_OPERAND (ret_val, 1))
3461 ret_val = TREE_OPERAND (ret_val, 1);
3463 /* Strip useless conversions around the return value. */
3464 if (gnat_useless_type_conversion (ret_val))
3465 ret_val = TREE_OPERAND (ret_val, 0);
3467 /* Now apply the test to the return value. */
3468 if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3470 if (!f_named_ret_val)
3471 f_named_ret_val = BITMAP_GGC_ALLOC ();
3472 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3475 /* Note that we need not care about CONSTRUCTORs here, as they are
3476 totally transparent given the read-compose-write semantics of
3477 assignments from CONSTRUCTORs. */
3478 else if (EXPR_P (ret_val))
3479 vec_safe_push (f_other_ret_val, ret_val);
3482 else
3483 result_expr = ret_obj;
3485 return build1 (RETURN_EXPR, void_type_node, result_expr);
3488 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
3489 and the GNAT node GNAT_SUBPROG. */
3491 static void
3492 build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
3494 tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
3495 tree gnu_subprog_param, gnu_stub_param, gnu_param;
3496 tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
3497 vec<tree, va_gc> *gnu_param_vec = NULL;
3499 gnu_subprog_type = TREE_TYPE (gnu_subprog);
3501 /* Initialize the information structure for the function. */
3502 allocate_struct_function (gnu_stub_decl, false);
3503 set_cfun (NULL);
3505 begin_subprog_body (gnu_stub_decl);
3507 start_stmt_group ();
3508 gnat_pushlevel ();
3510 /* Loop over the parameters of the stub and translate any of them
3511 passed by descriptor into a by reference one. */
3512 for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
3513 gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog);
3514 gnu_stub_param;
3515 gnu_stub_param = DECL_CHAIN (gnu_stub_param),
3516 gnu_subprog_param = DECL_CHAIN (gnu_subprog_param))
3518 if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
3520 gcc_assert (DECL_BY_REF_P (gnu_subprog_param));
3521 gnu_param
3522 = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param),
3523 gnu_stub_param,
3524 DECL_PARM_ALT_TYPE (gnu_stub_param),
3525 gnat_subprog);
3527 else
3528 gnu_param = gnu_stub_param;
3530 vec_safe_push (gnu_param_vec, gnu_param);
3533 /* Invoke the internal subprogram. */
3534 gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type),
3535 gnu_subprog);
3536 gnu_subprog_call = build_call_vec (TREE_TYPE (gnu_subprog_type),
3537 gnu_subprog_addr, gnu_param_vec);
3539 /* Propagate the return value, if any. */
3540 if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type)))
3541 add_stmt (gnu_subprog_call);
3542 else
3543 add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl),
3544 gnu_subprog_call));
3546 gnat_poplevel ();
3547 end_subprog_body (end_stmt_group ());
3548 rest_of_subprog_body_compilation (gnu_stub_decl);
3551 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3552 don't return anything. */
3554 static void
3555 Subprogram_Body_to_gnu (Node_Id gnat_node)
3557 /* Defining identifier of a parameter to the subprogram. */
3558 Entity_Id gnat_param;
3559 /* The defining identifier for the subprogram body. Note that if a
3560 specification has appeared before for this body, then the identifier
3561 occurring in that specification will also be a defining identifier and all
3562 the calls to this subprogram will point to that specification. */
3563 Entity_Id gnat_subprog_id
3564 = (Present (Corresponding_Spec (gnat_node))
3565 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
3566 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3567 tree gnu_subprog_decl;
3568 /* Its RESULT_DECL node. */
3569 tree gnu_result_decl;
3570 /* Its FUNCTION_TYPE node. */
3571 tree gnu_subprog_type;
3572 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3573 tree gnu_cico_list;
3574 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3575 tree gnu_return_var_elmt = NULL_TREE;
3576 tree gnu_result;
3577 struct language_function *gnu_subprog_language;
3578 vec<parm_attr, va_gc> *cache;
3580 /* If this is a generic object or if it has been eliminated,
3581 ignore it. */
3582 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
3583 || Ekind (gnat_subprog_id) == E_Generic_Function
3584 || Is_Eliminated (gnat_subprog_id))
3585 return;
3587 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3588 the already-elaborated tree node. However, if this subprogram had its
3589 elaboration deferred, we will already have made a tree node for it. So
3590 treat it as not being defined in that case. Such a subprogram cannot
3591 have an address clause or a freeze node, so this test is safe, though it
3592 does disable some otherwise-useful error checking. */
3593 gnu_subprog_decl
3594 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
3595 Acts_As_Spec (gnat_node)
3596 && !present_gnu_tree (gnat_subprog_id));
3597 gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
3598 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
3599 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3600 if (gnu_cico_list)
3601 gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list);
3603 /* If the function returns by invisible reference, make it explicit in the
3604 function body. See gnat_to_gnu_entity, E_Subprogram_Type case.
3605 Handle the explicit case here and the copy-in/copy-out case below. */
3606 if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt)
3608 TREE_TYPE (gnu_result_decl)
3609 = build_reference_type (TREE_TYPE (gnu_result_decl));
3610 relayout_decl (gnu_result_decl);
3613 /* Set the line number in the decl to correspond to that of the body so that
3614 the line number notes are written correctly. */
3615 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
3617 /* Initialize the information structure for the function. */
3618 allocate_struct_function (gnu_subprog_decl, false);
3619 gnu_subprog_language = ggc_cleared_alloc<language_function> ();
3620 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
3621 set_cfun (NULL);
3623 begin_subprog_body (gnu_subprog_decl);
3625 /* If there are In Out or Out parameters, we need to ensure that the return
3626 statement properly copies them out. We do this by making a new block and
3627 converting any return into a goto to a label at the end of the block. */
3628 if (gnu_cico_list)
3630 tree gnu_return_var = NULL_TREE;
3632 vec_safe_push (gnu_return_label_stack,
3633 create_artificial_label (input_location));
3635 start_stmt_group ();
3636 gnat_pushlevel ();
3638 /* If this is a function with In Out or Out parameters, we also need a
3639 variable for the return value to be placed. */
3640 if (gnu_return_var_elmt)
3642 tree gnu_return_type
3643 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
3645 /* If the function returns by invisible reference, make it
3646 explicit in the function body. See gnat_to_gnu_entity,
3647 E_Subprogram_Type case. */
3648 if (TREE_ADDRESSABLE (gnu_subprog_type))
3649 gnu_return_type = build_reference_type (gnu_return_type);
3651 gnu_return_var
3652 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
3653 gnu_return_type, NULL_TREE, false, false,
3654 false, false, NULL, gnat_subprog_id);
3655 TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
3658 vec_safe_push (gnu_return_var_stack, gnu_return_var);
3660 /* See whether there are parameters for which we don't have a GCC tree
3661 yet. These must be Out parameters. Make a VAR_DECL for them and
3662 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3663 We can match up the entries because TYPE_CI_CO_LIST is in the order
3664 of the parameters. */
3665 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3666 Present (gnat_param);
3667 gnat_param = Next_Formal_With_Extras (gnat_param))
3668 if (!present_gnu_tree (gnat_param))
3670 tree gnu_cico_entry = gnu_cico_list;
3671 tree gnu_decl;
3673 /* Skip any entries that have been already filled in; they must
3674 correspond to In Out parameters. */
3675 while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
3676 gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
3678 /* Do any needed dereferences for by-ref objects. */
3679 gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, 1);
3680 gcc_assert (DECL_P (gnu_decl));
3681 if (DECL_BY_REF_P (gnu_decl))
3682 gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl);
3684 /* Do any needed references for padded types. */
3685 TREE_VALUE (gnu_cico_entry)
3686 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl);
3689 else
3690 vec_safe_push (gnu_return_label_stack, NULL_TREE);
3692 /* Get a tree corresponding to the code for the subprogram. */
3693 start_stmt_group ();
3694 gnat_pushlevel ();
3696 /* On VMS, establish our condition handler to possibly turn a condition into
3697 the corresponding exception if the subprogram has a foreign convention or
3698 is exported.
3700 To ensure proper execution of local finalizations on condition instances,
3701 we must turn a condition into the corresponding exception even if there
3702 is no applicable Ada handler, and need at least one condition handler per
3703 possible call chain involving GNAT code. OTOH, establishing the handler
3704 has a cost so we want to minimize the number of subprograms into which
3705 this happens. The foreign or exported condition is expected to satisfy
3706 all the constraints. */
3707 if (TARGET_ABI_OPEN_VMS
3708 && (Has_Foreign_Convention (gnat_subprog_id)
3709 || Is_Exported (gnat_subprog_id)))
3710 establish_gnat_vms_condition_handler ();
3712 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3714 /* Generate the code of the subprogram itself. A return statement will be
3715 present and any Out parameters will be handled there. */
3716 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3717 gnat_poplevel ();
3718 gnu_result = end_stmt_group ();
3720 /* If we populated the parameter attributes cache, we need to make sure that
3721 the cached expressions are evaluated on all the possible paths leading to
3722 their uses. So we force their evaluation on entry of the function. */
3723 cache = gnu_subprog_language->parm_attr_cache;
3724 if (cache)
3726 struct parm_attr_d *pa;
3727 int i;
3729 start_stmt_group ();
3731 FOR_EACH_VEC_ELT (*cache, i, pa)
3733 if (pa->first)
3734 add_stmt_with_node_force (pa->first, gnat_node);
3735 if (pa->last)
3736 add_stmt_with_node_force (pa->last, gnat_node);
3737 if (pa->length)
3738 add_stmt_with_node_force (pa->length, gnat_node);
3741 add_stmt (gnu_result);
3742 gnu_result = end_stmt_group ();
3744 gnu_subprog_language->parm_attr_cache = NULL;
3747 /* If we are dealing with a return from an Ada procedure with parameters
3748 passed by copy-in/copy-out, we need to return a record containing the
3749 final values of these parameters. If the list contains only one entry,
3750 return just that entry though.
3752 For a full description of the copy-in/copy-out parameter mechanism, see
3753 the part of the gnat_to_gnu_entity routine dealing with the translation
3754 of subprograms.
3756 We need to make a block that contains the definition of that label and
3757 the copying of the return value. It first contains the function, then
3758 the label and copy statement. */
3759 if (gnu_cico_list)
3761 tree gnu_retval;
3763 gnu_return_var_stack->pop ();
3765 add_stmt (gnu_result);
3766 add_stmt (build1 (LABEL_EXPR, void_type_node,
3767 gnu_return_label_stack->last ()));
3769 if (list_length (gnu_cico_list) == 1)
3770 gnu_retval = TREE_VALUE (gnu_cico_list);
3771 else
3772 gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
3773 gnu_cico_list);
3775 add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
3776 End_Label (Handled_Statement_Sequence (gnat_node)));
3777 gnat_poplevel ();
3778 gnu_result = end_stmt_group ();
3781 gnu_return_label_stack->pop ();
3783 /* Attempt setting the end_locus of our GCC body tree, typically a
3784 BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram
3785 declaration tree. */
3786 set_end_locus_from_node (gnu_result, gnat_node);
3787 set_end_locus_from_node (gnu_subprog_decl, gnat_node);
3789 /* On SEH targets, install an exception handler around the main entry
3790 point to catch unhandled exceptions. */
3791 if (DECL_NAME (gnu_subprog_decl) == main_identifier_node
3792 && targetm_common.except_unwind_info (&global_options) == UI_SEH)
3794 tree t;
3795 tree etype;
3797 t = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
3798 1, integer_zero_node);
3799 t = build_call_n_expr (unhandled_except_decl, 1, t);
3801 etype = build_unary_op (ADDR_EXPR, NULL_TREE, unhandled_others_decl);
3802 etype = tree_cons (NULL_TREE, etype, NULL_TREE);
3804 t = build2 (CATCH_EXPR, void_type_node, etype, t);
3805 gnu_result = build2 (TRY_CATCH_EXPR, TREE_TYPE (gnu_result),
3806 gnu_result, t);
3809 end_subprog_body (gnu_result);
3811 /* Finally annotate the parameters and disconnect the trees for parameters
3812 that we have turned into variables since they are now unusable. */
3813 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3814 Present (gnat_param);
3815 gnat_param = Next_Formal_With_Extras (gnat_param))
3817 tree gnu_param = get_gnu_tree (gnat_param);
3818 bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
3820 annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
3821 DECL_BY_REF_P (gnu_param));
3823 if (is_var_decl)
3824 save_gnu_tree (gnat_param, NULL_TREE, false);
3827 /* Disconnect the variable created for the return value. */
3828 if (gnu_return_var_elmt)
3829 TREE_VALUE (gnu_return_var_elmt) = void_type_node;
3831 /* If the function returns an aggregate type and we have candidates for
3832 a Named Return Value, finalize the optimization. */
3833 if (optimize && gnu_subprog_language->named_ret_val)
3835 finalize_nrv (gnu_subprog_decl,
3836 gnu_subprog_language->named_ret_val,
3837 gnu_subprog_language->other_ret_val,
3838 gnu_subprog_language->gnat_ret);
3839 gnu_subprog_language->named_ret_val = NULL;
3840 gnu_subprog_language->other_ret_val = NULL;
3843 rest_of_subprog_body_compilation (gnu_subprog_decl);
3845 /* If there is a stub associated with the function, build it now. */
3846 if (DECL_FUNCTION_STUB (gnu_subprog_decl))
3847 build_function_stub (gnu_subprog_decl, gnat_subprog_id);
3850 /* Return true if GNAT_NODE requires atomic synchronization. */
3852 static bool
3853 atomic_sync_required_p (Node_Id gnat_node)
3855 const Node_Id gnat_parent = Parent (gnat_node);
3856 Node_Kind kind;
3857 unsigned char attr_id;
3859 /* First, scan the node to find the Atomic_Sync_Required flag. */
3860 kind = Nkind (gnat_node);
3861 if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
3863 gnat_node = Expression (gnat_node);
3864 kind = Nkind (gnat_node);
3867 switch (kind)
3869 case N_Expanded_Name:
3870 case N_Explicit_Dereference:
3871 case N_Identifier:
3872 case N_Indexed_Component:
3873 case N_Selected_Component:
3874 if (!Atomic_Sync_Required (gnat_node))
3875 return false;
3876 break;
3878 default:
3879 return false;
3882 /* Then, scan the parent to find out cases where the flag is irrelevant. */
3883 kind = Nkind (gnat_parent);
3884 switch (kind)
3886 case N_Attribute_Reference:
3887 attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
3888 /* Do not mess up machine code insertions. */
3889 if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
3890 return false;
3891 break;
3893 case N_Object_Renaming_Declaration:
3894 /* Do not generate a function call as a renamed object. */
3895 return false;
3897 default:
3898 break;
3901 return true;
3904 /* Create a temporary variable with PREFIX and TYPE, and return it. */
3906 static tree
3907 create_temporary (const char *prefix, tree type)
3909 tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
3910 type, NULL_TREE, false, false, false, false,
3911 NULL, Empty);
3912 DECL_ARTIFICIAL (gnu_temp) = 1;
3913 DECL_IGNORED_P (gnu_temp) = 1;
3915 return gnu_temp;
3918 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
3919 Put the initialization statement into GNU_INIT_STMT and annotate it with
3920 the SLOC of GNAT_NODE. Return the temporary variable. */
3922 static tree
3923 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
3924 Node_Id gnat_node)
3926 tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
3928 *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
3929 set_expr_location_from_node (*gnu_init_stmt, gnat_node);
3931 return gnu_temp;
3934 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
3935 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
3936 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
3937 If GNU_TARGET is non-null, this must be a function call on the RHS of a
3938 N_Assignment_Statement and the result is to be placed into that object.
3939 If, in addition, ATOMIC_SYNC is true, then the assignment to GNU_TARGET
3940 requires atomic synchronization. */
3942 static tree
3943 Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
3944 bool atomic_sync)
3946 const bool function_call = (Nkind (gnat_node) == N_Function_Call);
3947 const bool returning_value = (function_call && !gnu_target);
3948 /* The GCC node corresponding to the GNAT subprogram name. This can either
3949 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
3950 or an indirect reference expression (an INDIRECT_REF node) pointing to a
3951 subprogram. */
3952 tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
3953 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
3954 tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
3955 /* The return type of the FUNCTION_TYPE. */
3956 tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
3957 tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
3958 vec<tree, va_gc> *gnu_actual_vec = NULL;
3959 tree gnu_name_list = NULL_TREE;
3960 tree gnu_stmt_list = NULL_TREE;
3961 tree gnu_after_list = NULL_TREE;
3962 tree gnu_retval = NULL_TREE;
3963 tree gnu_call, gnu_result;
3964 bool went_into_elab_proc = false;
3965 bool pushed_binding_level = false;
3966 Entity_Id gnat_formal;
3967 Node_Id gnat_actual;
3969 gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
3971 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
3972 all our args first. */
3973 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
3975 tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
3976 gnat_node, N_Raise_Program_Error);
3978 for (gnat_actual = First_Actual (gnat_node);
3979 Present (gnat_actual);
3980 gnat_actual = Next_Actual (gnat_actual))
3981 add_stmt (gnat_to_gnu (gnat_actual));
3983 if (returning_value)
3985 *gnu_result_type_p = gnu_result_type;
3986 return build1 (NULL_EXPR, gnu_result_type, call_expr);
3989 return call_expr;
3992 /* The only way we can be making a call via an access type is if Name is an
3993 explicit dereference. In that case, get the list of formal args from the
3994 type the access type is pointing to. Otherwise, get the formals from the
3995 entity being called. */
3996 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
3997 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
3998 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
3999 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4000 gnat_formal = Empty;
4001 else
4002 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4004 /* The lifetime of the temporaries created for the call ends right after the
4005 return value is copied, so we can give them the scope of the elaboration
4006 routine at top level. */
4007 if (!current_function_decl)
4009 current_function_decl = get_elaboration_procedure ();
4010 went_into_elab_proc = true;
4013 /* First, create the temporary for the return value when:
4015 1. There is no target and the function has copy-in/copy-out parameters,
4016 because we need to preserve the return value before copying back the
4017 parameters.
4019 2. There is no target and this is not an object declaration, and the
4020 return type has variable size, because in these cases the gimplifier
4021 cannot create the temporary.
4023 3. There is a target and it is a slice or an array with fixed size,
4024 and the return type has variable size, because the gimplifier
4025 doesn't handle these cases.
4027 This must be done before we push a binding level around the call, since
4028 we will pop it before copying the return value. */
4029 if (function_call
4030 && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
4031 || (!gnu_target
4032 && Nkind (Parent (gnat_node)) != N_Object_Declaration
4033 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
4034 || (gnu_target
4035 && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
4036 || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
4037 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
4038 == INTEGER_CST))
4039 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)))
4040 gnu_retval = create_temporary ("R", gnu_result_type);
4042 /* Create the list of the actual parameters as GCC expects it, namely a
4043 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4044 is an expression and the TREE_PURPOSE field is null. But skip Out
4045 parameters not passed by reference and that need not be copied in. */
4046 for (gnat_actual = First_Actual (gnat_node);
4047 Present (gnat_actual);
4048 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4049 gnat_actual = Next_Actual (gnat_actual))
4051 tree gnu_formal = present_gnu_tree (gnat_formal)
4052 ? get_gnu_tree (gnat_formal) : NULL_TREE;
4053 tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
4054 const bool is_true_formal_parm
4055 = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
4056 const bool is_by_ref_formal_parm
4057 = is_true_formal_parm
4058 && (DECL_BY_REF_P (gnu_formal)
4059 || DECL_BY_COMPONENT_PTR_P (gnu_formal)
4060 || DECL_BY_DESCRIPTOR_P (gnu_formal));
4061 /* In the Out or In Out case, we must suppress conversions that yield
4062 an lvalue but can nevertheless cause the creation of a temporary,
4063 because we need the real object in this case, either to pass its
4064 address if it's passed by reference or as target of the back copy
4065 done after the call if it uses the copy-in/copy-out mechanism.
4066 We do it in the In case too, except for an unchecked conversion
4067 because it alone can cause the actual to be misaligned and the
4068 addressability test is applied to the real object. */
4069 const bool suppress_type_conversion
4070 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
4071 && Ekind (gnat_formal) != E_In_Parameter)
4072 || (Nkind (gnat_actual) == N_Type_Conversion
4073 && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
4074 Node_Id gnat_name = suppress_type_conversion
4075 ? Expression (gnat_actual) : gnat_actual;
4076 tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
4077 tree gnu_actual;
4079 /* If it's possible we may need to use this expression twice, make sure
4080 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4081 to force side-effects before the call.
4082 ??? This is more conservative than we need since we don't need to do
4083 this for pass-by-ref with no conversion. */
4084 if (Ekind (gnat_formal) != E_In_Parameter)
4085 gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
4087 /* If we are passing a non-addressable parameter by reference, pass the
4088 address of a copy. In the Out or In Out case, set up to copy back
4089 out after the call. */
4090 if (is_by_ref_formal_parm
4091 && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
4092 && !addressable_p (gnu_name, gnu_name_type))
4094 bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
4095 tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
4097 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4098 but sort of an instantiation for them. */
4099 if (TREE_CODE (gnu_name) == CONSTRUCTOR)
4102 /* If the type is passed by reference, a copy is not allowed. */
4103 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type))
4104 post_error ("misaligned actual cannot be passed by reference",
4105 gnat_actual);
4107 /* For users of Starlet we issue a warning because the interface
4108 apparently assumes that by-ref parameters outlive the procedure
4109 invocation. The code still will not work as intended, but we
4110 cannot do much better since low-level parts of the back-end
4111 would allocate temporaries at will because of the misalignment
4112 if we did not do so here. */
4113 else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
4115 post_error
4116 ("?possible violation of implicit assumption", gnat_actual);
4117 post_error_ne
4118 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
4119 Entity (Name (gnat_node)));
4120 post_error_ne ("?because of misalignment of &", gnat_actual,
4121 gnat_formal);
4124 /* If the actual type of the object is already the nominal type,
4125 we have nothing to do, except if the size is self-referential
4126 in which case we'll remove the unpadding below. */
4127 if (TREE_TYPE (gnu_name) == gnu_name_type
4128 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
4131 /* Otherwise remove the unpadding from all the objects. */
4132 else if (TREE_CODE (gnu_name) == COMPONENT_REF
4133 && TYPE_IS_PADDING_P
4134 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
4135 gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
4137 /* Otherwise convert to the nominal type of the object if needed.
4138 There are several cases in which we need to make the temporary
4139 using this type instead of the actual type of the object when
4140 they are distinct, because the expectations of the callee would
4141 otherwise not be met:
4142 - if it's a justified modular type,
4143 - if the actual type is a smaller form of it,
4144 - if it's a smaller form of the actual type. */
4145 else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
4146 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
4147 || smaller_form_type_p (TREE_TYPE (gnu_name),
4148 gnu_name_type)))
4149 || (INTEGRAL_TYPE_P (gnu_name_type)
4150 && smaller_form_type_p (gnu_name_type,
4151 TREE_TYPE (gnu_name))))
4152 gnu_name = convert (gnu_name_type, gnu_name);
4154 /* If this is an In Out or Out parameter and we're returning a value,
4155 we need to create a temporary for the return value because we must
4156 preserve it before copying back at the very end. */
4157 if (!in_param && returning_value && !gnu_retval)
4158 gnu_retval = create_temporary ("R", gnu_result_type);
4160 /* If we haven't pushed a binding level, push a new one. This will
4161 narrow the lifetime of the temporary we are about to make as much
4162 as possible. The drawback is that we'd need to create a temporary
4163 for the return value, if any (see comment before the loop). So do
4164 it only when this temporary was already created just above. */
4165 if (!pushed_binding_level && !(in_param && returning_value))
4167 start_stmt_group ();
4168 gnat_pushlevel ();
4169 pushed_binding_level = true;
4172 /* Create an explicit temporary holding the copy. */
4173 gnu_temp
4174 = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
4176 /* But initialize it on the fly like for an implicit temporary as
4177 we aren't necessarily having a statement list. */
4178 gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
4179 gnu_temp);
4181 /* Set up to move the copy back to the original if needed. */
4182 if (!in_param)
4184 /* If the original is a COND_EXPR whose first arm isn't meant to
4185 be further used, just deal with the second arm. This is very
4186 likely the conditional expression built for a check. */
4187 if (TREE_CODE (gnu_orig) == COND_EXPR
4188 && TREE_CODE (TREE_OPERAND (gnu_orig, 1)) == COMPOUND_EXPR
4189 && integer_zerop
4190 (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1)))
4191 gnu_orig = TREE_OPERAND (gnu_orig, 2);
4193 gnu_stmt
4194 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp);
4195 set_expr_location_from_node (gnu_stmt, gnat_node);
4197 append_to_statement_list (gnu_stmt, &gnu_after_list);
4201 /* Start from the real object and build the actual. */
4202 gnu_actual = gnu_name;
4204 /* If this is an atomic access of an In or In Out parameter for which
4205 synchronization is required, build the atomic load. */
4206 if (is_true_formal_parm
4207 && !is_by_ref_formal_parm
4208 && Ekind (gnat_formal) != E_Out_Parameter
4209 && atomic_sync_required_p (gnat_actual))
4210 gnu_actual = build_atomic_load (gnu_actual);
4212 /* If this was a procedure call, we may not have removed any padding.
4213 So do it here for the part we will use as an input, if any. */
4214 if (Ekind (gnat_formal) != E_Out_Parameter
4215 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4216 gnu_actual
4217 = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
4219 /* Put back the conversion we suppressed above in the computation of the
4220 real object. And even if we didn't suppress any conversion there, we
4221 may have suppressed a conversion to the Etype of the actual earlier,
4222 since the parent is a procedure call, so put it back here. */
4223 if (suppress_type_conversion
4224 && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4225 gnu_actual
4226 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
4227 gnu_actual, No_Truncation (gnat_actual));
4228 else
4229 gnu_actual
4230 = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
4232 /* Make sure that the actual is in range of the formal's type. */
4233 if (Ekind (gnat_formal) != E_Out_Parameter
4234 && Do_Range_Check (gnat_actual))
4235 gnu_actual
4236 = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
4238 /* Unless this is an In parameter, we must remove any justified modular
4239 building from GNU_NAME to get an lvalue. */
4240 if (Ekind (gnat_formal) != E_In_Parameter
4241 && TREE_CODE (gnu_name) == CONSTRUCTOR
4242 && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
4243 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
4244 gnu_name
4245 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
4247 /* First see if the parameter is passed by reference. */
4248 if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal))
4250 if (Ekind (gnat_formal) != E_In_Parameter)
4252 /* In Out or Out parameters passed by reference don't use the
4253 copy-in/copy-out mechanism so the address of the real object
4254 must be passed to the function. */
4255 gnu_actual = gnu_name;
4257 /* If we have a padded type, be sure we've removed padding. */
4258 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4259 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
4260 gnu_actual);
4262 /* If we have the constructed subtype of an aliased object
4263 with an unconstrained nominal subtype, the type of the
4264 actual includes the template, although it is formally
4265 constrained. So we need to convert it back to the real
4266 constructed subtype to retrieve the constrained part
4267 and takes its address. */
4268 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
4269 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
4270 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
4271 && Is_Array_Type (Underlying_Type (Etype (gnat_actual))))
4272 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
4273 gnu_actual);
4276 /* There is no need to convert the actual to the formal's type before
4277 taking its address. The only exception is for unconstrained array
4278 types because of the way we build fat pointers. */
4279 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4281 /* Put back a view conversion for In Out or Out parameters. */
4282 if (Ekind (gnat_formal) != E_In_Parameter)
4283 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
4284 gnu_actual);
4285 gnu_actual = convert (gnu_formal_type, gnu_actual);
4288 /* The symmetry of the paths to the type of an entity is broken here
4289 since arguments don't know that they will be passed by ref. */
4290 gnu_formal_type = TREE_TYPE (gnu_formal);
4291 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4294 /* Then see if the parameter is an array passed to a foreign convention
4295 subprogram. */
4296 else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
4298 gnu_formal_type = TREE_TYPE (gnu_formal);
4299 gnu_actual = maybe_implicit_deref (gnu_actual);
4300 gnu_actual = maybe_unconstrained_array (gnu_actual);
4302 if (TYPE_IS_PADDING_P (gnu_formal_type))
4304 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
4305 gnu_actual = convert (gnu_formal_type, gnu_actual);
4308 /* Take the address of the object and convert to the proper pointer
4309 type. We'd like to actually compute the address of the beginning
4310 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4311 possibility that the ARRAY_REF might return a constant and we'd be
4312 getting the wrong address. Neither approach is exactly correct,
4313 but this is the most likely to work in all cases. */
4314 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4317 /* Then see if the parameter is passed by descriptor. */
4318 else if (is_true_formal_parm && DECL_BY_DESCRIPTOR_P (gnu_formal))
4320 gnu_actual = convert (gnu_formal_type, gnu_actual);
4322 /* If this is 'Null_Parameter, pass a zero descriptor. */
4323 if ((TREE_CODE (gnu_actual) == INDIRECT_REF
4324 || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
4325 && TREE_PRIVATE (gnu_actual))
4326 gnu_actual
4327 = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
4328 else
4329 gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
4330 fill_vms_descriptor
4331 (TREE_TYPE (TREE_TYPE (gnu_formal)),
4332 gnu_actual, gnat_actual));
4335 /* Otherwise the parameter is passed by copy. */
4336 else
4338 tree gnu_size;
4340 if (Ekind (gnat_formal) != E_In_Parameter)
4341 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
4343 /* If we didn't create a PARM_DECL for the formal, this means that
4344 it is an Out parameter not passed by reference and that need not
4345 be copied in. In this case, the value of the actual need not be
4346 read. However, we still need to make sure that its side-effects
4347 are evaluated before the call, so we evaluate its address. */
4348 if (!is_true_formal_parm)
4350 if (TREE_SIDE_EFFECTS (gnu_name))
4352 tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
4353 append_to_statement_list (addr, &gnu_stmt_list);
4355 continue;
4358 gnu_actual = convert (gnu_formal_type, gnu_actual);
4360 /* If this is 'Null_Parameter, pass a zero even though we are
4361 dereferencing it. */
4362 if (TREE_CODE (gnu_actual) == INDIRECT_REF
4363 && TREE_PRIVATE (gnu_actual)
4364 && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
4365 && TREE_CODE (gnu_size) == INTEGER_CST
4366 && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
4367 gnu_actual
4368 = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
4369 convert (gnat_type_for_size
4370 (TREE_INT_CST_LOW (gnu_size), 1),
4371 integer_zero_node),
4372 false);
4373 else
4374 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
4377 vec_safe_push (gnu_actual_vec, gnu_actual);
4380 gnu_call
4381 = build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec);
4382 set_expr_location_from_node (gnu_call, gnat_node);
4384 /* If we have created a temporary for the return value, initialize it. */
4385 if (gnu_retval)
4387 tree gnu_stmt
4388 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
4389 set_expr_location_from_node (gnu_stmt, gnat_node);
4390 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4391 gnu_call = gnu_retval;
4394 /* If this is a subprogram with copy-in/copy-out parameters, we need to
4395 unpack the valued returned from the function into the In Out or Out
4396 parameters. We deal with the function return (if this is an Ada
4397 function) below. */
4398 if (TYPE_CI_CO_LIST (gnu_subprog_type))
4400 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
4401 copy-out parameters. */
4402 tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
4403 const int length = list_length (gnu_cico_list);
4405 /* The call sequence must contain one and only one call, even though the
4406 function is pure. Save the result into a temporary if needed. */
4407 if (length > 1)
4409 if (!gnu_retval)
4411 tree gnu_stmt;
4412 /* If we haven't pushed a binding level, push a new one. This
4413 will narrow the lifetime of the temporary we are about to
4414 make as much as possible. */
4415 if (!pushed_binding_level)
4417 start_stmt_group ();
4418 gnat_pushlevel ();
4419 pushed_binding_level = true;
4421 gnu_call
4422 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
4423 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
4426 gnu_name_list = nreverse (gnu_name_list);
4429 /* The first entry is for the actual return value if this is a
4430 function, so skip it. */
4431 if (function_call)
4432 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4434 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
4435 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
4436 else
4437 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
4439 for (gnat_actual = First_Actual (gnat_node);
4440 Present (gnat_actual);
4441 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4442 gnat_actual = Next_Actual (gnat_actual))
4443 /* If we are dealing with a copy-in/copy-out parameter, we must
4444 retrieve its value from the record returned in the call. */
4445 if (!(present_gnu_tree (gnat_formal)
4446 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
4447 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
4448 || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
4449 && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
4450 || (DECL_BY_DESCRIPTOR_P
4451 (get_gnu_tree (gnat_formal))))))))
4452 && Ekind (gnat_formal) != E_In_Parameter)
4454 /* Get the value to assign to this Out or In Out parameter. It is
4455 either the result of the function if there is only a single such
4456 parameter or the appropriate field from the record returned. */
4457 tree gnu_result
4458 = length == 1
4459 ? gnu_call
4460 : build_component_ref (gnu_call, NULL_TREE,
4461 TREE_PURPOSE (gnu_cico_list), false);
4463 /* If the actual is a conversion, get the inner expression, which
4464 will be the real destination, and convert the result to the
4465 type of the actual parameter. */
4466 tree gnu_actual
4467 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
4469 /* If the result is a padded type, remove the padding. */
4470 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4471 gnu_result
4472 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4473 gnu_result);
4475 /* If the actual is a type conversion, the real target object is
4476 denoted by the inner Expression and we need to convert the
4477 result to the associated type.
4478 We also need to convert our gnu assignment target to this type
4479 if the corresponding GNU_NAME was constructed from the GNAT
4480 conversion node and not from the inner Expression. */
4481 if (Nkind (gnat_actual) == N_Type_Conversion)
4483 gnu_result
4484 = convert_with_check
4485 (Etype (Expression (gnat_actual)), gnu_result,
4486 Do_Overflow_Check (gnat_actual),
4487 Do_Range_Check (Expression (gnat_actual)),
4488 Float_Truncate (gnat_actual), gnat_actual);
4490 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
4491 gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
4494 /* Unchecked conversions as actuals for Out parameters are not
4495 allowed in user code because they are not variables, but do
4496 occur in front-end expansions. The associated GNU_NAME is
4497 always obtained from the inner expression in such cases. */
4498 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4499 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
4500 gnu_result,
4501 No_Truncation (gnat_actual));
4502 else
4504 if (Do_Range_Check (gnat_actual))
4505 gnu_result
4506 = emit_range_check (gnu_result, Etype (gnat_actual),
4507 gnat_actual);
4509 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
4510 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
4511 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
4514 if (atomic_sync_required_p (gnat_actual))
4515 gnu_result = build_atomic_store (gnu_actual, gnu_result);
4516 else
4517 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
4518 gnu_actual, gnu_result);
4519 set_expr_location_from_node (gnu_result, gnat_node);
4520 append_to_statement_list (gnu_result, &gnu_stmt_list);
4521 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
4522 gnu_name_list = TREE_CHAIN (gnu_name_list);
4526 /* If this is a function call, the result is the call expression unless a
4527 target is specified, in which case we copy the result into the target
4528 and return the assignment statement. */
4529 if (function_call)
4531 /* If this is a function with copy-in/copy-out parameters, extract the
4532 return value from it and update the return type. */
4533 if (TYPE_CI_CO_LIST (gnu_subprog_type))
4535 tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type);
4536 gnu_call = build_component_ref (gnu_call, NULL_TREE,
4537 TREE_PURPOSE (gnu_elmt), false);
4538 gnu_result_type = TREE_TYPE (gnu_call);
4541 /* If the function returns an unconstrained array or by direct reference,
4542 we have to dereference the pointer. */
4543 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
4544 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
4545 gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
4547 if (gnu_target)
4549 Node_Id gnat_parent = Parent (gnat_node);
4550 enum tree_code op_code;
4552 /* If range check is needed, emit code to generate it. */
4553 if (Do_Range_Check (gnat_node))
4554 gnu_call
4555 = emit_range_check (gnu_call, Etype (Name (gnat_parent)),
4556 gnat_parent);
4558 /* ??? If the return type has variable size, then force the return
4559 slot optimization as we would not be able to create a temporary.
4560 Likewise if it was unconstrained as we would copy too much data.
4561 That's what has been done historically. */
4562 if (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4563 || (TYPE_IS_PADDING_P (gnu_result_type)
4564 && CONTAINS_PLACEHOLDER_P
4565 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type))))))
4566 op_code = INIT_EXPR;
4567 else
4568 op_code = MODIFY_EXPR;
4570 if (atomic_sync)
4571 gnu_call = build_atomic_store (gnu_target, gnu_call);
4572 else
4573 gnu_call
4574 = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
4575 set_expr_location_from_node (gnu_call, gnat_parent);
4576 append_to_statement_list (gnu_call, &gnu_stmt_list);
4578 else
4579 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
4582 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
4583 parameters, the result is just the call statement. */
4584 else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
4585 append_to_statement_list (gnu_call, &gnu_stmt_list);
4587 /* Finally, add the copy back statements, if any. */
4588 append_to_statement_list (gnu_after_list, &gnu_stmt_list);
4590 if (went_into_elab_proc)
4591 current_function_decl = NULL_TREE;
4593 /* If we have pushed a binding level, pop it and finish up the enclosing
4594 statement group. */
4595 if (pushed_binding_level)
4597 add_stmt (gnu_stmt_list);
4598 gnat_poplevel ();
4599 gnu_result = end_stmt_group ();
4602 /* Otherwise, retrieve the statement list, if any. */
4603 else if (gnu_stmt_list)
4604 gnu_result = gnu_stmt_list;
4606 /* Otherwise, just return the call expression. */
4607 else
4608 return gnu_call;
4610 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
4611 But first simplify if we have only one statement in the list. */
4612 if (returning_value)
4614 tree first = expr_first (gnu_result), last = expr_last (gnu_result);
4615 if (first == last)
4616 gnu_result = first;
4617 gnu_result
4618 = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
4621 return gnu_result;
4624 /* Subroutine of gnat_to_gnu to translate gnat_node, an
4625 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
4627 static tree
4628 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
4630 tree gnu_jmpsave_decl = NULL_TREE;
4631 tree gnu_jmpbuf_decl = NULL_TREE;
4632 /* If just annotating, ignore all EH and cleanups. */
4633 bool gcc_zcx = (!type_annotate_only
4634 && Present (Exception_Handlers (gnat_node))
4635 && Exception_Mechanism == Back_End_Exceptions);
4636 bool setjmp_longjmp
4637 = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
4638 && Exception_Mechanism == Setjmp_Longjmp);
4639 bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
4640 bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
4641 tree gnu_inner_block; /* The statement(s) for the block itself. */
4642 tree gnu_result;
4643 tree gnu_expr;
4644 Node_Id gnat_temp;
4645 /* Node providing the sloc for the cleanup actions. */
4646 Node_Id gnat_cleanup_loc_node = (Present (End_Label (gnat_node)) ?
4647 End_Label (gnat_node) :
4648 gnat_node);
4650 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
4651 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
4652 add_cleanup, and when we leave the binding, end_stmt_group will create
4653 the TRY_FINALLY_EXPR.
4655 ??? The region level calls down there have been specifically put in place
4656 for a ZCX context and currently the order in which things are emitted
4657 (region/handlers) is different from the SJLJ case. Instead of putting
4658 other calls with different conditions at other places for the SJLJ case,
4659 it seems cleaner to reorder things for the SJLJ case and generalize the
4660 condition to make it not ZCX specific.
4662 If there are any exceptions or cleanup processing involved, we need an
4663 outer statement group (for Setjmp_Longjmp) and binding level. */
4664 if (binding_for_block)
4666 start_stmt_group ();
4667 gnat_pushlevel ();
4670 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
4671 area for address of previous buffer. Do this first since we need to have
4672 the setjmp buf known for any decls in this block. */
4673 if (setjmp_longjmp)
4675 gnu_jmpsave_decl
4676 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
4677 jmpbuf_ptr_type,
4678 build_call_n_expr (get_jmpbuf_decl, 0),
4679 false, false, false, false, NULL, gnat_node);
4680 DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
4682 /* The __builtin_setjmp receivers will immediately reinstall it. Now
4683 because of the unstructured form of EH used by setjmp_longjmp, there
4684 might be forward edges going to __builtin_setjmp receivers on which
4685 it is uninitialized, although they will never be actually taken. */
4686 TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
4687 gnu_jmpbuf_decl
4688 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE,
4689 jmpbuf_type,
4690 NULL_TREE,
4691 false, false, false, false, NULL, gnat_node);
4692 DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
4694 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
4696 /* When we exit this block, restore the saved value. */
4697 add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl),
4698 gnat_cleanup_loc_node);
4701 /* If we are to call a function when exiting this block, add a cleanup
4702 to the binding level we made above. Note that add_cleanup is FIFO
4703 so we must register this cleanup after the EH cleanup just above. */
4704 if (at_end)
4705 add_cleanup (build_call_n_expr (gnat_to_gnu (At_End_Proc (gnat_node)), 0),
4706 gnat_cleanup_loc_node);
4708 /* Now build the tree for the declarations and statements inside this block.
4709 If this is SJLJ, set our jmp_buf as the current buffer. */
4710 start_stmt_group ();
4712 if (setjmp_longjmp)
4713 add_stmt (build_call_n_expr (set_jmpbuf_decl, 1,
4714 build_unary_op (ADDR_EXPR, NULL_TREE,
4715 gnu_jmpbuf_decl)));
4717 if (Present (First_Real_Statement (gnat_node)))
4718 process_decls (Statements (gnat_node), Empty,
4719 First_Real_Statement (gnat_node), true, true);
4721 /* Generate code for each statement in the block. */
4722 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
4723 ? First_Real_Statement (gnat_node)
4724 : First (Statements (gnat_node)));
4725 Present (gnat_temp); gnat_temp = Next (gnat_temp))
4726 add_stmt (gnat_to_gnu (gnat_temp));
4727 gnu_inner_block = end_stmt_group ();
4729 /* Now generate code for the two exception models, if either is relevant for
4730 this block. */
4731 if (setjmp_longjmp)
4733 tree *gnu_else_ptr = 0;
4734 tree gnu_handler;
4736 /* Make a binding level for the exception handling declarations and code
4737 and set up gnu_except_ptr_stack for the handlers to use. */
4738 start_stmt_group ();
4739 gnat_pushlevel ();
4741 vec_safe_push (gnu_except_ptr_stack,
4742 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
4743 build_pointer_type (except_type_node),
4744 build_call_n_expr (get_excptr_decl, 0),
4745 false, false, false, false,
4746 NULL, gnat_node));
4748 /* Generate code for each handler. The N_Exception_Handler case does the
4749 real work and returns a COND_EXPR for each handler, which we chain
4750 together here. */
4751 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
4752 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
4754 gnu_expr = gnat_to_gnu (gnat_temp);
4756 /* If this is the first one, set it as the outer one. Otherwise,
4757 point the "else" part of the previous handler to us. Then point
4758 to our "else" part. */
4759 if (!gnu_else_ptr)
4760 add_stmt (gnu_expr);
4761 else
4762 *gnu_else_ptr = gnu_expr;
4764 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
4767 /* If none of the exception handlers did anything, re-raise but do not
4768 defer abortion. */
4769 gnu_expr = build_call_n_expr (raise_nodefer_decl, 1,
4770 gnu_except_ptr_stack->last ());
4771 set_expr_location_from_node
4772 (gnu_expr,
4773 Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
4775 if (gnu_else_ptr)
4776 *gnu_else_ptr = gnu_expr;
4777 else
4778 add_stmt (gnu_expr);
4780 /* End the binding level dedicated to the exception handlers and get the
4781 whole statement group. */
4782 gnu_except_ptr_stack->pop ();
4783 gnat_poplevel ();
4784 gnu_handler = end_stmt_group ();
4786 /* If the setjmp returns 1, we restore our incoming longjmp value and
4787 then check the handlers. */
4788 start_stmt_group ();
4789 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl, 1,
4790 gnu_jmpsave_decl),
4791 gnat_node);
4792 add_stmt (gnu_handler);
4793 gnu_handler = end_stmt_group ();
4795 /* This block is now "if (setjmp) ... <handlers> else <block>". */
4796 gnu_result = build3 (COND_EXPR, void_type_node,
4797 (build_call_n_expr
4798 (setjmp_decl, 1,
4799 build_unary_op (ADDR_EXPR, NULL_TREE,
4800 gnu_jmpbuf_decl))),
4801 gnu_handler, gnu_inner_block);
4803 else if (gcc_zcx)
4805 tree gnu_handlers;
4806 location_t locus;
4808 /* First make a block containing the handlers. */
4809 start_stmt_group ();
4810 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
4811 Present (gnat_temp);
4812 gnat_temp = Next_Non_Pragma (gnat_temp))
4813 add_stmt (gnat_to_gnu (gnat_temp));
4814 gnu_handlers = end_stmt_group ();
4816 /* Now make the TRY_CATCH_EXPR for the block. */
4817 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
4818 gnu_inner_block, gnu_handlers);
4819 /* Set a location. We need to find a unique location for the dispatching
4820 code, otherwise we can get coverage or debugging issues. Try with
4821 the location of the end label. */
4822 if (Present (End_Label (gnat_node))
4823 && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus))
4824 SET_EXPR_LOCATION (gnu_result, locus);
4825 else
4826 /* Clear column information so that the exception handler of an
4827 implicit transient block does not incorrectly inherit the slocs
4828 of a decision, which would otherwise confuse control flow based
4829 coverage analysis tools. */
4830 set_expr_location_from_node1 (gnu_result, gnat_node, true);
4832 else
4833 gnu_result = gnu_inner_block;
4835 /* Now close our outer block, if we had to make one. */
4836 if (binding_for_block)
4838 add_stmt (gnu_result);
4839 gnat_poplevel ();
4840 gnu_result = end_stmt_group ();
4843 return gnu_result;
4846 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4847 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
4848 exception handling. */
4850 static tree
4851 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
4853 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
4854 an "if" statement to select the proper exceptions. For "Others", exclude
4855 exceptions where Handled_By_Others is nonzero unless the All_Others flag
4856 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
4857 tree gnu_choice = boolean_false_node;
4858 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
4859 Node_Id gnat_temp;
4861 for (gnat_temp = First (Exception_Choices (gnat_node));
4862 gnat_temp; gnat_temp = Next (gnat_temp))
4864 tree this_choice;
4866 if (Nkind (gnat_temp) == N_Others_Choice)
4868 if (All_Others (gnat_temp))
4869 this_choice = boolean_true_node;
4870 else
4871 this_choice
4872 = build_binary_op
4873 (EQ_EXPR, boolean_type_node,
4874 convert
4875 (integer_type_node,
4876 build_component_ref
4877 (build_unary_op
4878 (INDIRECT_REF, NULL_TREE,
4879 gnu_except_ptr_stack->last ()),
4880 get_identifier ("not_handled_by_others"), NULL_TREE,
4881 false)),
4882 integer_zero_node);
4885 else if (Nkind (gnat_temp) == N_Identifier
4886 || Nkind (gnat_temp) == N_Expanded_Name)
4888 Entity_Id gnat_ex_id = Entity (gnat_temp);
4889 tree gnu_expr;
4891 /* Exception may be a renaming. Recover original exception which is
4892 the one elaborated and registered. */
4893 if (Present (Renamed_Object (gnat_ex_id)))
4894 gnat_ex_id = Renamed_Object (gnat_ex_id);
4896 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
4898 this_choice
4899 = build_binary_op
4900 (EQ_EXPR, boolean_type_node,
4901 gnu_except_ptr_stack->last (),
4902 convert (TREE_TYPE (gnu_except_ptr_stack->last ()),
4903 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
4905 /* If this is the distinguished exception "Non_Ada_Error" (and we are
4906 in VMS mode), also allow a non-Ada exception (a VMS condition) t
4907 match. */
4908 if (Is_Non_Ada_Error (Entity (gnat_temp)))
4910 tree gnu_comp
4911 = build_component_ref
4912 (build_unary_op (INDIRECT_REF, NULL_TREE,
4913 gnu_except_ptr_stack->last ()),
4914 get_identifier ("lang"), NULL_TREE, false);
4916 this_choice
4917 = build_binary_op
4918 (TRUTH_ORIF_EXPR, boolean_type_node,
4919 build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp,
4920 build_int_cst (TREE_TYPE (gnu_comp), 'V')),
4921 this_choice);
4924 else
4925 gcc_unreachable ();
4927 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
4928 gnu_choice, this_choice);
4931 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
4934 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
4935 to a GCC tree, which is returned. This is the variant for ZCX. */
4937 static tree
4938 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
4940 tree gnu_etypes_list = NULL_TREE;
4941 tree gnu_current_exc_ptr, prev_gnu_incoming_exc_ptr;
4942 Node_Id gnat_temp;
4944 /* We build a TREE_LIST of nodes representing what exception types this
4945 handler can catch, with special cases for others and all others cases.
4947 Each exception type is actually identified by a pointer to the exception
4948 id, or to a dummy object for "others" and "all others". */
4949 for (gnat_temp = First (Exception_Choices (gnat_node));
4950 gnat_temp; gnat_temp = Next (gnat_temp))
4952 tree gnu_expr, gnu_etype;
4954 if (Nkind (gnat_temp) == N_Others_Choice)
4956 gnu_expr = All_Others (gnat_temp) ? all_others_decl : others_decl;
4957 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
4959 else if (Nkind (gnat_temp) == N_Identifier
4960 || Nkind (gnat_temp) == N_Expanded_Name)
4962 Entity_Id gnat_ex_id = Entity (gnat_temp);
4964 /* Exception may be a renaming. Recover original exception which is
4965 the one elaborated and registered. */
4966 if (Present (Renamed_Object (gnat_ex_id)))
4967 gnat_ex_id = Renamed_Object (gnat_ex_id);
4969 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
4970 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
4972 /* The Non_Ada_Error case for VMS exceptions is handled
4973 by the personality routine. */
4975 else
4976 gcc_unreachable ();
4978 /* The GCC interface expects NULL to be passed for catch all handlers, so
4979 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
4980 is integer_zero_node. It would not work, however, because GCC's
4981 notion of "catch all" is stronger than our notion of "others". Until
4982 we correctly use the cleanup interface as well, doing that would
4983 prevent the "all others" handlers from being seen, because nothing
4984 can be caught beyond a catch all from GCC's point of view. */
4985 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
4988 start_stmt_group ();
4989 gnat_pushlevel ();
4991 /* Expand a call to the begin_handler hook at the beginning of the handler,
4992 and arrange for a call to the end_handler hook to occur on every possible
4993 exit path.
4995 The hooks expect a pointer to the low level occurrence. This is required
4996 for our stack management scheme because a raise inside the handler pushes
4997 a new occurrence on top of the stack, which means that this top does not
4998 necessarily match the occurrence this handler was dealing with.
5000 __builtin_eh_pointer references the exception occurrence being
5001 propagated. Upon handler entry, this is the exception for which the
5002 handler is triggered. This might not be the case upon handler exit,
5003 however, as we might have a new occurrence propagated by the handler's
5004 body, and the end_handler hook called as a cleanup in this context.
5006 We use a local variable to retrieve the incoming value at handler entry
5007 time, and reuse it to feed the end_handler hook's argument at exit. */
5009 gnu_current_exc_ptr
5010 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
5011 1, integer_zero_node);
5012 prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
5013 gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
5014 ptr_type_node, gnu_current_exc_ptr,
5015 false, false, false, false,
5016 NULL, gnat_node);
5018 add_stmt_with_node (build_call_n_expr (begin_handler_decl, 1,
5019 gnu_incoming_exc_ptr),
5020 gnat_node);
5022 /* Declare and initialize the choice parameter, if present. */
5023 if (Present (Choice_Parameter (gnat_node)))
5025 tree gnu_param
5026 = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, 1);
5028 add_stmt (build_call_n_expr
5029 (set_exception_parameter_decl, 2,
5030 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_param),
5031 gnu_incoming_exc_ptr));
5034 /* We don't have an End_Label at hand to set the location of the cleanup
5035 actions, so we use that of the exception handler itself instead. */
5036 add_cleanup (build_call_n_expr (end_handler_decl, 1, gnu_incoming_exc_ptr),
5037 gnat_node);
5038 add_stmt_list (Statements (gnat_node));
5039 gnat_poplevel ();
5041 gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
5043 return
5044 build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, end_stmt_group ());
5047 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
5049 static void
5050 Compilation_Unit_to_gnu (Node_Id gnat_node)
5052 const Node_Id gnat_unit = Unit (gnat_node);
5053 const bool body_p = (Nkind (gnat_unit) == N_Package_Body
5054 || Nkind (gnat_unit) == N_Subprogram_Body);
5055 const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
5056 Node_Id gnat_pragma;
5057 /* Make the decl for the elaboration procedure. */
5058 tree gnu_elab_proc_decl
5059 = create_subprog_decl
5060 (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
5061 NULL_TREE, void_ftype, NULL_TREE, is_disabled, true, false, true, NULL,
5062 gnat_unit);
5063 struct elab_info *info;
5065 vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
5066 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
5068 /* Initialize the information structure for the function. */
5069 allocate_struct_function (gnu_elab_proc_decl, false);
5070 set_cfun (NULL);
5072 current_function_decl = NULL_TREE;
5074 start_stmt_group ();
5075 gnat_pushlevel ();
5077 /* For a body, first process the spec if there is one. */
5078 if (Nkind (gnat_unit) == N_Package_Body
5079 || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
5080 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
5082 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
5084 elaborate_all_entities (gnat_node);
5086 if (Nkind (gnat_unit) == N_Subprogram_Declaration
5087 || Nkind (gnat_unit) == N_Generic_Package_Declaration
5088 || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
5089 return;
5092 /* Then process any pragmas and declarations preceding the unit. */
5093 for (gnat_pragma = First (Context_Items (gnat_node));
5094 Present (gnat_pragma);
5095 gnat_pragma = Next (gnat_pragma))
5096 if (Nkind (gnat_pragma) == N_Pragma)
5097 add_stmt (gnat_to_gnu (gnat_pragma));
5098 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
5099 true, true);
5101 /* Process the unit itself. */
5102 add_stmt (gnat_to_gnu (gnat_unit));
5104 /* If we can inline, generate code for all the inlined subprograms. */
5105 if (optimize)
5107 Entity_Id gnat_entity;
5109 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5110 Present (gnat_entity);
5111 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5113 Node_Id gnat_body = Parent (Declaration_Node (gnat_entity));
5115 if (Nkind (gnat_body) != N_Subprogram_Body)
5117 /* ??? This really should always be present. */
5118 if (No (Corresponding_Body (gnat_body)))
5119 continue;
5120 gnat_body
5121 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5124 if (Present (gnat_body))
5126 /* Define the entity first so we set DECL_EXTERNAL. */
5127 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5128 add_stmt (gnat_to_gnu (gnat_body));
5133 /* Process any pragmas and actions following the unit. */
5134 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
5135 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
5136 finalize_from_limited_with ();
5138 /* Save away what we've made so far and record this potential elaboration
5139 procedure. */
5140 info = ggc_alloc<elab_info> ();
5141 set_current_block_context (gnu_elab_proc_decl);
5142 gnat_poplevel ();
5143 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
5145 set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
5147 info->next = elab_info_list;
5148 info->elab_proc = gnu_elab_proc_decl;
5149 info->gnat_node = gnat_node;
5150 elab_info_list = info;
5152 /* Generate elaboration code for this unit, if necessary, and say whether
5153 we did or not. */
5154 gnu_elab_proc_stack->pop ();
5156 /* Invalidate the global renaming pointers. This is necessary because
5157 stabilization of the renamed entities may create SAVE_EXPRs which
5158 have been tied to a specific elaboration routine just above. */
5159 invalidate_global_renaming_pointers ();
5162 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Raise_xxx_Error,
5163 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where
5164 we should place the result type. LABEL_P is true if there is a label to
5165 branch to for the exception. */
5167 static tree
5168 Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
5170 const Node_Kind kind = Nkind (gnat_node);
5171 const int reason = UI_To_Int (Reason (gnat_node));
5172 const Node_Id gnat_cond = Condition (gnat_node);
5173 const bool with_extra_info
5174 = Exception_Extra_Info
5175 && !No_Exception_Handlers_Set ()
5176 && !get_exception_label (kind);
5177 tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
5179 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
5181 switch (reason)
5183 case CE_Access_Check_Failed:
5184 if (with_extra_info)
5185 gnu_result = build_call_raise_column (reason, gnat_node);
5186 break;
5188 case CE_Index_Check_Failed:
5189 case CE_Range_Check_Failed:
5190 case CE_Invalid_Data:
5191 if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not)
5193 Node_Id gnat_range, gnat_index, gnat_type;
5194 tree gnu_index, gnu_low_bound, gnu_high_bound;
5195 struct range_check_info_d *rci;
5197 switch (Nkind (Right_Opnd (gnat_cond)))
5199 case N_In:
5200 gnat_range = Right_Opnd (Right_Opnd (gnat_cond));
5201 gcc_assert (Nkind (gnat_range) == N_Range);
5202 gnu_low_bound = gnat_to_gnu (Low_Bound (gnat_range));
5203 gnu_high_bound = gnat_to_gnu (High_Bound (gnat_range));
5204 break;
5206 case N_Op_Ge:
5207 gnu_low_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
5208 gnu_high_bound = NULL_TREE;
5209 break;
5211 case N_Op_Le:
5212 gnu_low_bound = NULL_TREE;
5213 gnu_high_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)));
5214 break;
5216 default:
5217 goto common;
5220 gnat_index = Left_Opnd (Right_Opnd (gnat_cond));
5221 gnat_type = Etype (gnat_index);
5222 gnu_index = gnat_to_gnu (gnat_index);
5224 if (with_extra_info
5225 && gnu_low_bound
5226 && gnu_high_bound
5227 && Known_Esize (gnat_type)
5228 && UI_To_Int (Esize (gnat_type)) <= 32)
5229 gnu_result
5230 = build_call_raise_range (reason, gnat_node, gnu_index,
5231 gnu_low_bound, gnu_high_bound);
5233 /* If loop unswitching is enabled, we try to compute invariant
5234 conditions for checks applied to iteration variables, i.e.
5235 conditions that are both independent of the variable and
5236 necessary in order for the check to fail in the course of
5237 some iteration, and prepend them to the original condition
5238 of the checks. This will make it possible later for the
5239 loop unswitching pass to replace the loop with two loops,
5240 one of which has the checks eliminated and the other has
5241 the original checks reinstated, and a run time selection.
5242 The former loop will be suitable for vectorization. */
5243 if (flag_unswitch_loops
5244 && (!gnu_low_bound
5245 || (gnu_low_bound = gnat_invariant_expr (gnu_low_bound)))
5246 && (!gnu_high_bound
5247 || (gnu_high_bound = gnat_invariant_expr (gnu_high_bound)))
5248 && (rci = push_range_check_info (gnu_index)))
5250 rci->low_bound = gnu_low_bound;
5251 rci->high_bound = gnu_high_bound;
5252 rci->type = get_unpadded_type (gnat_type);
5253 rci->invariant_cond = build1 (SAVE_EXPR, boolean_type_node,
5254 boolean_true_node);
5255 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
5256 boolean_type_node,
5257 rci->invariant_cond,
5258 gnat_to_gnu (gnat_cond));
5261 break;
5263 default:
5264 break;
5267 common:
5268 if (!gnu_result)
5269 gnu_result = build_call_raise (reason, gnat_node, kind);
5270 set_expr_location_from_node (gnu_result, gnat_node);
5272 /* If the type is VOID, this is a statement, so we need to generate the code
5273 for the call. Handle a condition, if there is one. */
5274 if (VOID_TYPE_P (*gnu_result_type_p))
5276 if (Present (gnat_cond))
5278 if (!gnu_cond)
5279 gnu_cond = gnat_to_gnu (gnat_cond);
5280 gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
5281 alloc_stmt_list ());
5284 else
5285 gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
5287 return gnu_result;
5290 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
5291 parameter of a call. */
5293 static bool
5294 lhs_or_actual_p (Node_Id gnat_node)
5296 Node_Id gnat_parent = Parent (gnat_node);
5297 Node_Kind kind = Nkind (gnat_parent);
5299 if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
5300 return true;
5302 if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call)
5303 && Name (gnat_parent) != gnat_node)
5304 return true;
5306 if (kind == N_Parameter_Association)
5307 return true;
5309 return false;
5312 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
5313 of an assignment or an actual parameter of a call. */
5315 static bool
5316 present_in_lhs_or_actual_p (Node_Id gnat_node)
5318 Node_Kind kind;
5320 if (lhs_or_actual_p (gnat_node))
5321 return true;
5323 kind = Nkind (Parent (gnat_node));
5325 if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
5326 && lhs_or_actual_p (Parent (gnat_node)))
5327 return true;
5329 return false;
5332 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
5333 as gigi is concerned. This is used to avoid conversions on the LHS. */
5335 static bool
5336 unchecked_conversion_nop (Node_Id gnat_node)
5338 Entity_Id from_type, to_type;
5340 /* The conversion must be on the LHS of an assignment or an actual parameter
5341 of a call. Otherwise, even if the conversion was essentially a no-op, it
5342 could de facto ensure type consistency and this should be preserved. */
5343 if (!lhs_or_actual_p (gnat_node))
5344 return false;
5346 from_type = Etype (Expression (gnat_node));
5348 /* We're interested in artificial conversions generated by the front-end
5349 to make private types explicit, e.g. in Expand_Assign_Array. */
5350 if (!Is_Private_Type (from_type))
5351 return false;
5353 from_type = Underlying_Type (from_type);
5354 to_type = Etype (gnat_node);
5356 /* The direct conversion to the underlying type is a no-op. */
5357 if (to_type == from_type)
5358 return true;
5360 /* For an array subtype, the conversion to the PAT is a no-op. */
5361 if (Ekind (from_type) == E_Array_Subtype
5362 && to_type == Packed_Array_Type (from_type))
5363 return true;
5365 /* For a record subtype, the conversion to the type is a no-op. */
5366 if (Ekind (from_type) == E_Record_Subtype
5367 && to_type == Etype (from_type))
5368 return true;
5370 return false;
5373 /* This function is the driver of the GNAT to GCC tree transformation process.
5374 It is the entry point of the tree transformer. GNAT_NODE is the root of
5375 some GNAT tree. Return the root of the corresponding GCC tree. If this
5376 is an expression, return the GCC equivalent of the expression. If this
5377 is a statement, return the statement or add it to the current statement
5378 group, in which case anything returned is to be interpreted as occurring
5379 after anything added. */
5381 tree
5382 gnat_to_gnu (Node_Id gnat_node)
5384 const Node_Kind kind = Nkind (gnat_node);
5385 bool went_into_elab_proc = false;
5386 tree gnu_result = error_mark_node; /* Default to no value. */
5387 tree gnu_result_type = void_type_node;
5388 tree gnu_expr, gnu_lhs, gnu_rhs;
5389 Node_Id gnat_temp;
5391 /* Save node number for error message and set location information. */
5392 error_gnat_node = gnat_node;
5393 Sloc_to_locus (Sloc (gnat_node), &input_location);
5395 /* If this node is a statement and we are only annotating types, return an
5396 empty statement list. */
5397 if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call))
5398 return alloc_stmt_list ();
5400 /* If this node is a non-static subexpression and we are only annotating
5401 types, make this into a NULL_EXPR. */
5402 if (type_annotate_only
5403 && IN (kind, N_Subexpr)
5404 && kind != N_Identifier
5405 && !Compile_Time_Known_Value (gnat_node))
5406 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
5407 build_call_raise (CE_Range_Check_Failed, gnat_node,
5408 N_Raise_Constraint_Error));
5410 if ((IN (kind, N_Statement_Other_Than_Procedure_Call)
5411 && kind != N_Null_Statement)
5412 || kind == N_Procedure_Call_Statement
5413 || kind == N_Label
5414 || kind == N_Implicit_Label_Declaration
5415 || kind == N_Handled_Sequence_Of_Statements
5416 || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
5418 tree current_elab_proc = get_elaboration_procedure ();
5420 /* If this is a statement and we are at top level, it must be part of
5421 the elaboration procedure, so mark us as being in that procedure. */
5422 if (!current_function_decl)
5424 current_function_decl = current_elab_proc;
5425 went_into_elab_proc = true;
5428 /* If we are in the elaboration procedure, check if we are violating a
5429 No_Elaboration_Code restriction by having a statement there. Don't
5430 check for a possible No_Elaboration_Code restriction violation on
5431 N_Handled_Sequence_Of_Statements, as we want to signal an error on
5432 every nested real statement instead. This also avoids triggering
5433 spurious errors on dummy (empty) sequences created by the front-end
5434 for package bodies in some cases. */
5435 if (current_function_decl == current_elab_proc
5436 && kind != N_Handled_Sequence_Of_Statements)
5437 Check_Elaboration_Code_Allowed (gnat_node);
5440 switch (kind)
5442 /********************************/
5443 /* Chapter 2: Lexical Elements */
5444 /********************************/
5446 case N_Identifier:
5447 case N_Expanded_Name:
5448 case N_Operator_Symbol:
5449 case N_Defining_Identifier:
5450 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
5452 /* If this is an atomic access on the RHS for which synchronization is
5453 required, build the atomic load. */
5454 if (atomic_sync_required_p (gnat_node)
5455 && !present_in_lhs_or_actual_p (gnat_node))
5456 gnu_result = build_atomic_load (gnu_result);
5457 break;
5459 case N_Integer_Literal:
5461 tree gnu_type;
5463 /* Get the type of the result, looking inside any padding and
5464 justified modular types. Then get the value in that type. */
5465 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
5467 if (TREE_CODE (gnu_type) == RECORD_TYPE
5468 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
5469 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
5471 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
5473 /* If the result overflows (meaning it doesn't fit in its base type),
5474 abort. We would like to check that the value is within the range
5475 of the subtype, but that causes problems with subtypes whose usage
5476 will raise Constraint_Error and with biased representation, so
5477 we don't. */
5478 gcc_assert (!TREE_OVERFLOW (gnu_result));
5480 break;
5482 case N_Character_Literal:
5483 /* If a Entity is present, it means that this was one of the
5484 literals in a user-defined character type. In that case,
5485 just return the value in the CONST_DECL. Otherwise, use the
5486 character code. In that case, the base type should be an
5487 INTEGER_TYPE, but we won't bother checking for that. */
5488 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5489 if (Present (Entity (gnat_node)))
5490 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
5491 else
5492 gnu_result
5493 = build_int_cst_type
5494 (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
5495 break;
5497 case N_Real_Literal:
5498 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5500 /* If this is of a fixed-point type, the value we want is the
5501 value of the corresponding integer. */
5502 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
5504 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
5505 gnu_result_type);
5506 gcc_assert (!TREE_OVERFLOW (gnu_result));
5509 /* Convert the Ureal to a vax float (represented on a signed type). */
5510 else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
5512 gnu_result = UI_To_gnu (Get_Vax_Real_Literal_As_Signed (gnat_node),
5513 gnu_result_type);
5516 else
5518 Ureal ur_realval = Realval (gnat_node);
5520 /* First convert the real value to a machine number if it isn't
5521 already. That forces BASE to 2 for non-zero values and simplifies
5522 the rest of our logic. */
5524 if (!Is_Machine_Number (gnat_node))
5525 ur_realval
5526 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
5527 ur_realval, Round_Even, gnat_node);
5529 if (UR_Is_Zero (ur_realval))
5530 gnu_result = convert (gnu_result_type, integer_zero_node);
5531 else
5533 REAL_VALUE_TYPE tmp;
5535 gnu_result
5536 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
5538 /* The base must be 2 as Machine guarantees this, so we scale
5539 the value, which we know can fit in the mantissa of the type
5540 (hence the use of that type above). */
5542 gcc_assert (Rbase (ur_realval) == 2);
5543 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
5544 - UI_To_Int (Denominator (ur_realval)));
5545 gnu_result = build_real (gnu_result_type, tmp);
5548 /* Now see if we need to negate the result. Do it this way to
5549 properly handle -0. */
5550 if (UR_Is_Negative (Realval (gnat_node)))
5551 gnu_result
5552 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
5553 gnu_result);
5556 break;
5558 case N_String_Literal:
5559 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5560 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
5562 String_Id gnat_string = Strval (gnat_node);
5563 int length = String_Length (gnat_string);
5564 int i;
5565 char *string;
5566 if (length >= ALLOCA_THRESHOLD)
5567 string = XNEWVEC (char, length + 1);
5568 else
5569 string = (char *) alloca (length + 1);
5571 /* Build the string with the characters in the literal. Note
5572 that Ada strings are 1-origin. */
5573 for (i = 0; i < length; i++)
5574 string[i] = Get_String_Char (gnat_string, i + 1);
5576 /* Put a null at the end of the string in case it's in a context
5577 where GCC will want to treat it as a C string. */
5578 string[i] = 0;
5580 gnu_result = build_string (length, string);
5582 /* Strings in GCC don't normally have types, but we want
5583 this to not be converted to the array type. */
5584 TREE_TYPE (gnu_result) = gnu_result_type;
5586 if (length >= ALLOCA_THRESHOLD)
5587 free (string);
5589 else
5591 /* Build a list consisting of each character, then make
5592 the aggregate. */
5593 String_Id gnat_string = Strval (gnat_node);
5594 int length = String_Length (gnat_string);
5595 int i;
5596 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
5597 tree gnu_one_node = convert (TREE_TYPE (gnu_idx), integer_one_node);
5598 vec<constructor_elt, va_gc> *gnu_vec;
5599 vec_alloc (gnu_vec, length);
5601 for (i = 0; i < length; i++)
5603 tree t = build_int_cst (TREE_TYPE (gnu_result_type),
5604 Get_String_Char (gnat_string, i + 1));
5606 CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
5607 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, gnu_one_node);
5610 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
5612 break;
5614 case N_Pragma:
5615 gnu_result = Pragma_to_gnu (gnat_node);
5616 break;
5618 /**************************************/
5619 /* Chapter 3: Declarations and Types */
5620 /**************************************/
5622 case N_Subtype_Declaration:
5623 case N_Full_Type_Declaration:
5624 case N_Incomplete_Type_Declaration:
5625 case N_Private_Type_Declaration:
5626 case N_Private_Extension_Declaration:
5627 case N_Task_Type_Declaration:
5628 process_type (Defining_Entity (gnat_node));
5629 gnu_result = alloc_stmt_list ();
5630 break;
5632 case N_Object_Declaration:
5633 case N_Exception_Declaration:
5634 gnat_temp = Defining_Entity (gnat_node);
5635 gnu_result = alloc_stmt_list ();
5637 /* If we are just annotating types and this object has an unconstrained
5638 or task type, don't elaborate it. */
5639 if (type_annotate_only
5640 && (((Is_Array_Type (Etype (gnat_temp))
5641 || Is_Record_Type (Etype (gnat_temp)))
5642 && !Is_Constrained (Etype (gnat_temp)))
5643 || Is_Concurrent_Type (Etype (gnat_temp))))
5644 break;
5646 if (Present (Expression (gnat_node))
5647 && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
5648 && (!type_annotate_only
5649 || Compile_Time_Known_Value (Expression (gnat_node))))
5651 gnu_expr = gnat_to_gnu (Expression (gnat_node));
5652 if (Do_Range_Check (Expression (gnat_node)))
5653 gnu_expr
5654 = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
5656 /* If this object has its elaboration delayed, we must force
5657 evaluation of GNU_EXPR right now and save it for when the object
5658 is frozen. */
5659 if (Present (Freeze_Node (gnat_temp)))
5661 if (TREE_CONSTANT (gnu_expr))
5663 else if (global_bindings_p ())
5664 gnu_expr
5665 = create_var_decl (create_concat_name (gnat_temp, "init"),
5666 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5667 false, false, false, false,
5668 NULL, gnat_temp);
5669 else
5670 gnu_expr = gnat_save_expr (gnu_expr);
5672 save_gnu_tree (gnat_node, gnu_expr, true);
5675 else
5676 gnu_expr = NULL_TREE;
5678 if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
5679 gnu_expr = NULL_TREE;
5681 /* If this is a deferred constant with an address clause, we ignore the
5682 full view since the clause is on the partial view and we cannot have
5683 2 different GCC trees for the object. The only bits of the full view
5684 we will use is the initializer, but it will be directly fetched. */
5685 if (Ekind(gnat_temp) == E_Constant
5686 && Present (Address_Clause (gnat_temp))
5687 && Present (Full_View (gnat_temp)))
5688 save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
5690 if (No (Freeze_Node (gnat_temp)))
5691 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
5692 break;
5694 case N_Object_Renaming_Declaration:
5695 gnat_temp = Defining_Entity (gnat_node);
5697 /* Don't do anything if this renaming is handled by the front end or if
5698 we are just annotating types and this object has a composite or task
5699 type, don't elaborate it. We return the result in case it has any
5700 SAVE_EXPRs in it that need to be evaluated here. */
5701 if (!Is_Renaming_Of_Object (gnat_temp)
5702 && ! (type_annotate_only
5703 && (Is_Array_Type (Etype (gnat_temp))
5704 || Is_Record_Type (Etype (gnat_temp))
5705 || Is_Concurrent_Type (Etype (gnat_temp)))))
5706 gnu_result
5707 = gnat_to_gnu_entity (gnat_temp,
5708 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
5709 else
5710 gnu_result = alloc_stmt_list ();
5711 break;
5713 case N_Implicit_Label_Declaration:
5714 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
5715 gnu_result = alloc_stmt_list ();
5716 break;
5718 case N_Exception_Renaming_Declaration:
5719 case N_Number_Declaration:
5720 case N_Package_Renaming_Declaration:
5721 case N_Subprogram_Renaming_Declaration:
5722 /* These are fully handled in the front end. */
5723 gnu_result = alloc_stmt_list ();
5724 break;
5726 /*************************************/
5727 /* Chapter 4: Names and Expressions */
5728 /*************************************/
5730 case N_Explicit_Dereference:
5731 gnu_result = gnat_to_gnu (Prefix (gnat_node));
5732 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5733 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
5735 /* If this is an atomic access on the RHS for which synchronization is
5736 required, build the atomic load. */
5737 if (atomic_sync_required_p (gnat_node)
5738 && !present_in_lhs_or_actual_p (gnat_node))
5739 gnu_result = build_atomic_load (gnu_result);
5740 break;
5742 case N_Indexed_Component:
5744 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
5745 tree gnu_type;
5746 int ndim;
5747 int i;
5748 Node_Id *gnat_expr_array;
5750 gnu_array_object = maybe_implicit_deref (gnu_array_object);
5752 /* Convert vector inputs to their representative array type, to fit
5753 what the code below expects. */
5754 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object)))
5756 if (present_in_lhs_or_actual_p (gnat_node))
5757 gnat_mark_addressable (gnu_array_object);
5758 gnu_array_object = maybe_vector_array (gnu_array_object);
5761 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
5763 /* If we got a padded type, remove it too. */
5764 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
5765 gnu_array_object
5766 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
5767 gnu_array_object);
5769 gnu_result = gnu_array_object;
5771 /* The failure of this assertion will very likely come from a missing
5772 expansion for a packed array access. */
5773 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
5775 /* First compute the number of dimensions of the array, then
5776 fill the expression array, the order depending on whether
5777 this is a Convention_Fortran array or not. */
5778 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
5779 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5780 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
5781 ndim++, gnu_type = TREE_TYPE (gnu_type))
5784 gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
5786 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
5787 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
5788 i >= 0;
5789 i--, gnat_temp = Next (gnat_temp))
5790 gnat_expr_array[i] = gnat_temp;
5791 else
5792 for (i = 0, gnat_temp = First (Expressions (gnat_node));
5793 i < ndim;
5794 i++, gnat_temp = Next (gnat_temp))
5795 gnat_expr_array[i] = gnat_temp;
5797 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
5798 i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
5800 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
5801 gnat_temp = gnat_expr_array[i];
5802 gnu_expr = gnat_to_gnu (gnat_temp);
5804 if (Do_Range_Check (gnat_temp))
5805 gnu_expr
5806 = emit_index_check
5807 (gnu_array_object, gnu_expr,
5808 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
5809 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
5810 gnat_temp);
5812 gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
5813 gnu_result, gnu_expr);
5816 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5818 /* If this is an atomic access on the RHS for which synchronization is
5819 required, build the atomic load. */
5820 if (atomic_sync_required_p (gnat_node)
5821 && !present_in_lhs_or_actual_p (gnat_node))
5822 gnu_result = build_atomic_load (gnu_result);
5824 break;
5826 case N_Slice:
5828 Node_Id gnat_range_node = Discrete_Range (gnat_node);
5829 tree gnu_type;
5831 gnu_result = gnat_to_gnu (Prefix (gnat_node));
5832 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5834 /* Do any implicit dereferences of the prefix and do any needed
5835 range check. */
5836 gnu_result = maybe_implicit_deref (gnu_result);
5837 gnu_result = maybe_unconstrained_array (gnu_result);
5838 gnu_type = TREE_TYPE (gnu_result);
5839 if (Do_Range_Check (gnat_range_node))
5841 /* Get the bounds of the slice. */
5842 tree gnu_index_type
5843 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
5844 tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
5845 tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
5846 /* Get the permitted bounds. */
5847 tree gnu_base_index_type
5848 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
5849 tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
5850 (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result);
5851 tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
5852 (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
5853 tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
5855 gnu_min_expr = gnat_protect_expr (gnu_min_expr);
5856 gnu_max_expr = gnat_protect_expr (gnu_max_expr);
5858 /* Derive a good type to convert everything to. */
5859 gnu_expr_type = get_base_type (gnu_index_type);
5861 /* Test whether the minimum slice value is too small. */
5862 gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node,
5863 convert (gnu_expr_type,
5864 gnu_min_expr),
5865 convert (gnu_expr_type,
5866 gnu_base_min_expr));
5868 /* Test whether the maximum slice value is too large. */
5869 gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node,
5870 convert (gnu_expr_type,
5871 gnu_max_expr),
5872 convert (gnu_expr_type,
5873 gnu_base_max_expr));
5875 /* Build a slice index check that returns the low bound,
5876 assuming the slice is not empty. */
5877 gnu_expr = emit_check
5878 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
5879 gnu_expr_l, gnu_expr_h),
5880 gnu_min_expr, CE_Index_Check_Failed, gnat_node);
5882 /* Build a conditional expression that does the index checks and
5883 returns the low bound if the slice is not empty (max >= min),
5884 and returns the naked low bound otherwise (max < min), unless
5885 it is non-constant and the high bound is; this prevents VRP
5886 from inferring bogus ranges on the unlikely path. */
5887 gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
5888 build_binary_op (GE_EXPR, gnu_expr_type,
5889 convert (gnu_expr_type,
5890 gnu_max_expr),
5891 convert (gnu_expr_type,
5892 gnu_min_expr)),
5893 gnu_expr,
5894 TREE_CODE (gnu_min_expr) != INTEGER_CST
5895 && TREE_CODE (gnu_max_expr) == INTEGER_CST
5896 ? gnu_max_expr : gnu_min_expr);
5898 else
5899 /* Simply return the naked low bound. */
5900 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
5902 /* If this is a slice with non-constant size of an array with constant
5903 size, set the maximum size for the allocation of temporaries. */
5904 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
5905 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
5906 TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
5908 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
5909 gnu_result, gnu_expr);
5911 break;
5913 case N_Selected_Component:
5915 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
5916 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
5917 Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
5918 tree gnu_field;
5920 while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
5921 || IN (Ekind (gnat_pref_type), Access_Kind))
5923 if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
5924 gnat_pref_type = Underlying_Type (gnat_pref_type);
5925 else if (IN (Ekind (gnat_pref_type), Access_Kind))
5926 gnat_pref_type = Designated_Type (gnat_pref_type);
5929 gnu_prefix = maybe_implicit_deref (gnu_prefix);
5931 /* For discriminant references in tagged types always substitute the
5932 corresponding discriminant as the actual selected component. */
5933 if (Is_Tagged_Type (gnat_pref_type))
5934 while (Present (Corresponding_Discriminant (gnat_field)))
5935 gnat_field = Corresponding_Discriminant (gnat_field);
5937 /* For discriminant references of untagged types always substitute the
5938 corresponding stored discriminant. */
5939 else if (Present (Corresponding_Discriminant (gnat_field)))
5940 gnat_field = Original_Record_Component (gnat_field);
5942 /* Handle extracting the real or imaginary part of a complex.
5943 The real part is the first field and the imaginary the last. */
5944 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
5945 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
5946 ? REALPART_EXPR : IMAGPART_EXPR,
5947 NULL_TREE, gnu_prefix);
5948 else
5950 gnu_field = gnat_to_gnu_field_decl (gnat_field);
5952 /* If there are discriminants, the prefix might be evaluated more
5953 than once, which is a problem if it has side-effects. */
5954 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
5955 ? Designated_Type (Etype
5956 (Prefix (gnat_node)))
5957 : Etype (Prefix (gnat_node))))
5958 gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL);
5960 gnu_result
5961 = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
5962 (Nkind (Parent (gnat_node))
5963 == N_Attribute_Reference)
5964 && lvalue_required_for_attribute_p
5965 (Parent (gnat_node)));
5968 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5970 /* If this is an atomic access on the RHS for which synchronization is
5971 required, build the atomic load. */
5972 if (atomic_sync_required_p (gnat_node)
5973 && !present_in_lhs_or_actual_p (gnat_node))
5974 gnu_result = build_atomic_load (gnu_result);
5976 break;
5978 case N_Attribute_Reference:
5980 /* The attribute designator. */
5981 const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
5983 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
5984 is a unit, not an object with a GCC equivalent. */
5985 if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
5986 return
5987 create_subprog_decl (create_concat_name
5988 (Entity (Prefix (gnat_node)),
5989 attr == Attr_Elab_Body ? "elabb" : "elabs"),
5990 NULL_TREE, void_ftype, NULL_TREE, is_disabled,
5991 true, true, true, NULL, gnat_node);
5993 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
5995 break;
5997 case N_Reference:
5998 /* Like 'Access as far as we are concerned. */
5999 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6000 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6001 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6002 break;
6004 case N_Aggregate:
6005 case N_Extension_Aggregate:
6007 tree gnu_aggr_type;
6009 /* ??? It is wrong to evaluate the type now, but there doesn't
6010 seem to be any other practical way of doing it. */
6012 gcc_assert (!Expansion_Delayed (gnat_node));
6014 gnu_aggr_type = gnu_result_type
6015 = get_unpadded_type (Etype (gnat_node));
6017 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
6018 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
6019 gnu_aggr_type
6020 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type)));
6021 else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
6022 gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
6024 if (Null_Record_Present (gnat_node))
6025 gnu_result = gnat_build_constructor (gnu_aggr_type,
6026 NULL);
6028 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
6029 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
6030 gnu_result
6031 = assoc_to_constructor (Etype (gnat_node),
6032 First (Component_Associations (gnat_node)),
6033 gnu_aggr_type);
6034 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
6035 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
6036 gnu_aggr_type,
6037 Component_Type (Etype (gnat_node)));
6038 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
6039 gnu_result
6040 = build_binary_op
6041 (COMPLEX_EXPR, gnu_aggr_type,
6042 gnat_to_gnu (Expression (First
6043 (Component_Associations (gnat_node)))),
6044 gnat_to_gnu (Expression
6045 (Next
6046 (First (Component_Associations (gnat_node))))));
6047 else
6048 gcc_unreachable ();
6050 gnu_result = convert (gnu_result_type, gnu_result);
6052 break;
6054 case N_Null:
6055 if (TARGET_VTABLE_USES_DESCRIPTORS
6056 && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
6057 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
6058 gnu_result = null_fdesc_node;
6059 else
6060 gnu_result = null_pointer_node;
6061 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6062 break;
6064 case N_Type_Conversion:
6065 case N_Qualified_Expression:
6066 /* Get the operand expression. */
6067 gnu_result = gnat_to_gnu (Expression (gnat_node));
6068 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6070 /* If this is a qualified expression for a tagged type, we mark the type
6071 as used. Because of polymorphism, this might be the only reference to
6072 the tagged type in the program while objects have it as dynamic type.
6073 The debugger needs to see it to display these objects properly. */
6074 if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node)))
6075 used_types_insert (gnu_result_type);
6077 gnu_result
6078 = convert_with_check (Etype (gnat_node), gnu_result,
6079 Do_Overflow_Check (gnat_node),
6080 Do_Range_Check (Expression (gnat_node)),
6081 kind == N_Type_Conversion
6082 && Float_Truncate (gnat_node), gnat_node);
6083 break;
6085 case N_Unchecked_Type_Conversion:
6086 gnu_result = gnat_to_gnu (Expression (gnat_node));
6088 /* Skip further processing if the conversion is deemed a no-op. */
6089 if (unchecked_conversion_nop (gnat_node))
6091 gnu_result_type = TREE_TYPE (gnu_result);
6092 break;
6095 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6097 /* If the result is a pointer type, see if we are improperly
6098 converting to a stricter alignment. */
6099 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
6100 && IN (Ekind (Etype (gnat_node)), Access_Kind))
6102 unsigned int align = known_alignment (gnu_result);
6103 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
6104 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
6106 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
6107 post_error_ne_tree_2
6108 ("?source alignment (^) '< alignment of & (^)",
6109 gnat_node, Designated_Type (Etype (gnat_node)),
6110 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
6113 /* If we are converting a descriptor to a function pointer, first
6114 build the pointer. */
6115 if (TARGET_VTABLE_USES_DESCRIPTORS
6116 && TREE_TYPE (gnu_result) == fdesc_type_node
6117 && POINTER_TYPE_P (gnu_result_type))
6118 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6120 gnu_result = unchecked_convert (gnu_result_type, gnu_result,
6121 No_Truncation (gnat_node));
6122 break;
6124 case N_In:
6125 case N_Not_In:
6127 tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
6128 Node_Id gnat_range = Right_Opnd (gnat_node);
6129 tree gnu_low, gnu_high;
6131 /* GNAT_RANGE is either an N_Range node or an identifier denoting a
6132 subtype. */
6133 if (Nkind (gnat_range) == N_Range)
6135 gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
6136 gnu_high = gnat_to_gnu (High_Bound (gnat_range));
6138 else if (Nkind (gnat_range) == N_Identifier
6139 || Nkind (gnat_range) == N_Expanded_Name)
6141 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
6143 gnu_low = TYPE_MIN_VALUE (gnu_range_type);
6144 gnu_high = TYPE_MAX_VALUE (gnu_range_type);
6146 else
6147 gcc_unreachable ();
6149 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6151 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
6152 ensure that GNU_OBJ is evaluated only once and perform a full range
6153 test. */
6154 if (operand_equal_p (gnu_low, gnu_high, 0))
6155 gnu_result
6156 = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
6157 else
6159 tree t1, t2;
6160 gnu_obj = gnat_protect_expr (gnu_obj);
6161 t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
6162 if (EXPR_P (t1))
6163 set_expr_location_from_node (t1, gnat_node);
6164 t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
6165 if (EXPR_P (t2))
6166 set_expr_location_from_node (t2, gnat_node);
6167 gnu_result
6168 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
6171 if (kind == N_Not_In)
6172 gnu_result
6173 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
6175 break;
6177 case N_Op_Divide:
6178 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6179 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6180 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6181 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
6182 ? RDIV_EXPR
6183 : (Rounded_Result (gnat_node)
6184 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
6185 gnu_result_type, gnu_lhs, gnu_rhs);
6186 break;
6188 case N_Op_Or: case N_Op_And: case N_Op_Xor:
6189 /* These can either be operations on booleans or on modular types.
6190 Fall through for boolean types since that's the way GNU_CODES is
6191 set up. */
6192 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
6194 enum tree_code code
6195 = (kind == N_Op_Or ? BIT_IOR_EXPR
6196 : kind == N_Op_And ? BIT_AND_EXPR
6197 : BIT_XOR_EXPR);
6199 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6200 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6201 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6202 gnu_result = build_binary_op (code, gnu_result_type,
6203 gnu_lhs, gnu_rhs);
6204 break;
6207 /* ... fall through ... */
6209 case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
6210 case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
6211 case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
6212 case N_Op_Mod: case N_Op_Rem:
6213 case N_Op_Rotate_Left:
6214 case N_Op_Rotate_Right:
6215 case N_Op_Shift_Left:
6216 case N_Op_Shift_Right:
6217 case N_Op_Shift_Right_Arithmetic:
6218 case N_And_Then: case N_Or_Else:
6220 enum tree_code code = gnu_codes[kind];
6221 bool ignore_lhs_overflow = false;
6222 location_t saved_location = input_location;
6223 tree gnu_type;
6225 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
6226 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
6227 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
6229 /* Pending generic support for efficient vector logical operations in
6230 GCC, convert vectors to their representative array type view and
6231 fallthrough. */
6232 gnu_lhs = maybe_vector_array (gnu_lhs);
6233 gnu_rhs = maybe_vector_array (gnu_rhs);
6235 /* If this is a comparison operator, convert any references to an
6236 unconstrained array value into a reference to the actual array. */
6237 if (TREE_CODE_CLASS (code) == tcc_comparison)
6239 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
6240 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
6243 /* If this is a shift whose count is not guaranteed to be correct,
6244 we need to adjust the shift count. */
6245 if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
6247 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
6248 tree gnu_max_shift
6249 = convert (gnu_count_type, TYPE_SIZE (gnu_type));
6251 if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
6252 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
6253 gnu_rhs, gnu_max_shift);
6254 else if (kind == N_Op_Shift_Right_Arithmetic)
6255 gnu_rhs
6256 = build_binary_op
6257 (MIN_EXPR, gnu_count_type,
6258 build_binary_op (MINUS_EXPR,
6259 gnu_count_type,
6260 gnu_max_shift,
6261 convert (gnu_count_type,
6262 integer_one_node)),
6263 gnu_rhs);
6266 /* For right shifts, the type says what kind of shift to do,
6267 so we may need to choose a different type. In this case,
6268 we have to ignore integer overflow lest it propagates all
6269 the way down and causes a CE to be explicitly raised. */
6270 if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
6272 gnu_type = gnat_unsigned_type (gnu_type);
6273 ignore_lhs_overflow = true;
6275 else if (kind == N_Op_Shift_Right_Arithmetic
6276 && TYPE_UNSIGNED (gnu_type))
6278 gnu_type = gnat_signed_type (gnu_type);
6279 ignore_lhs_overflow = true;
6282 if (gnu_type != gnu_result_type)
6284 tree gnu_old_lhs = gnu_lhs;
6285 gnu_lhs = convert (gnu_type, gnu_lhs);
6286 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
6287 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
6288 gnu_rhs = convert (gnu_type, gnu_rhs);
6291 /* Instead of expanding overflow checks for addition, subtraction
6292 and multiplication itself, the front end will leave this to
6293 the back end when Backend_Overflow_Checks_On_Target is set.
6294 As the GCC back end itself does not know yet how to properly
6295 do overflow checking, do it here. The goal is to push
6296 the expansions further into the back end over time. */
6297 if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
6298 && (kind == N_Op_Add
6299 || kind == N_Op_Subtract
6300 || kind == N_Op_Multiply)
6301 && !TYPE_UNSIGNED (gnu_type)
6302 && !FLOAT_TYPE_P (gnu_type))
6303 gnu_result = build_binary_op_trapv (code, gnu_type,
6304 gnu_lhs, gnu_rhs, gnat_node);
6305 else
6307 /* Some operations, e.g. comparisons of arrays, generate complex
6308 trees that need to be annotated while they are being built. */
6309 input_location = saved_location;
6310 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
6313 /* If this is a logical shift with the shift count not verified,
6314 we must return zero if it is too large. We cannot compensate
6315 above in this case. */
6316 if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
6317 && !Shift_Count_OK (gnat_node))
6318 gnu_result
6319 = build_cond_expr
6320 (gnu_type,
6321 build_binary_op (GE_EXPR, boolean_type_node,
6322 gnu_rhs,
6323 convert (TREE_TYPE (gnu_rhs),
6324 TYPE_SIZE (gnu_type))),
6325 convert (gnu_type, integer_zero_node),
6326 gnu_result);
6328 break;
6330 case N_If_Expression:
6332 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
6333 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
6334 tree gnu_false
6335 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
6337 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6338 gnu_result
6339 = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
6341 break;
6343 case N_Op_Plus:
6344 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
6345 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6346 break;
6348 case N_Op_Not:
6349 /* This case can apply to a boolean or a modular type.
6350 Fall through for a boolean operand since GNU_CODES is set
6351 up to handle this. */
6352 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
6354 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
6355 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6356 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
6357 gnu_expr);
6358 break;
6361 /* ... fall through ... */
6363 case N_Op_Minus: case N_Op_Abs:
6364 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
6365 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6367 if (Do_Overflow_Check (gnat_node)
6368 && !TYPE_UNSIGNED (gnu_result_type)
6369 && !FLOAT_TYPE_P (gnu_result_type))
6370 gnu_result
6371 = build_unary_op_trapv (gnu_codes[kind],
6372 gnu_result_type, gnu_expr, gnat_node);
6373 else
6374 gnu_result = build_unary_op (gnu_codes[kind],
6375 gnu_result_type, gnu_expr);
6376 break;
6378 case N_Allocator:
6380 tree gnu_init = 0;
6381 tree gnu_type;
6382 bool ignore_init_type = false;
6384 gnat_temp = Expression (gnat_node);
6386 /* The Expression operand can either be an N_Identifier or
6387 Expanded_Name, which must represent a type, or a
6388 N_Qualified_Expression, which contains both the object type and an
6389 initial value for the object. */
6390 if (Nkind (gnat_temp) == N_Identifier
6391 || Nkind (gnat_temp) == N_Expanded_Name)
6392 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
6393 else if (Nkind (gnat_temp) == N_Qualified_Expression)
6395 Entity_Id gnat_desig_type
6396 = Designated_Type (Underlying_Type (Etype (gnat_node)));
6398 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
6399 gnu_init = gnat_to_gnu (Expression (gnat_temp));
6401 gnu_init = maybe_unconstrained_array (gnu_init);
6402 if (Do_Range_Check (Expression (gnat_temp)))
6403 gnu_init
6404 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
6406 if (Is_Elementary_Type (gnat_desig_type)
6407 || Is_Constrained (gnat_desig_type))
6408 gnu_type = gnat_to_gnu_type (gnat_desig_type);
6409 else
6411 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
6412 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
6413 gnu_type = TREE_TYPE (gnu_init);
6416 /* See the N_Qualified_Expression case for the rationale. */
6417 if (Is_Tagged_Type (gnat_desig_type))
6418 used_types_insert (gnu_type);
6420 gnu_init = convert (gnu_type, gnu_init);
6422 else
6423 gcc_unreachable ();
6425 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6426 return build_allocator (gnu_type, gnu_init, gnu_result_type,
6427 Procedure_To_Call (gnat_node),
6428 Storage_Pool (gnat_node), gnat_node,
6429 ignore_init_type);
6431 break;
6433 /**************************/
6434 /* Chapter 5: Statements */
6435 /**************************/
6437 case N_Label:
6438 gnu_result = build1 (LABEL_EXPR, void_type_node,
6439 gnat_to_gnu (Identifier (gnat_node)));
6440 break;
6442 case N_Null_Statement:
6443 /* When not optimizing, turn null statements from source into gotos to
6444 the next statement that the middle-end knows how to preserve. */
6445 if (!optimize && Comes_From_Source (gnat_node))
6447 tree stmt, label = create_label_decl (NULL_TREE, gnat_node);
6448 DECL_IGNORED_P (label) = 1;
6449 start_stmt_group ();
6450 stmt = build1 (GOTO_EXPR, void_type_node, label);
6451 set_expr_location_from_node (stmt, gnat_node);
6452 add_stmt (stmt);
6453 stmt = build1 (LABEL_EXPR, void_type_node, label);
6454 set_expr_location_from_node (stmt, gnat_node);
6455 add_stmt (stmt);
6456 gnu_result = end_stmt_group ();
6458 else
6459 gnu_result = alloc_stmt_list ();
6460 break;
6462 case N_Assignment_Statement:
6463 /* Get the LHS and RHS of the statement and convert any reference to an
6464 unconstrained array into a reference to the underlying array. */
6465 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
6467 /* If the type has a size that overflows, convert this into raise of
6468 Storage_Error: execution shouldn't have gotten here anyway. */
6469 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
6470 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
6471 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
6472 N_Raise_Storage_Error);
6473 else if (Nkind (Expression (gnat_node)) == N_Function_Call)
6474 gnu_result
6475 = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
6476 atomic_sync_required_p (Name (gnat_node)));
6477 else
6479 gnu_rhs
6480 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
6482 /* If range check is needed, emit code to generate it. */
6483 if (Do_Range_Check (Expression (gnat_node)))
6484 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
6485 gnat_node);
6487 if (atomic_sync_required_p (Name (gnat_node)))
6488 gnu_result = build_atomic_store (gnu_lhs, gnu_rhs);
6489 else
6490 gnu_result
6491 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
6493 /* If the type being assigned is an array type and the two sides are
6494 not completely disjoint, play safe and use memmove. But don't do
6495 it for a bit-packed array as it might not be byte-aligned. */
6496 if (TREE_CODE (gnu_result) == MODIFY_EXPR
6497 && Is_Array_Type (Etype (Name (gnat_node)))
6498 && !Is_Bit_Packed_Array (Etype (Name (gnat_node)))
6499 && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
6501 tree to, from, size, to_ptr, from_ptr, t;
6503 to = TREE_OPERAND (gnu_result, 0);
6504 from = TREE_OPERAND (gnu_result, 1);
6506 size = TYPE_SIZE_UNIT (TREE_TYPE (from));
6507 size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from);
6509 to_ptr = build_fold_addr_expr (to);
6510 from_ptr = build_fold_addr_expr (from);
6512 t = builtin_decl_implicit (BUILT_IN_MEMMOVE);
6513 gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
6516 break;
6518 case N_If_Statement:
6520 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
6522 /* Make the outer COND_EXPR. Avoid non-determinism. */
6523 gnu_result = build3 (COND_EXPR, void_type_node,
6524 gnat_to_gnu (Condition (gnat_node)),
6525 NULL_TREE, NULL_TREE);
6526 COND_EXPR_THEN (gnu_result)
6527 = build_stmt_group (Then_Statements (gnat_node), false);
6528 TREE_SIDE_EFFECTS (gnu_result) = 1;
6529 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
6531 /* Now make a COND_EXPR for each of the "else if" parts. Put each
6532 into the previous "else" part and point to where to put any
6533 outer "else". Also avoid non-determinism. */
6534 if (Present (Elsif_Parts (gnat_node)))
6535 for (gnat_temp = First (Elsif_Parts (gnat_node));
6536 Present (gnat_temp); gnat_temp = Next (gnat_temp))
6538 gnu_expr = build3 (COND_EXPR, void_type_node,
6539 gnat_to_gnu (Condition (gnat_temp)),
6540 NULL_TREE, NULL_TREE);
6541 COND_EXPR_THEN (gnu_expr)
6542 = build_stmt_group (Then_Statements (gnat_temp), false);
6543 TREE_SIDE_EFFECTS (gnu_expr) = 1;
6544 set_expr_location_from_node (gnu_expr, gnat_temp);
6545 *gnu_else_ptr = gnu_expr;
6546 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
6549 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
6551 break;
6553 case N_Case_Statement:
6554 gnu_result = Case_Statement_to_gnu (gnat_node);
6555 break;
6557 case N_Loop_Statement:
6558 gnu_result = Loop_Statement_to_gnu (gnat_node);
6559 break;
6561 case N_Block_Statement:
6562 /* The only way to enter the block is to fall through to it. */
6563 if (stmt_group_may_fallthru ())
6565 start_stmt_group ();
6566 gnat_pushlevel ();
6567 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
6568 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
6569 gnat_poplevel ();
6570 gnu_result = end_stmt_group ();
6572 else
6573 gnu_result = alloc_stmt_list ();
6574 break;
6576 case N_Exit_Statement:
6577 gnu_result
6578 = build2 (EXIT_STMT, void_type_node,
6579 (Present (Condition (gnat_node))
6580 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
6581 (Present (Name (gnat_node))
6582 ? get_gnu_tree (Entity (Name (gnat_node)))
6583 : LOOP_STMT_LABEL (gnu_loop_stack->last ()->stmt)));
6584 break;
6586 case N_Simple_Return_Statement:
6588 tree gnu_ret_obj, gnu_ret_val;
6590 /* If the subprogram is a function, we must return the expression. */
6591 if (Present (Expression (gnat_node)))
6593 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
6595 /* If this function has copy-in/copy-out parameters, get the real
6596 object for the return. See Subprogram_to_gnu. */
6597 if (TYPE_CI_CO_LIST (gnu_subprog_type))
6598 gnu_ret_obj = gnu_return_var_stack->last ();
6599 else
6600 gnu_ret_obj = DECL_RESULT (current_function_decl);
6602 /* Get the GCC tree for the expression to be returned. */
6603 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
6605 /* Do not remove the padding from GNU_RET_VAL if the inner type is
6606 self-referential since we want to allocate the fixed size. */
6607 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
6608 && TYPE_IS_PADDING_P
6609 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
6610 && CONTAINS_PLACEHOLDER_P
6611 (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
6612 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
6614 /* If the function returns by direct reference, return a pointer
6615 to the return value. */
6616 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
6617 || By_Ref (gnat_node))
6618 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
6620 /* Otherwise, if it returns an unconstrained array, we have to
6621 allocate a new version of the result and return it. */
6622 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
6624 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
6626 /* And find out whether this is a candidate for Named Return
6627 Value. If so, record it. */
6628 if (!TYPE_CI_CO_LIST (gnu_subprog_type) && optimize)
6630 tree ret_val = gnu_ret_val;
6632 /* Strip useless conversions around the return value. */
6633 if (gnat_useless_type_conversion (ret_val))
6634 ret_val = TREE_OPERAND (ret_val, 0);
6636 /* Strip unpadding around the return value. */
6637 if (TREE_CODE (ret_val) == COMPONENT_REF
6638 && TYPE_IS_PADDING_P
6639 (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
6640 ret_val = TREE_OPERAND (ret_val, 0);
6642 /* Now apply the test to the return value. */
6643 if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
6645 if (!f_named_ret_val)
6646 f_named_ret_val = BITMAP_GGC_ALLOC ();
6647 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
6648 if (!f_gnat_ret)
6649 f_gnat_ret = gnat_node;
6653 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
6654 gnu_ret_val,
6655 TREE_TYPE (gnu_ret_obj),
6656 Procedure_To_Call (gnat_node),
6657 Storage_Pool (gnat_node),
6658 gnat_node, false);
6661 /* Otherwise, if it returns by invisible reference, dereference
6662 the pointer it is passed using the type of the return value
6663 and build the copy operation manually. This ensures that we
6664 don't copy too much data, for example if the return type is
6665 unconstrained with a maximum size. */
6666 else if (TREE_ADDRESSABLE (gnu_subprog_type))
6668 tree gnu_ret_deref
6669 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
6670 gnu_ret_obj);
6671 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
6672 gnu_ret_deref, gnu_ret_val);
6673 add_stmt_with_node (gnu_result, gnat_node);
6674 gnu_ret_val = NULL_TREE;
6678 else
6679 gnu_ret_obj = gnu_ret_val = NULL_TREE;
6681 /* If we have a return label defined, convert this into a branch to
6682 that label. The return proper will be handled elsewhere. */
6683 if (gnu_return_label_stack->last ())
6685 if (gnu_ret_obj)
6686 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
6687 gnu_ret_val));
6689 gnu_result = build1 (GOTO_EXPR, void_type_node,
6690 gnu_return_label_stack->last ());
6692 /* When not optimizing, make sure the return is preserved. */
6693 if (!optimize && Comes_From_Source (gnat_node))
6694 DECL_ARTIFICIAL (gnu_return_label_stack->last ()) = 0;
6697 /* Otherwise, build a regular return. */
6698 else
6699 gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
6701 break;
6703 case N_Goto_Statement:
6704 gnu_result
6705 = build1 (GOTO_EXPR, void_type_node, gnat_to_gnu (Name (gnat_node)));
6706 break;
6708 /***************************/
6709 /* Chapter 6: Subprograms */
6710 /***************************/
6712 case N_Subprogram_Declaration:
6713 /* Unless there is a freeze node, declare the subprogram. We consider
6714 this a "definition" even though we're not generating code for
6715 the subprogram because we will be making the corresponding GCC
6716 node here. */
6718 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
6719 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
6720 NULL_TREE, 1);
6721 gnu_result = alloc_stmt_list ();
6722 break;
6724 case N_Abstract_Subprogram_Declaration:
6725 /* This subprogram doesn't exist for code generation purposes, but we
6726 have to elaborate the types of any parameters and result, unless
6727 they are imported types (nothing to generate in this case).
6729 The parameter list may contain types with freeze nodes, e.g. not null
6730 subtypes, so the subprogram itself may carry a freeze node, in which
6731 case its elaboration must be deferred. */
6733 /* Process the parameter types first. */
6734 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
6735 for (gnat_temp
6736 = First_Formal_With_Extras
6737 (Defining_Entity (Specification (gnat_node)));
6738 Present (gnat_temp);
6739 gnat_temp = Next_Formal_With_Extras (gnat_temp))
6740 if (Is_Itype (Etype (gnat_temp))
6741 && !From_Limited_With (Etype (gnat_temp)))
6742 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
6744 /* Then the result type, set to Standard_Void_Type for procedures. */
6746 Entity_Id gnat_temp_type
6747 = Etype (Defining_Entity (Specification (gnat_node)));
6749 if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type))
6750 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
6753 gnu_result = alloc_stmt_list ();
6754 break;
6756 case N_Defining_Program_Unit_Name:
6757 /* For a child unit identifier go up a level to get the specification.
6758 We get this when we try to find the spec of a child unit package
6759 that is the compilation unit being compiled. */
6760 gnu_result = gnat_to_gnu (Parent (gnat_node));
6761 break;
6763 case N_Subprogram_Body:
6764 Subprogram_Body_to_gnu (gnat_node);
6765 gnu_result = alloc_stmt_list ();
6766 break;
6768 case N_Function_Call:
6769 case N_Procedure_Call_Statement:
6770 gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE, false);
6771 break;
6773 /************************/
6774 /* Chapter 7: Packages */
6775 /************************/
6777 case N_Package_Declaration:
6778 gnu_result = gnat_to_gnu (Specification (gnat_node));
6779 break;
6781 case N_Package_Specification:
6783 start_stmt_group ();
6784 process_decls (Visible_Declarations (gnat_node),
6785 Private_Declarations (gnat_node), Empty, true, true);
6786 gnu_result = end_stmt_group ();
6787 break;
6789 case N_Package_Body:
6791 /* If this is the body of a generic package - do nothing. */
6792 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
6794 gnu_result = alloc_stmt_list ();
6795 break;
6798 start_stmt_group ();
6799 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
6801 if (Present (Handled_Statement_Sequence (gnat_node)))
6802 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
6804 gnu_result = end_stmt_group ();
6805 break;
6807 /********************************/
6808 /* Chapter 8: Visibility Rules */
6809 /********************************/
6811 case N_Use_Package_Clause:
6812 case N_Use_Type_Clause:
6813 /* Nothing to do here - but these may appear in list of declarations. */
6814 gnu_result = alloc_stmt_list ();
6815 break;
6817 /*********************/
6818 /* Chapter 9: Tasks */
6819 /*********************/
6821 case N_Protected_Type_Declaration:
6822 gnu_result = alloc_stmt_list ();
6823 break;
6825 case N_Single_Task_Declaration:
6826 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
6827 gnu_result = alloc_stmt_list ();
6828 break;
6830 /*********************************************************/
6831 /* Chapter 10: Program Structure and Compilation Issues */
6832 /*********************************************************/
6834 case N_Compilation_Unit:
6835 /* This is not called for the main unit on which gigi is invoked. */
6836 Compilation_Unit_to_gnu (gnat_node);
6837 gnu_result = alloc_stmt_list ();
6838 break;
6840 case N_Subprogram_Body_Stub:
6841 case N_Package_Body_Stub:
6842 case N_Protected_Body_Stub:
6843 case N_Task_Body_Stub:
6844 /* Simply process whatever unit is being inserted. */
6845 if (Present (Library_Unit (gnat_node)))
6846 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
6847 else
6849 gcc_assert (type_annotate_only);
6850 gnu_result = alloc_stmt_list ();
6852 break;
6854 case N_Subunit:
6855 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
6856 break;
6858 /***************************/
6859 /* Chapter 11: Exceptions */
6860 /***************************/
6862 case N_Handled_Sequence_Of_Statements:
6863 /* If there is an At_End procedure attached to this node, and the EH
6864 mechanism is SJLJ, we must have at least a corresponding At_End
6865 handler, unless the No_Exception_Handlers restriction is set. */
6866 gcc_assert (type_annotate_only
6867 || Exception_Mechanism != Setjmp_Longjmp
6868 || No (At_End_Proc (gnat_node))
6869 || Present (Exception_Handlers (gnat_node))
6870 || No_Exception_Handlers_Set ());
6872 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
6873 break;
6875 case N_Exception_Handler:
6876 if (Exception_Mechanism == Setjmp_Longjmp)
6877 gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
6878 else if (Exception_Mechanism == Back_End_Exceptions)
6879 gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
6880 else
6881 gcc_unreachable ();
6882 break;
6884 case N_Raise_Statement:
6885 /* Only for reraise in back-end exceptions mode. */
6886 gcc_assert (No (Name (gnat_node))
6887 && Exception_Mechanism == Back_End_Exceptions);
6889 start_stmt_group ();
6890 gnat_pushlevel ();
6892 /* Clear the current exception pointer so that the occurrence won't be
6893 deallocated. */
6894 gnu_expr = create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE,
6895 ptr_type_node, gnu_incoming_exc_ptr,
6896 false, false, false, false, NULL, gnat_node);
6898 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_incoming_exc_ptr,
6899 convert (ptr_type_node, integer_zero_node)));
6900 add_stmt (build_call_n_expr (reraise_zcx_decl, 1, gnu_expr));
6901 gnat_poplevel ();
6902 gnu_result = end_stmt_group ();
6903 break;
6905 case N_Push_Constraint_Error_Label:
6906 push_exception_label_stack (&gnu_constraint_error_label_stack,
6907 Exception_Label (gnat_node));
6908 break;
6910 case N_Push_Storage_Error_Label:
6911 push_exception_label_stack (&gnu_storage_error_label_stack,
6912 Exception_Label (gnat_node));
6913 break;
6915 case N_Push_Program_Error_Label:
6916 push_exception_label_stack (&gnu_program_error_label_stack,
6917 Exception_Label (gnat_node));
6918 break;
6920 case N_Pop_Constraint_Error_Label:
6921 gnu_constraint_error_label_stack->pop ();
6922 break;
6924 case N_Pop_Storage_Error_Label:
6925 gnu_storage_error_label_stack->pop ();
6926 break;
6928 case N_Pop_Program_Error_Label:
6929 gnu_program_error_label_stack->pop ();
6930 break;
6932 /******************************/
6933 /* Chapter 12: Generic Units */
6934 /******************************/
6936 case N_Generic_Function_Renaming_Declaration:
6937 case N_Generic_Package_Renaming_Declaration:
6938 case N_Generic_Procedure_Renaming_Declaration:
6939 case N_Generic_Package_Declaration:
6940 case N_Generic_Subprogram_Declaration:
6941 case N_Package_Instantiation:
6942 case N_Procedure_Instantiation:
6943 case N_Function_Instantiation:
6944 /* These nodes can appear on a declaration list but there is nothing to
6945 to be done with them. */
6946 gnu_result = alloc_stmt_list ();
6947 break;
6949 /**************************************************/
6950 /* Chapter 13: Representation Clauses and */
6951 /* Implementation-Dependent Features */
6952 /**************************************************/
6954 case N_Attribute_Definition_Clause:
6955 gnu_result = alloc_stmt_list ();
6957 /* The only one we need to deal with is 'Address since, for the others,
6958 the front-end puts the information elsewhere. */
6959 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
6960 break;
6962 /* And we only deal with 'Address if the object has a Freeze node. */
6963 gnat_temp = Entity (Name (gnat_node));
6964 if (No (Freeze_Node (gnat_temp)))
6965 break;
6967 /* Get the value to use as the address and save it as the equivalent
6968 for the object. When it is frozen, gnat_to_gnu_entity will do the
6969 right thing. */
6970 save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
6971 break;
6973 case N_Enumeration_Representation_Clause:
6974 case N_Record_Representation_Clause:
6975 case N_At_Clause:
6976 /* We do nothing with these. SEM puts the information elsewhere. */
6977 gnu_result = alloc_stmt_list ();
6978 break;
6980 case N_Code_Statement:
6981 if (!type_annotate_only)
6983 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
6984 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
6985 tree gnu_clobbers = NULL_TREE, tail;
6986 bool allows_mem, allows_reg, fake;
6987 int ninputs, noutputs, i;
6988 const char **oconstraints;
6989 const char *constraint;
6990 char *clobber;
6992 /* First retrieve the 3 operand lists built by the front-end. */
6993 Setup_Asm_Outputs (gnat_node);
6994 while (Present (gnat_temp = Asm_Output_Variable ()))
6996 tree gnu_value = gnat_to_gnu (gnat_temp);
6997 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
6998 (Asm_Output_Constraint ()));
7000 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
7001 Next_Asm_Output ();
7004 Setup_Asm_Inputs (gnat_node);
7005 while (Present (gnat_temp = Asm_Input_Value ()))
7007 tree gnu_value = gnat_to_gnu (gnat_temp);
7008 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7009 (Asm_Input_Constraint ()));
7011 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
7012 Next_Asm_Input ();
7015 Clobber_Setup (gnat_node);
7016 while ((clobber = Clobber_Get_Next ()))
7017 gnu_clobbers
7018 = tree_cons (NULL_TREE,
7019 build_string (strlen (clobber) + 1, clobber),
7020 gnu_clobbers);
7022 /* Then perform some standard checking and processing on the
7023 operands. In particular, mark them addressable if needed. */
7024 gnu_outputs = nreverse (gnu_outputs);
7025 noutputs = list_length (gnu_outputs);
7026 gnu_inputs = nreverse (gnu_inputs);
7027 ninputs = list_length (gnu_inputs);
7028 oconstraints = XALLOCAVEC (const char *, noutputs);
7030 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
7032 tree output = TREE_VALUE (tail);
7033 constraint
7034 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7035 oconstraints[i] = constraint;
7037 if (parse_output_constraint (&constraint, i, ninputs, noutputs,
7038 &allows_mem, &allows_reg, &fake))
7040 /* If the operand is going to end up in memory,
7041 mark it addressable. Note that we don't test
7042 allows_mem like in the input case below; this
7043 is modelled on the C front-end. */
7044 if (!allows_reg)
7046 output = remove_conversions (output, false);
7047 if (TREE_CODE (output) == CONST_DECL
7048 && DECL_CONST_CORRESPONDING_VAR (output))
7049 output = DECL_CONST_CORRESPONDING_VAR (output);
7050 if (!gnat_mark_addressable (output))
7051 output = error_mark_node;
7054 else
7055 output = error_mark_node;
7057 TREE_VALUE (tail) = output;
7060 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
7062 tree input = TREE_VALUE (tail);
7063 constraint
7064 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
7066 if (parse_input_constraint (&constraint, i, ninputs, noutputs,
7067 0, oconstraints,
7068 &allows_mem, &allows_reg))
7070 /* If the operand is going to end up in memory,
7071 mark it addressable. */
7072 if (!allows_reg && allows_mem)
7074 input = remove_conversions (input, false);
7075 if (TREE_CODE (input) == CONST_DECL
7076 && DECL_CONST_CORRESPONDING_VAR (input))
7077 input = DECL_CONST_CORRESPONDING_VAR (input);
7078 if (!gnat_mark_addressable (input))
7079 input = error_mark_node;
7082 else
7083 input = error_mark_node;
7085 TREE_VALUE (tail) = input;
7088 gnu_result = build5 (ASM_EXPR, void_type_node,
7089 gnu_template, gnu_outputs,
7090 gnu_inputs, gnu_clobbers, NULL_TREE);
7091 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
7093 else
7094 gnu_result = alloc_stmt_list ();
7096 break;
7098 /****************/
7099 /* Added Nodes */
7100 /****************/
7102 case N_Expression_With_Actions:
7103 /* This construct doesn't define a scope so we don't push a binding level
7104 around the statement list; but we wrap it in a SAVE_EXPR to protect it
7105 from unsharing. */
7106 gnu_result = build_stmt_group (Actions (gnat_node), false);
7107 gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
7108 TREE_SIDE_EFFECTS (gnu_result) = 1;
7109 gnu_expr = gnat_to_gnu (Expression (gnat_node));
7110 gnu_result
7111 = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
7112 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7113 break;
7115 case N_Freeze_Entity:
7116 start_stmt_group ();
7117 process_freeze_entity (gnat_node);
7118 process_decls (Actions (gnat_node), Empty, Empty, true, true);
7119 gnu_result = end_stmt_group ();
7120 break;
7122 case N_Freeze_Generic_Entity:
7123 gnu_result = alloc_stmt_list ();
7124 break;
7126 case N_Itype_Reference:
7127 if (!present_gnu_tree (Itype (gnat_node)))
7128 process_type (Itype (gnat_node));
7130 gnu_result = alloc_stmt_list ();
7131 break;
7133 case N_Free_Statement:
7134 if (!type_annotate_only)
7136 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
7137 tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
7138 tree gnu_obj_type, gnu_actual_obj_type;
7140 /* If this is a thin pointer, we must first dereference it to create
7141 a fat pointer, then go back below to a thin pointer. The reason
7142 for this is that we need to have a fat pointer someplace in order
7143 to properly compute the size. */
7144 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
7145 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
7146 build_unary_op (INDIRECT_REF, NULL_TREE,
7147 gnu_ptr));
7149 /* If this is a fat pointer, the object must have been allocated with
7150 the template in front of the array. So pass the template address,
7151 and get the total size; do it by converting to a thin pointer. */
7152 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
7153 gnu_ptr
7154 = convert (build_pointer_type
7155 (TYPE_OBJECT_RECORD_TYPE
7156 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
7157 gnu_ptr);
7159 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
7161 /* If this is a thin pointer, the object must have been allocated with
7162 the template in front of the array. So pass the template address,
7163 and get the total size. */
7164 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
7165 gnu_ptr
7166 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
7167 gnu_ptr,
7168 fold_build1 (NEGATE_EXPR, sizetype,
7169 byte_position
7170 (DECL_CHAIN
7171 TYPE_FIELDS ((gnu_obj_type)))));
7173 /* If we have a special dynamic constrained subtype on the node, use
7174 it to compute the size; otherwise, use the designated subtype. */
7175 if (Present (Actual_Designated_Subtype (gnat_node)))
7177 gnu_actual_obj_type
7178 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
7180 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
7181 gnu_actual_obj_type
7182 = build_unc_object_type_from_ptr (gnu_ptr_type,
7183 gnu_actual_obj_type,
7184 get_identifier ("DEALLOC"),
7185 false);
7187 else
7188 gnu_actual_obj_type = gnu_obj_type;
7190 gnu_result
7191 = build_call_alloc_dealloc (gnu_ptr,
7192 TYPE_SIZE_UNIT (gnu_actual_obj_type),
7193 gnu_obj_type,
7194 Procedure_To_Call (gnat_node),
7195 Storage_Pool (gnat_node),
7196 gnat_node);
7198 break;
7200 case N_Raise_Constraint_Error:
7201 case N_Raise_Program_Error:
7202 case N_Raise_Storage_Error:
7203 if (type_annotate_only)
7204 gnu_result = alloc_stmt_list ();
7205 else
7206 gnu_result = Raise_Error_to_gnu (gnat_node, &gnu_result_type);
7207 break;
7209 case N_Validate_Unchecked_Conversion:
7210 /* The only validation we currently do on an unchecked conversion is
7211 that of aliasing assumptions. */
7212 if (flag_strict_aliasing)
7213 gnat_validate_uc_list.safe_push (gnat_node);
7214 gnu_result = alloc_stmt_list ();
7215 break;
7217 case N_Function_Specification:
7218 case N_Procedure_Specification:
7219 case N_Op_Concat:
7220 case N_Component_Association:
7221 case N_Protected_Body:
7222 case N_Task_Body:
7223 /* These nodes should only be present when annotating types. */
7224 gcc_assert (type_annotate_only);
7225 gnu_result = alloc_stmt_list ();
7226 break;
7228 default:
7229 /* Other nodes are not supposed to reach here. */
7230 gcc_unreachable ();
7233 /* If we pushed the processing of the elaboration routine, pop it back. */
7234 if (went_into_elab_proc)
7235 current_function_decl = NULL_TREE;
7237 /* When not optimizing, turn boolean rvalues B into B != false tests
7238 so that the code just below can put the location information of the
7239 reference to B on the inequality operator for better debug info. */
7240 if (!optimize
7241 && TREE_CODE (gnu_result) != INTEGER_CST
7242 && (kind == N_Identifier
7243 || kind == N_Expanded_Name
7244 || kind == N_Explicit_Dereference
7245 || kind == N_Function_Call
7246 || kind == N_Indexed_Component
7247 || kind == N_Selected_Component)
7248 && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
7249 && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
7250 gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
7251 convert (gnu_result_type, gnu_result),
7252 convert (gnu_result_type,
7253 boolean_false_node));
7255 /* Set the location information on the result. Note that we may have
7256 no result if we tried to build a CALL_EXPR node to a procedure with
7257 no side-effects and optimization is enabled. */
7258 if (gnu_result && EXPR_P (gnu_result))
7259 set_gnu_expr_location_from_node (gnu_result, gnat_node);
7261 /* If we're supposed to return something of void_type, it means we have
7262 something we're elaborating for effect, so just return. */
7263 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
7264 return gnu_result;
7266 /* If the result is a constant that overflowed, raise Constraint_Error. */
7267 if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
7269 post_error ("?`Constraint_Error` will be raised at run time", gnat_node);
7270 gnu_result
7271 = build1 (NULL_EXPR, gnu_result_type,
7272 build_call_raise (CE_Overflow_Check_Failed, gnat_node,
7273 N_Raise_Constraint_Error));
7276 /* If the result has side-effects and is of an unconstrained type, make a
7277 SAVE_EXPR so that we can be sure it will only be referenced once. But
7278 this is useless for a call to a function that returns an unconstrained
7279 type with default discriminant, as we cannot compute the size of the
7280 actual returned object. We must do this before any conversions. */
7281 if (TREE_SIDE_EFFECTS (gnu_result)
7282 && !(TREE_CODE (gnu_result) == CALL_EXPR
7283 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
7284 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
7285 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
7286 gnu_result = gnat_stabilize_reference (gnu_result, false, NULL);
7288 /* Now convert the result to the result type, unless we are in one of the
7289 following cases:
7291 1. If this is the LHS of an assignment or an actual parameter of a
7292 call, return the result almost unmodified since the RHS will have
7293 to be converted to our type in that case, unless the result type
7294 has a simpler size. Likewise if there is just a no-op unchecked
7295 conversion in-between. Similarly, don't convert integral types
7296 that are the operands of an unchecked conversion since we need
7297 to ignore those conversions (for 'Valid).
7299 2. If we have a label (which doesn't have any well-defined type), a
7300 field or an error, return the result almost unmodified. Similarly,
7301 if the two types are record types with the same name, don't convert.
7302 This will be the case when we are converting from a packable version
7303 of a type to its original type and we need those conversions to be
7304 NOPs in order for assignments into these types to work properly.
7306 3. If the type is void or if we have no result, return error_mark_node
7307 to show we have no result.
7309 4. If this a call to a function that returns an unconstrained type with
7310 default discriminant, return the call expression unmodified since we
7311 cannot compute the size of the actual returned object.
7313 5. Finally, if the type of the result is already correct. */
7315 if (Present (Parent (gnat_node))
7316 && (lhs_or_actual_p (gnat_node)
7317 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
7318 && unchecked_conversion_nop (Parent (gnat_node)))
7319 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
7320 && !AGGREGATE_TYPE_P (gnu_result_type)
7321 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
7322 && !(TYPE_SIZE (gnu_result_type)
7323 && TYPE_SIZE (TREE_TYPE (gnu_result))
7324 && (AGGREGATE_TYPE_P (gnu_result_type)
7325 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
7326 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
7327 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
7328 != INTEGER_CST))
7329 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
7330 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
7331 && (CONTAINS_PLACEHOLDER_P
7332 (TYPE_SIZE (TREE_TYPE (gnu_result))))))
7333 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
7334 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
7336 /* Remove padding only if the inner object is of self-referential
7337 size: in that case it must be an object of unconstrained type
7338 with a default discriminant and we want to avoid copying too
7339 much data. */
7340 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
7341 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
7342 (TREE_TYPE (gnu_result))))))
7343 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
7344 gnu_result);
7347 else if (TREE_CODE (gnu_result) == LABEL_DECL
7348 || TREE_CODE (gnu_result) == FIELD_DECL
7349 || TREE_CODE (gnu_result) == ERROR_MARK
7350 || (TYPE_NAME (gnu_result_type)
7351 == TYPE_NAME (TREE_TYPE (gnu_result))
7352 && TREE_CODE (gnu_result_type) == RECORD_TYPE
7353 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
7355 /* Remove any padding. */
7356 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
7357 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
7358 gnu_result);
7361 else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
7362 gnu_result = error_mark_node;
7364 else if (TREE_CODE (gnu_result) == CALL_EXPR
7365 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
7366 && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result)))
7367 == gnu_result_type
7368 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
7371 else if (TREE_TYPE (gnu_result) != gnu_result_type)
7372 gnu_result = convert (gnu_result_type, gnu_result);
7374 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
7375 while ((TREE_CODE (gnu_result) == NOP_EXPR
7376 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
7377 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
7378 gnu_result = TREE_OPERAND (gnu_result, 0);
7380 return gnu_result;
7383 /* Subroutine of above to push the exception label stack. GNU_STACK is
7384 a pointer to the stack to update and GNAT_LABEL, if present, is the
7385 label to push onto the stack. */
7387 static void
7388 push_exception_label_stack (vec<tree, va_gc> **gnu_stack, Entity_Id gnat_label)
7390 tree gnu_label = (Present (gnat_label)
7391 ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
7392 : NULL_TREE);
7394 vec_safe_push (*gnu_stack, gnu_label);
7397 /* Record the current code position in GNAT_NODE. */
7399 static void
7400 record_code_position (Node_Id gnat_node)
7402 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
7404 add_stmt_with_node (stmt_stmt, gnat_node);
7405 save_gnu_tree (gnat_node, stmt_stmt, true);
7408 /* Insert the code for GNAT_NODE at the position saved for that node. */
7410 static void
7411 insert_code_for (Node_Id gnat_node)
7413 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
7414 save_gnu_tree (gnat_node, NULL_TREE, true);
7417 /* Start a new statement group chained to the previous group. */
7419 void
7420 start_stmt_group (void)
7422 struct stmt_group *group = stmt_group_free_list;
7424 /* First see if we can get one from the free list. */
7425 if (group)
7426 stmt_group_free_list = group->previous;
7427 else
7428 group = ggc_alloc<stmt_group> ();
7430 group->previous = current_stmt_group;
7431 group->stmt_list = group->block = group->cleanups = NULL_TREE;
7432 current_stmt_group = group;
7435 /* Add GNU_STMT to the current statement group. If it is an expression with
7436 no effects, it is ignored. */
7438 void
7439 add_stmt (tree gnu_stmt)
7441 append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
7444 /* Similar, but the statement is always added, regardless of side-effects. */
7446 void
7447 add_stmt_force (tree gnu_stmt)
7449 append_to_statement_list_force (gnu_stmt, &current_stmt_group->stmt_list);
7452 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
7454 void
7455 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
7457 if (Present (gnat_node))
7458 set_expr_location_from_node (gnu_stmt, gnat_node);
7459 add_stmt (gnu_stmt);
7462 /* Similar, but the statement is always added, regardless of side-effects. */
7464 void
7465 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
7467 if (Present (gnat_node))
7468 set_expr_location_from_node (gnu_stmt, gnat_node);
7469 add_stmt_force (gnu_stmt);
7472 /* Add a declaration statement for GNU_DECL to the current statement group.
7473 Get SLOC from Entity_Id. */
7475 void
7476 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
7478 tree type = TREE_TYPE (gnu_decl);
7479 tree gnu_stmt, gnu_init, t;
7481 /* If this is a variable that Gigi is to ignore, we may have been given
7482 an ERROR_MARK. So test for it. We also might have been given a
7483 reference for a renaming. So only do something for a decl. Also
7484 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
7485 if (!DECL_P (gnu_decl)
7486 || (TREE_CODE (gnu_decl) == TYPE_DECL
7487 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
7488 return;
7490 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
7492 /* If we are external or global, we don't want to output the DECL_EXPR for
7493 this DECL node since we already have evaluated the expressions in the
7494 sizes and positions as globals and doing it again would be wrong. */
7495 if (DECL_EXTERNAL (gnu_decl) || global_bindings_p ())
7497 /* Mark everything as used to prevent node sharing with subprograms.
7498 Note that walk_tree knows how to deal with TYPE_DECL, but neither
7499 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
7500 MARK_VISITED (gnu_stmt);
7501 if (TREE_CODE (gnu_decl) == VAR_DECL
7502 || TREE_CODE (gnu_decl) == CONST_DECL)
7504 MARK_VISITED (DECL_SIZE (gnu_decl));
7505 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
7506 MARK_VISITED (DECL_INITIAL (gnu_decl));
7508 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
7509 else if (TREE_CODE (gnu_decl) == TYPE_DECL
7510 && RECORD_OR_UNION_TYPE_P (type)
7511 && !TYPE_FAT_POINTER_P (type))
7512 MARK_VISITED (TYPE_ADA_SIZE (type));
7514 else
7515 add_stmt_with_node (gnu_stmt, gnat_entity);
7517 /* If this is a variable and an initializer is attached to it, it must be
7518 valid for the context. Similar to init_const in create_var_decl_1. */
7519 if (TREE_CODE (gnu_decl) == VAR_DECL
7520 && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
7521 && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
7522 || (TREE_STATIC (gnu_decl)
7523 && !initializer_constant_valid_p (gnu_init,
7524 TREE_TYPE (gnu_init)))))
7526 /* If GNU_DECL has a padded type, convert it to the unpadded
7527 type so the assignment is done properly. */
7528 if (TYPE_IS_PADDING_P (type))
7529 t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
7530 else
7531 t = gnu_decl;
7533 gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
7535 DECL_INITIAL (gnu_decl) = NULL_TREE;
7536 if (TREE_READONLY (gnu_decl))
7538 TREE_READONLY (gnu_decl) = 0;
7539 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
7542 add_stmt_with_node (gnu_stmt, gnat_entity);
7546 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
7548 static tree
7549 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
7551 tree t = *tp;
7553 if (TREE_VISITED (t))
7554 *walk_subtrees = 0;
7556 /* Don't mark a dummy type as visited because we want to mark its sizes
7557 and fields once it's filled in. */
7558 else if (!TYPE_IS_DUMMY_P (t))
7559 TREE_VISITED (t) = 1;
7561 if (TYPE_P (t))
7562 TYPE_SIZES_GIMPLIFIED (t) = 1;
7564 return NULL_TREE;
7567 /* Mark nodes rooted at T with TREE_VISITED and types as having their
7568 sized gimplified. We use this to indicate all variable sizes and
7569 positions in global types may not be shared by any subprogram. */
7571 void
7572 mark_visited (tree t)
7574 walk_tree (&t, mark_visited_r, NULL, NULL);
7577 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
7578 set its location to that of GNAT_NODE if present, but with column info
7579 cleared so that conditional branches generated as part of the cleanup
7580 code do not interfere with coverage analysis tools. */
7582 static void
7583 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
7585 if (Present (gnat_node))
7586 set_expr_location_from_node1 (gnu_cleanup, gnat_node, true);
7587 append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
7590 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
7592 void
7593 set_block_for_group (tree gnu_block)
7595 gcc_assert (!current_stmt_group->block);
7596 current_stmt_group->block = gnu_block;
7599 /* Return code corresponding to the current code group. It is normally
7600 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
7601 BLOCK or cleanups were set. */
7603 tree
7604 end_stmt_group (void)
7606 struct stmt_group *group = current_stmt_group;
7607 tree gnu_retval = group->stmt_list;
7609 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
7610 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
7611 make a BIND_EXPR. Note that we nest in that because the cleanup may
7612 reference variables in the block. */
7613 if (gnu_retval == NULL_TREE)
7614 gnu_retval = alloc_stmt_list ();
7616 if (group->cleanups)
7617 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
7618 group->cleanups);
7620 if (current_stmt_group->block)
7621 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
7622 gnu_retval, group->block);
7624 /* Remove this group from the stack and add it to the free list. */
7625 current_stmt_group = group->previous;
7626 group->previous = stmt_group_free_list;
7627 stmt_group_free_list = group;
7629 return gnu_retval;
7632 /* Return whether the current statement group may fall through. */
7634 static inline bool
7635 stmt_group_may_fallthru (void)
7637 if (current_stmt_group->stmt_list)
7638 return block_may_fallthru (current_stmt_group->stmt_list);
7639 else
7640 return true;
7643 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
7644 statements.*/
7646 static void
7647 add_stmt_list (List_Id gnat_list)
7649 Node_Id gnat_node;
7651 if (Present (gnat_list))
7652 for (gnat_node = First (gnat_list); Present (gnat_node);
7653 gnat_node = Next (gnat_node))
7654 add_stmt (gnat_to_gnu (gnat_node));
7657 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
7658 If BINDING_P is true, push and pop a binding level around the list. */
7660 static tree
7661 build_stmt_group (List_Id gnat_list, bool binding_p)
7663 start_stmt_group ();
7664 if (binding_p)
7665 gnat_pushlevel ();
7667 add_stmt_list (gnat_list);
7668 if (binding_p)
7669 gnat_poplevel ();
7671 return end_stmt_group ();
7674 /* Generate GIMPLE in place for the expression at *EXPR_P. */
7677 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
7678 gimple_seq *post_p ATTRIBUTE_UNUSED)
7680 tree expr = *expr_p;
7681 tree op;
7683 if (IS_ADA_STMT (expr))
7684 return gnat_gimplify_stmt (expr_p);
7686 switch (TREE_CODE (expr))
7688 case NULL_EXPR:
7689 /* If this is for a scalar, just make a VAR_DECL for it. If for
7690 an aggregate, get a null pointer of the appropriate type and
7691 dereference it. */
7692 if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
7693 *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
7694 convert (build_pointer_type (TREE_TYPE (expr)),
7695 integer_zero_node));
7696 else
7698 *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
7699 TREE_NO_WARNING (*expr_p) = 1;
7702 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
7703 return GS_OK;
7705 case UNCONSTRAINED_ARRAY_REF:
7706 /* We should only do this if we are just elaborating for side-effects,
7707 but we can't know that yet. */
7708 *expr_p = TREE_OPERAND (*expr_p, 0);
7709 return GS_OK;
7711 case ADDR_EXPR:
7712 op = TREE_OPERAND (expr, 0);
7714 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
7715 is put into static memory. We know that it's going to be read-only
7716 given the semantics we have and it must be in static memory when the
7717 reference is in an elaboration procedure. */
7718 if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
7720 tree addr = build_fold_addr_expr (tree_output_constant_def (op));
7721 *expr_p = fold_convert (TREE_TYPE (expr), addr);
7722 return GS_ALL_DONE;
7725 return GS_UNHANDLED;
7727 case VIEW_CONVERT_EXPR:
7728 op = TREE_OPERAND (expr, 0);
7730 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
7731 type to a scalar one, explicitly create the local temporary. That's
7732 required if the type is passed by reference. */
7733 if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
7734 && AGGREGATE_TYPE_P (TREE_TYPE (op))
7735 && !AGGREGATE_TYPE_P (TREE_TYPE (expr)))
7737 tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
7738 gimple_add_tmp_var (new_var);
7740 mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
7741 gimplify_and_add (mod, pre_p);
7743 TREE_OPERAND (expr, 0) = new_var;
7744 return GS_OK;
7747 return GS_UNHANDLED;
7749 case DECL_EXPR:
7750 op = DECL_EXPR_DECL (expr);
7752 /* The expressions for the RM bounds must be gimplified to ensure that
7753 they are properly elaborated. See gimplify_decl_expr. */
7754 if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
7755 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
7756 switch (TREE_CODE (TREE_TYPE (op)))
7758 case INTEGER_TYPE:
7759 case ENUMERAL_TYPE:
7760 case BOOLEAN_TYPE:
7761 case REAL_TYPE:
7763 tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
7765 val = TYPE_RM_MIN_VALUE (type);
7766 if (val)
7768 gimplify_one_sizepos (&val, pre_p);
7769 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
7770 SET_TYPE_RM_MIN_VALUE (t, val);
7773 val = TYPE_RM_MAX_VALUE (type);
7774 if (val)
7776 gimplify_one_sizepos (&val, pre_p);
7777 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
7778 SET_TYPE_RM_MAX_VALUE (t, val);
7782 break;
7784 default:
7785 break;
7788 /* ... fall through ... */
7790 default:
7791 return GS_UNHANDLED;
7795 /* Generate GIMPLE in place for the statement at *STMT_P. */
7797 static enum gimplify_status
7798 gnat_gimplify_stmt (tree *stmt_p)
7800 tree stmt = *stmt_p;
7802 switch (TREE_CODE (stmt))
7804 case STMT_STMT:
7805 *stmt_p = STMT_STMT_STMT (stmt);
7806 return GS_OK;
7808 case LOOP_STMT:
7810 tree gnu_start_label = create_artificial_label (input_location);
7811 tree gnu_cond = LOOP_STMT_COND (stmt);
7812 tree gnu_update = LOOP_STMT_UPDATE (stmt);
7813 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
7815 /* Build the condition expression from the test, if any. */
7816 if (gnu_cond)
7818 /* Deal with the optimization hints. */
7819 if (LOOP_STMT_IVDEP (stmt))
7820 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
7821 build_int_cst (integer_type_node,
7822 annot_expr_ivdep_kind));
7823 if (LOOP_STMT_NO_VECTOR (stmt))
7824 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
7825 build_int_cst (integer_type_node,
7826 annot_expr_no_vector_kind));
7827 if (LOOP_STMT_VECTOR (stmt))
7828 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
7829 build_int_cst (integer_type_node,
7830 annot_expr_vector_kind));
7832 gnu_cond
7833 = build3 (COND_EXPR, void_type_node, gnu_cond, NULL_TREE,
7834 build1 (GOTO_EXPR, void_type_node, gnu_end_label));
7837 /* Set to emit the statements of the loop. */
7838 *stmt_p = NULL_TREE;
7840 /* We first emit the start label and then a conditional jump to the
7841 end label if there's a top condition, then the update if it's at
7842 the top, then the body of the loop, then a conditional jump to
7843 the end label if there's a bottom condition, then the update if
7844 it's at the bottom, and finally a jump to the start label and the
7845 definition of the end label. */
7846 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
7847 gnu_start_label),
7848 stmt_p);
7850 if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
7851 append_to_statement_list (gnu_cond, stmt_p);
7853 if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
7854 append_to_statement_list (gnu_update, stmt_p);
7856 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
7858 if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
7859 append_to_statement_list (gnu_cond, stmt_p);
7861 if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
7862 append_to_statement_list (gnu_update, stmt_p);
7864 tree t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
7865 SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
7866 append_to_statement_list (t, stmt_p);
7868 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
7869 gnu_end_label),
7870 stmt_p);
7871 return GS_OK;
7874 case EXIT_STMT:
7875 /* Build a statement to jump to the corresponding end label, then
7876 see if it needs to be conditional. */
7877 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
7878 if (EXIT_STMT_COND (stmt))
7879 *stmt_p = build3 (COND_EXPR, void_type_node,
7880 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
7881 return GS_OK;
7883 default:
7884 gcc_unreachable ();
7888 /* Force references to each of the entities in packages withed by GNAT_NODE.
7889 Operate recursively but check that we aren't elaborating something more
7890 than once.
7892 This routine is exclusively called in type_annotate mode, to compute DDA
7893 information for types in withed units, for ASIS use. */
7895 static void
7896 elaborate_all_entities (Node_Id gnat_node)
7898 Entity_Id gnat_with_clause, gnat_entity;
7900 /* Process each unit only once. As we trace the context of all relevant
7901 units transitively, including generic bodies, we may encounter the
7902 same generic unit repeatedly. */
7903 if (!present_gnu_tree (gnat_node))
7904 save_gnu_tree (gnat_node, integer_zero_node, true);
7906 /* Save entities in all context units. A body may have an implicit_with
7907 on its own spec, if the context includes a child unit, so don't save
7908 the spec twice. */
7909 for (gnat_with_clause = First (Context_Items (gnat_node));
7910 Present (gnat_with_clause);
7911 gnat_with_clause = Next (gnat_with_clause))
7912 if (Nkind (gnat_with_clause) == N_With_Clause
7913 && !present_gnu_tree (Library_Unit (gnat_with_clause))
7914 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
7916 elaborate_all_entities (Library_Unit (gnat_with_clause));
7918 if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
7920 for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
7921 Present (gnat_entity);
7922 gnat_entity = Next_Entity (gnat_entity))
7923 if (Is_Public (gnat_entity)
7924 && Convention (gnat_entity) != Convention_Intrinsic
7925 && Ekind (gnat_entity) != E_Package
7926 && Ekind (gnat_entity) != E_Package_Body
7927 && Ekind (gnat_entity) != E_Operator
7928 && !(IN (Ekind (gnat_entity), Type_Kind)
7929 && !Is_Frozen (gnat_entity))
7930 && !((Ekind (gnat_entity) == E_Procedure
7931 || Ekind (gnat_entity) == E_Function)
7932 && Is_Intrinsic_Subprogram (gnat_entity))
7933 && !IN (Ekind (gnat_entity), Named_Kind)
7934 && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
7935 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
7937 else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
7939 Node_Id gnat_body
7940 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
7942 /* Retrieve compilation unit node of generic body. */
7943 while (Present (gnat_body)
7944 && Nkind (gnat_body) != N_Compilation_Unit)
7945 gnat_body = Parent (gnat_body);
7947 /* If body is available, elaborate its context. */
7948 if (Present (gnat_body))
7949 elaborate_all_entities (gnat_body);
7953 if (Nkind (Unit (gnat_node)) == N_Package_Body)
7954 elaborate_all_entities (Library_Unit (gnat_node));
7957 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
7959 static void
7960 process_freeze_entity (Node_Id gnat_node)
7962 const Entity_Id gnat_entity = Entity (gnat_node);
7963 const Entity_Kind kind = Ekind (gnat_entity);
7964 tree gnu_old, gnu_new;
7966 /* If this is a package, we need to generate code for the package. */
7967 if (kind == E_Package)
7969 insert_code_for
7970 (Parent (Corresponding_Body
7971 (Parent (Declaration_Node (gnat_entity)))));
7972 return;
7975 /* Don't do anything for class-wide types as they are always transformed
7976 into their root type. */
7977 if (kind == E_Class_Wide_Type)
7978 return;
7980 /* Check for an old definition. This freeze node might be for an Itype. */
7981 gnu_old
7982 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
7984 /* If this entity has an address representation clause, GNU_OLD is the
7985 address, so discard it here. */
7986 if (Present (Address_Clause (gnat_entity)))
7987 gnu_old = NULL_TREE;
7989 /* Don't do anything for subprograms that may have been elaborated before
7990 their freeze nodes. This can happen, for example, because of an inner
7991 call in an instance body or because of previous compilation of a spec
7992 for inlining purposes. */
7993 if (gnu_old
7994 && ((TREE_CODE (gnu_old) == FUNCTION_DECL
7995 && (kind == E_Function || kind == E_Procedure))
7996 || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
7997 && kind == E_Subprogram_Type)))
7998 return;
8000 /* If we have a non-dummy type old tree, we have nothing to do, except
8001 aborting if this is the public view of a private type whose full view was
8002 not delayed, as this node was never delayed as it should have been. We
8003 let this happen for concurrent types and their Corresponding_Record_Type,
8004 however, because each might legitimately be elaborated before its own
8005 freeze node, e.g. while processing the other. */
8006 if (gnu_old
8007 && !(TREE_CODE (gnu_old) == TYPE_DECL
8008 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
8010 gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
8011 && Present (Full_View (gnat_entity))
8012 && No (Freeze_Node (Full_View (gnat_entity))))
8013 || Is_Concurrent_Type (gnat_entity)
8014 || (IN (kind, Record_Kind)
8015 && Is_Concurrent_Record_Type (gnat_entity)));
8016 return;
8019 /* Reset the saved tree, if any, and elaborate the object or type for real.
8020 If there is a full view, elaborate it and use the result. And, if this
8021 is the root type of a class-wide type, reuse it for the latter. */
8022 if (gnu_old)
8024 save_gnu_tree (gnat_entity, NULL_TREE, false);
8025 if (IN (kind, Incomplete_Or_Private_Kind)
8026 && Present (Full_View (gnat_entity))
8027 && present_gnu_tree (Full_View (gnat_entity)))
8028 save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
8029 if (IN (kind, Type_Kind)
8030 && Present (Class_Wide_Type (gnat_entity))
8031 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
8032 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
8035 if (IN (kind, Incomplete_Or_Private_Kind)
8036 && Present (Full_View (gnat_entity)))
8038 gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
8040 /* Propagate back-annotations from full view to partial view. */
8041 if (Unknown_Alignment (gnat_entity))
8042 Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
8044 if (Unknown_Esize (gnat_entity))
8045 Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
8047 if (Unknown_RM_Size (gnat_entity))
8048 Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
8050 /* The above call may have defined this entity (the simplest example
8051 of this is when we have a private enumeral type since the bounds
8052 will have the public view). */
8053 if (!present_gnu_tree (gnat_entity))
8054 save_gnu_tree (gnat_entity, gnu_new, false);
8056 else
8058 tree gnu_init
8059 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
8060 && present_gnu_tree (Declaration_Node (gnat_entity)))
8061 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
8063 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
8066 if (IN (kind, Type_Kind)
8067 && Present (Class_Wide_Type (gnat_entity))
8068 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
8069 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
8071 /* If we have an old type and we've made pointers to this type, update those
8072 pointers. If this is a Taft amendment type in the main unit, we need to
8073 mark the type as used since other units referencing it don't see the full
8074 declaration and, therefore, cannot mark it as used themselves. */
8075 if (gnu_old)
8077 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
8078 TREE_TYPE (gnu_new));
8079 if (DECL_TAFT_TYPE_P (gnu_old))
8080 used_types_insert (TREE_TYPE (gnu_new));
8084 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
8085 We make two passes, one to elaborate anything other than bodies (but
8086 we declare a function if there was no spec). The second pass
8087 elaborates the bodies.
8089 GNAT_END_LIST gives the element in the list past the end. Normally,
8090 this is Empty, but can be First_Real_Statement for a
8091 Handled_Sequence_Of_Statements.
8093 We make a complete pass through both lists if PASS1P is true, then make
8094 the second pass over both lists if PASS2P is true. The lists usually
8095 correspond to the public and private parts of a package. */
8097 static void
8098 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
8099 Node_Id gnat_end_list, bool pass1p, bool pass2p)
8101 List_Id gnat_decl_array[2];
8102 Node_Id gnat_decl;
8103 int i;
8105 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
8107 if (pass1p)
8108 for (i = 0; i <= 1; i++)
8109 if (Present (gnat_decl_array[i]))
8110 for (gnat_decl = First (gnat_decl_array[i]);
8111 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
8113 /* For package specs, we recurse inside the declarations,
8114 thus taking the two pass approach inside the boundary. */
8115 if (Nkind (gnat_decl) == N_Package_Declaration
8116 && (Nkind (Specification (gnat_decl)
8117 == N_Package_Specification)))
8118 process_decls (Visible_Declarations (Specification (gnat_decl)),
8119 Private_Declarations (Specification (gnat_decl)),
8120 Empty, true, false);
8122 /* Similarly for any declarations in the actions of a
8123 freeze node. */
8124 else if (Nkind (gnat_decl) == N_Freeze_Entity)
8126 process_freeze_entity (gnat_decl);
8127 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
8130 /* Package bodies with freeze nodes get their elaboration deferred
8131 until the freeze node, but the code must be placed in the right
8132 place, so record the code position now. */
8133 else if (Nkind (gnat_decl) == N_Package_Body
8134 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
8135 record_code_position (gnat_decl);
8137 else if (Nkind (gnat_decl) == N_Package_Body_Stub
8138 && Present (Library_Unit (gnat_decl))
8139 && Present (Freeze_Node
8140 (Corresponding_Spec
8141 (Proper_Body (Unit
8142 (Library_Unit (gnat_decl)))))))
8143 record_code_position
8144 (Proper_Body (Unit (Library_Unit (gnat_decl))));
8146 /* We defer most subprogram bodies to the second pass. */
8147 else if (Nkind (gnat_decl) == N_Subprogram_Body)
8149 if (Acts_As_Spec (gnat_decl))
8151 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
8153 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
8154 && Ekind (gnat_subprog_id) != E_Generic_Function)
8155 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
8159 /* For bodies and stubs that act as their own specs, the entity
8160 itself must be elaborated in the first pass, because it may
8161 be used in other declarations. */
8162 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
8164 Node_Id gnat_subprog_id
8165 = Defining_Entity (Specification (gnat_decl));
8167 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
8168 && Ekind (gnat_subprog_id) != E_Generic_Procedure
8169 && Ekind (gnat_subprog_id) != E_Generic_Function)
8170 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
8173 /* Concurrent stubs stand for the corresponding subprogram bodies,
8174 which are deferred like other bodies. */
8175 else if (Nkind (gnat_decl) == N_Task_Body_Stub
8176 || Nkind (gnat_decl) == N_Protected_Body_Stub)
8179 else
8180 add_stmt (gnat_to_gnu (gnat_decl));
8183 /* Here we elaborate everything we deferred above except for package bodies,
8184 which are elaborated at their freeze nodes. Note that we must also
8185 go inside things (package specs and freeze nodes) the first pass did. */
8186 if (pass2p)
8187 for (i = 0; i <= 1; i++)
8188 if (Present (gnat_decl_array[i]))
8189 for (gnat_decl = First (gnat_decl_array[i]);
8190 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
8192 if (Nkind (gnat_decl) == N_Subprogram_Body
8193 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
8194 || Nkind (gnat_decl) == N_Task_Body_Stub
8195 || Nkind (gnat_decl) == N_Protected_Body_Stub)
8196 add_stmt (gnat_to_gnu (gnat_decl));
8198 else if (Nkind (gnat_decl) == N_Package_Declaration
8199 && (Nkind (Specification (gnat_decl)
8200 == N_Package_Specification)))
8201 process_decls (Visible_Declarations (Specification (gnat_decl)),
8202 Private_Declarations (Specification (gnat_decl)),
8203 Empty, false, true);
8205 else if (Nkind (gnat_decl) == N_Freeze_Entity)
8206 process_decls (Actions (gnat_decl), Empty, Empty, false, true);
8210 /* Make a unary operation of kind CODE using build_unary_op, but guard
8211 the operation by an overflow check. CODE can be one of NEGATE_EXPR
8212 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
8213 the operation is to be performed in that type. GNAT_NODE is the gnat
8214 node conveying the source location for which the error should be
8215 signaled. */
8217 static tree
8218 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
8219 Node_Id gnat_node)
8221 gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
8223 operand = gnat_protect_expr (operand);
8225 return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
8226 operand, TYPE_MIN_VALUE (gnu_type)),
8227 build_unary_op (code, gnu_type, operand),
8228 CE_Overflow_Check_Failed, gnat_node);
8231 /* Make a binary operation of kind CODE using build_binary_op, but guard
8232 the operation by an overflow check. CODE can be one of PLUS_EXPR,
8233 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
8234 Usually the operation is to be performed in that type. GNAT_NODE is
8235 the GNAT node conveying the source location for which the error should
8236 be signaled. */
8238 static tree
8239 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
8240 tree right, Node_Id gnat_node)
8242 tree lhs = gnat_protect_expr (left);
8243 tree rhs = gnat_protect_expr (right);
8244 tree type_max = TYPE_MAX_VALUE (gnu_type);
8245 tree type_min = TYPE_MIN_VALUE (gnu_type);
8246 tree gnu_expr;
8247 tree tmp1, tmp2;
8248 tree zero = convert (gnu_type, integer_zero_node);
8249 tree rhs_lt_zero;
8250 tree check_pos;
8251 tree check_neg;
8252 tree check;
8253 int precision = TYPE_PRECISION (gnu_type);
8255 gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */
8257 /* Prefer a constant or known-positive rhs to simplify checks. */
8258 if (!TREE_CONSTANT (rhs)
8259 && commutative_tree_code (code)
8260 && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs)
8261 && tree_expr_nonnegative_p (lhs))))
8263 tree tmp = lhs;
8264 lhs = rhs;
8265 rhs = tmp;
8268 rhs_lt_zero = tree_expr_nonnegative_p (rhs)
8269 ? boolean_false_node
8270 : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
8272 /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
8274 /* Try a few strategies that may be cheaper than the general
8275 code at the end of the function, if the rhs is not known.
8276 The strategies are:
8277 - Call library function for 64-bit multiplication (complex)
8278 - Widen, if input arguments are sufficiently small
8279 - Determine overflow using wrapped result for addition/subtraction. */
8281 if (!TREE_CONSTANT (rhs))
8283 /* Even for add/subtract double size to get another base type. */
8284 int needed_precision = precision * 2;
8286 if (code == MULT_EXPR && precision == 64)
8288 tree int_64 = gnat_type_for_size (64, 0);
8290 return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
8291 convert (int_64, lhs),
8292 convert (int_64, rhs)));
8295 else if (needed_precision <= BITS_PER_WORD
8296 || (code == MULT_EXPR
8297 && needed_precision <= LONG_LONG_TYPE_SIZE))
8299 tree wide_type = gnat_type_for_size (needed_precision, 0);
8301 tree wide_result = build_binary_op (code, wide_type,
8302 convert (wide_type, lhs),
8303 convert (wide_type, rhs));
8305 tree check = build_binary_op
8306 (TRUTH_ORIF_EXPR, boolean_type_node,
8307 build_binary_op (LT_EXPR, boolean_type_node, wide_result,
8308 convert (wide_type, type_min)),
8309 build_binary_op (GT_EXPR, boolean_type_node, wide_result,
8310 convert (wide_type, type_max)));
8312 tree result = convert (gnu_type, wide_result);
8314 return
8315 emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
8318 else if (code == PLUS_EXPR || code == MINUS_EXPR)
8320 tree unsigned_type = gnat_type_for_size (precision, 1);
8321 tree wrapped_expr = convert
8322 (gnu_type, build_binary_op (code, unsigned_type,
8323 convert (unsigned_type, lhs),
8324 convert (unsigned_type, rhs)));
8326 tree result = convert
8327 (gnu_type, build_binary_op (code, gnu_type, lhs, rhs));
8329 /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
8330 or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */
8331 tree check = build_binary_op
8332 (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
8333 build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
8334 boolean_type_node, wrapped_expr, lhs));
8336 return
8337 emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
8341 switch (code)
8343 case PLUS_EXPR:
8344 /* When rhs >= 0, overflow when lhs > type_max - rhs. */
8345 check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
8346 build_binary_op (MINUS_EXPR, gnu_type,
8347 type_max, rhs)),
8349 /* When rhs < 0, overflow when lhs < type_min - rhs. */
8350 check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
8351 build_binary_op (MINUS_EXPR, gnu_type,
8352 type_min, rhs));
8353 break;
8355 case MINUS_EXPR:
8356 /* When rhs >= 0, overflow when lhs < type_min + rhs. */
8357 check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
8358 build_binary_op (PLUS_EXPR, gnu_type,
8359 type_min, rhs)),
8361 /* When rhs < 0, overflow when lhs > type_max + rhs. */
8362 check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
8363 build_binary_op (PLUS_EXPR, gnu_type,
8364 type_max, rhs));
8365 break;
8367 case MULT_EXPR:
8368 /* The check here is designed to be efficient if the rhs is constant,
8369 but it will work for any rhs by using integer division.
8370 Four different check expressions determine whether X * C overflows,
8371 depending on C.
8372 C == 0 => false
8373 C > 0 => X > type_max / C || X < type_min / C
8374 C == -1 => X == type_min
8375 C < -1 => X > type_min / C || X < type_max / C */
8377 tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
8378 tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
8380 check_pos
8381 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
8382 build_binary_op (NE_EXPR, boolean_type_node, zero,
8383 rhs),
8384 build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8385 build_binary_op (GT_EXPR,
8386 boolean_type_node,
8387 lhs, tmp1),
8388 build_binary_op (LT_EXPR,
8389 boolean_type_node,
8390 lhs, tmp2)));
8392 check_neg
8393 = fold_build3 (COND_EXPR, boolean_type_node,
8394 build_binary_op (EQ_EXPR, boolean_type_node, rhs,
8395 build_int_cst (gnu_type, -1)),
8396 build_binary_op (EQ_EXPR, boolean_type_node, lhs,
8397 type_min),
8398 build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8399 build_binary_op (GT_EXPR,
8400 boolean_type_node,
8401 lhs, tmp2),
8402 build_binary_op (LT_EXPR,
8403 boolean_type_node,
8404 lhs, tmp1)));
8405 break;
8407 default:
8408 gcc_unreachable();
8411 gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
8413 /* If we can fold the expression to a constant, just return it.
8414 The caller will deal with overflow, no need to generate a check. */
8415 if (TREE_CONSTANT (gnu_expr))
8416 return gnu_expr;
8418 check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
8419 check_pos);
8421 return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
8424 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
8425 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
8426 which we have to check. GNAT_NODE is the GNAT node conveying the source
8427 location for which the error should be signaled. */
8429 static tree
8430 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
8432 tree gnu_range_type = get_unpadded_type (gnat_range_type);
8433 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
8435 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
8436 This can for example happen when translating 'Val or 'Value. */
8437 if (gnu_compare_type == gnu_range_type)
8438 return gnu_expr;
8440 /* Range checks can only be applied to types with ranges. */
8441 gcc_assert (INTEGRAL_TYPE_P (gnu_range_type)
8442 || SCALAR_FLOAT_TYPE_P (gnu_range_type));
8444 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
8445 we can't do anything since we might be truncating the bounds. No
8446 check is needed in this case. */
8447 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
8448 && (TYPE_PRECISION (gnu_compare_type)
8449 < TYPE_PRECISION (get_base_type (gnu_range_type))))
8450 return gnu_expr;
8452 /* Checked expressions must be evaluated only once. */
8453 gnu_expr = gnat_protect_expr (gnu_expr);
8455 /* Note that the form of the check is
8456 (not (expr >= lo)) or (not (expr <= hi))
8457 the reason for this slightly convoluted form is that NaNs
8458 are not considered to be in range in the float case. */
8459 return emit_check
8460 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8461 invert_truthvalue
8462 (build_binary_op (GE_EXPR, boolean_type_node,
8463 convert (gnu_compare_type, gnu_expr),
8464 convert (gnu_compare_type,
8465 TYPE_MIN_VALUE
8466 (gnu_range_type)))),
8467 invert_truthvalue
8468 (build_binary_op (LE_EXPR, boolean_type_node,
8469 convert (gnu_compare_type, gnu_expr),
8470 convert (gnu_compare_type,
8471 TYPE_MAX_VALUE
8472 (gnu_range_type))))),
8473 gnu_expr, CE_Range_Check_Failed, gnat_node);
8476 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which
8477 we are about to index, GNU_EXPR is the index expression to be checked,
8478 GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
8479 has to be checked. Note that for index checking we cannot simply use the
8480 emit_range_check function (although very similar code needs to be generated
8481 in both cases) since for index checking the array type against which we are
8482 checking the indices may be unconstrained and consequently we need to get
8483 the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
8484 The place where we need to do that is in subprograms having unconstrained
8485 array formal parameters. GNAT_NODE is the GNAT node conveying the source
8486 location for which the error should be signaled. */
8488 static tree
8489 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
8490 tree gnu_high, Node_Id gnat_node)
8492 tree gnu_expr_check;
8494 /* Checked expressions must be evaluated only once. */
8495 gnu_expr = gnat_protect_expr (gnu_expr);
8497 /* Must do this computation in the base type in case the expression's
8498 type is an unsigned subtypes. */
8499 gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
8501 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
8502 the object we are handling. */
8503 gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
8504 gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
8506 return emit_check
8507 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
8508 build_binary_op (LT_EXPR, boolean_type_node,
8509 gnu_expr_check,
8510 convert (TREE_TYPE (gnu_expr_check),
8511 gnu_low)),
8512 build_binary_op (GT_EXPR, boolean_type_node,
8513 gnu_expr_check,
8514 convert (TREE_TYPE (gnu_expr_check),
8515 gnu_high))),
8516 gnu_expr, CE_Index_Check_Failed, gnat_node);
8519 /* GNU_COND contains the condition corresponding to an access, discriminant or
8520 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
8521 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
8522 REASON is the code that says why the exception was raised. GNAT_NODE is
8523 the GNAT node conveying the source location for which the error should be
8524 signaled. */
8526 static tree
8527 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
8529 tree gnu_call
8530 = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
8531 tree gnu_result
8532 = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
8533 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
8534 convert (TREE_TYPE (gnu_expr), integer_zero_node)),
8535 gnu_expr);
8537 /* GNU_RESULT has side effects if and only if GNU_EXPR has:
8538 we don't need to evaluate it just for the check. */
8539 TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr);
8541 return gnu_result;
8544 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
8545 checks if OVERFLOW_P is true and range checks if RANGE_P is true.
8546 GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
8547 float to integer conversion with truncation; otherwise round.
8548 GNAT_NODE is the GNAT node conveying the source location for which the
8549 error should be signaled. */
8551 static tree
8552 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
8553 bool rangep, bool truncatep, Node_Id gnat_node)
8555 tree gnu_type = get_unpadded_type (gnat_type);
8556 tree gnu_in_type = TREE_TYPE (gnu_expr);
8557 tree gnu_in_basetype = get_base_type (gnu_in_type);
8558 tree gnu_base_type = get_base_type (gnu_type);
8559 tree gnu_result = gnu_expr;
8561 /* If we are not doing any checks, the output is an integral type, and
8562 the input is not a floating type, just do the conversion. This
8563 shortcut is required to avoid problems with packed array types
8564 and simplifies code in all cases anyway. */
8565 if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
8566 && !FLOAT_TYPE_P (gnu_in_type))
8567 return convert (gnu_type, gnu_expr);
8569 /* First convert the expression to its base type. This
8570 will never generate code, but makes the tests below much simpler.
8571 But don't do this if converting from an integer type to an unconstrained
8572 array type since then we need to get the bounds from the original
8573 (unpacked) type. */
8574 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
8575 gnu_result = convert (gnu_in_basetype, gnu_result);
8577 /* If overflow checks are requested, we need to be sure the result will
8578 fit in the output base type. But don't do this if the input
8579 is integer and the output floating-point. */
8580 if (overflowp
8581 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
8583 /* Ensure GNU_EXPR only gets evaluated once. */
8584 tree gnu_input = gnat_protect_expr (gnu_result);
8585 tree gnu_cond = boolean_false_node;
8586 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
8587 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
8588 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
8589 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
8591 /* Convert the lower bounds to signed types, so we're sure we're
8592 comparing them properly. Likewise, convert the upper bounds
8593 to unsigned types. */
8594 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
8595 gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
8597 if (INTEGRAL_TYPE_P (gnu_in_basetype)
8598 && !TYPE_UNSIGNED (gnu_in_basetype))
8599 gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
8601 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
8602 gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
8604 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
8605 gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
8607 /* Check each bound separately and only if the result bound
8608 is tighter than the bound on the input type. Note that all the
8609 types are base types, so the bounds must be constant. Also,
8610 the comparison is done in the base type of the input, which
8611 always has the proper signedness. First check for input
8612 integer (which means output integer), output float (which means
8613 both float), or mixed, in which case we always compare.
8614 Note that we have to do the comparison which would *fail* in the
8615 case of an error since if it's an FP comparison and one of the
8616 values is a NaN or Inf, the comparison will fail. */
8617 if (INTEGRAL_TYPE_P (gnu_in_basetype)
8618 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
8619 : (FLOAT_TYPE_P (gnu_base_type)
8620 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
8621 TREE_REAL_CST (gnu_out_lb))
8622 : 1))
8623 gnu_cond
8624 = invert_truthvalue
8625 (build_binary_op (GE_EXPR, boolean_type_node,
8626 gnu_input, convert (gnu_in_basetype,
8627 gnu_out_lb)));
8629 if (INTEGRAL_TYPE_P (gnu_in_basetype)
8630 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
8631 : (FLOAT_TYPE_P (gnu_base_type)
8632 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
8633 TREE_REAL_CST (gnu_in_lb))
8634 : 1))
8635 gnu_cond
8636 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
8637 invert_truthvalue
8638 (build_binary_op (LE_EXPR, boolean_type_node,
8639 gnu_input,
8640 convert (gnu_in_basetype,
8641 gnu_out_ub))));
8643 if (!integer_zerop (gnu_cond))
8644 gnu_result = emit_check (gnu_cond, gnu_input,
8645 CE_Overflow_Check_Failed, gnat_node);
8648 /* Now convert to the result base type. If this is a non-truncating
8649 float-to-integer conversion, round. */
8650 if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
8651 && !truncatep)
8653 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
8654 tree gnu_conv, gnu_zero, gnu_comp, calc_type;
8655 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
8656 const struct real_format *fmt;
8658 /* The following calculations depend on proper rounding to even
8659 of each arithmetic operation. In order to prevent excess
8660 precision from spoiling this property, use the widest hardware
8661 floating-point type if FP_ARITH_MAY_WIDEN is true. */
8662 calc_type
8663 = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
8665 /* FIXME: Should not have padding in the first place. */
8666 if (TYPE_IS_PADDING_P (calc_type))
8667 calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
8669 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
8670 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
8671 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
8672 REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
8673 half_minus_pred_half);
8674 gnu_pred_half = build_real (calc_type, pred_half);
8676 /* If the input is strictly negative, subtract this value
8677 and otherwise add it from the input. For 0.5, the result
8678 is exactly between 1.0 and the machine number preceding 1.0
8679 (for calc_type). Since the last bit of 1.0 is even, this 0.5
8680 will round to 1.0, while all other number with an absolute
8681 value less than 0.5 round to 0.0. For larger numbers exactly
8682 halfway between integers, rounding will always be correct as
8683 the true mathematical result will be closer to the higher
8684 integer compared to the lower one. So, this constant works
8685 for all floating-point numbers.
8687 The reason to use the same constant with subtract/add instead
8688 of a positive and negative constant is to allow the comparison
8689 to be scheduled in parallel with retrieval of the constant and
8690 conversion of the input to the calc_type (if necessary). */
8692 gnu_zero = convert (gnu_in_basetype, integer_zero_node);
8693 gnu_result = gnat_protect_expr (gnu_result);
8694 gnu_conv = convert (calc_type, gnu_result);
8695 gnu_comp
8696 = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
8697 gnu_add_pred_half
8698 = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
8699 gnu_subtract_pred_half
8700 = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
8701 gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
8702 gnu_add_pred_half, gnu_subtract_pred_half);
8705 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
8706 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
8707 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
8708 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
8709 else
8710 gnu_result = convert (gnu_base_type, gnu_result);
8712 /* Finally, do the range check if requested. Note that if the result type
8713 is a modular type, the range check is actually an overflow check. */
8714 if (rangep
8715 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
8716 && TYPE_MODULAR_P (gnu_base_type) && overflowp))
8717 gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
8719 return convert (gnu_type, gnu_result);
8722 /* Return true if GNU_EXPR can be directly addressed. This is the case
8723 unless it is an expression involving computation or if it involves a
8724 reference to a bitfield or to an object not sufficiently aligned for
8725 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
8726 be directly addressed as an object of this type.
8728 *** Notes on addressability issues in the Ada compiler ***
8730 This predicate is necessary in order to bridge the gap between Gigi
8731 and the middle-end about addressability of GENERIC trees. A tree
8732 is said to be addressable if it can be directly addressed, i.e. if
8733 its address can be taken, is a multiple of the type's alignment on
8734 strict-alignment architectures and returns the first storage unit
8735 assigned to the object represented by the tree.
8737 In the C family of languages, everything is in practice addressable
8738 at the language level, except for bit-fields. This means that these
8739 compilers will take the address of any tree that doesn't represent
8740 a bit-field reference and expect the result to be the first storage
8741 unit assigned to the object. Even in cases where this will result
8742 in unaligned accesses at run time, nothing is supposed to be done
8743 and the program is considered as erroneous instead (see PR c/18287).
8745 The implicit assumptions made in the middle-end are in keeping with
8746 the C viewpoint described above:
8747 - the address of a bit-field reference is supposed to be never
8748 taken; the compiler (generally) will stop on such a construct,
8749 - any other tree is addressable if it is formally addressable,
8750 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
8752 In Ada, the viewpoint is the opposite one: nothing is addressable
8753 at the language level unless explicitly declared so. This means
8754 that the compiler will both make sure that the trees representing
8755 references to addressable ("aliased" in Ada parlance) objects are
8756 addressable and make no real attempts at ensuring that the trees
8757 representing references to non-addressable objects are addressable.
8759 In the first case, Ada is effectively equivalent to C and handing
8760 down the direct result of applying ADDR_EXPR to these trees to the
8761 middle-end works flawlessly. In the second case, Ada cannot afford
8762 to consider the program as erroneous if the address of trees that
8763 are not addressable is requested for technical reasons, unlike C;
8764 as a consequence, the Ada compiler must arrange for either making
8765 sure that this address is not requested in the middle-end or for
8766 compensating by inserting temporaries if it is requested in Gigi.
8768 The first goal can be achieved because the middle-end should not
8769 request the address of non-addressable trees on its own; the only
8770 exception is for the invocation of low-level block operations like
8771 memcpy, for which the addressability requirements are lower since
8772 the type's alignment can be disregarded. In practice, this means
8773 that Gigi must make sure that such operations cannot be applied to
8774 non-BLKmode bit-fields.
8776 The second goal is achieved by means of the addressable_p predicate,
8777 which computes whether a temporary must be inserted by Gigi when the
8778 address of a tree is requested; if so, the address of the temporary
8779 will be used in lieu of that of the original tree and some glue code
8780 generated to connect everything together. */
8782 static bool
8783 addressable_p (tree gnu_expr, tree gnu_type)
8785 /* For an integral type, the size of the actual type of the object may not
8786 be greater than that of the expected type, otherwise an indirect access
8787 in the latter type wouldn't correctly set all the bits of the object. */
8788 if (gnu_type
8789 && INTEGRAL_TYPE_P (gnu_type)
8790 && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
8791 return false;
8793 /* The size of the actual type of the object may not be smaller than that
8794 of the expected type, otherwise an indirect access in the latter type
8795 would be larger than the object. But only record types need to be
8796 considered in practice for this case. */
8797 if (gnu_type
8798 && TREE_CODE (gnu_type) == RECORD_TYPE
8799 && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
8800 return false;
8802 switch (TREE_CODE (gnu_expr))
8804 case VAR_DECL:
8805 case PARM_DECL:
8806 case FUNCTION_DECL:
8807 case RESULT_DECL:
8808 /* All DECLs are addressable: if they are in a register, we can force
8809 them to memory. */
8810 return true;
8812 case UNCONSTRAINED_ARRAY_REF:
8813 case INDIRECT_REF:
8814 /* Taking the address of a dereference yields the original pointer. */
8815 return true;
8817 case STRING_CST:
8818 case INTEGER_CST:
8819 /* Taking the address yields a pointer to the constant pool. */
8820 return true;
8822 case CONSTRUCTOR:
8823 /* Taking the address of a static constructor yields a pointer to the
8824 tree constant pool. */
8825 return TREE_STATIC (gnu_expr) ? true : false;
8827 case NULL_EXPR:
8828 case SAVE_EXPR:
8829 case CALL_EXPR:
8830 case PLUS_EXPR:
8831 case MINUS_EXPR:
8832 case BIT_IOR_EXPR:
8833 case BIT_XOR_EXPR:
8834 case BIT_AND_EXPR:
8835 case BIT_NOT_EXPR:
8836 /* All rvalues are deemed addressable since taking their address will
8837 force a temporary to be created by the middle-end. */
8838 return true;
8840 case COMPOUND_EXPR:
8841 /* The address of a compound expression is that of its 2nd operand. */
8842 return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
8844 case COND_EXPR:
8845 /* We accept &COND_EXPR as soon as both operands are addressable and
8846 expect the outcome to be the address of the selected operand. */
8847 return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
8848 && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
8850 case COMPONENT_REF:
8851 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
8852 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
8853 the field is sufficiently aligned, in case it is subject
8854 to a pragma Component_Alignment. But we don't need to
8855 check the alignment of the containing record, as it is
8856 guaranteed to be not smaller than that of its most
8857 aligned field that is not a bit-field. */
8858 && (!STRICT_ALIGNMENT
8859 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
8860 >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
8861 /* The field of a padding record is always addressable. */
8862 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
8863 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
8865 case ARRAY_REF: case ARRAY_RANGE_REF:
8866 case REALPART_EXPR: case IMAGPART_EXPR:
8867 case NOP_EXPR:
8868 return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
8870 case CONVERT_EXPR:
8871 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
8872 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
8874 case VIEW_CONVERT_EXPR:
8876 /* This is addressable if we can avoid a copy. */
8877 tree type = TREE_TYPE (gnu_expr);
8878 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
8879 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
8880 && (!STRICT_ALIGNMENT
8881 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
8882 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
8883 || ((TYPE_MODE (type) == BLKmode
8884 || TYPE_MODE (inner_type) == BLKmode)
8885 && (!STRICT_ALIGNMENT
8886 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
8887 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
8888 || TYPE_ALIGN_OK (type)
8889 || TYPE_ALIGN_OK (inner_type))))
8890 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
8893 default:
8894 return false;
8898 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
8899 a separate Freeze node exists, delay the bulk of the processing. Otherwise
8900 make a GCC type for GNAT_ENTITY and set up the correspondence. */
8902 void
8903 process_type (Entity_Id gnat_entity)
8905 tree gnu_old
8906 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
8907 tree gnu_new;
8909 /* If we are to delay elaboration of this type, just do any
8910 elaborations needed for expressions within the declaration and
8911 make a dummy type entry for this node and its Full_View (if
8912 any) in case something points to it. Don't do this if it
8913 has already been done (the only way that can happen is if
8914 the private completion is also delayed). */
8915 if (Present (Freeze_Node (gnat_entity))
8916 || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
8917 && Present (Full_View (gnat_entity))
8918 && Present (Freeze_Node (Full_View (gnat_entity)))
8919 && !present_gnu_tree (Full_View (gnat_entity))))
8921 elaborate_entity (gnat_entity);
8923 if (!gnu_old)
8925 tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
8926 save_gnu_tree (gnat_entity, gnu_decl, false);
8927 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
8928 && Present (Full_View (gnat_entity)))
8930 if (Has_Completion_In_Body (gnat_entity))
8931 DECL_TAFT_TYPE_P (gnu_decl) = 1;
8932 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
8936 return;
8939 /* If we saved away a dummy type for this node it means that this
8940 made the type that corresponds to the full type of an incomplete
8941 type. Clear that type for now and then update the type in the
8942 pointers. */
8943 if (gnu_old)
8945 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
8946 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
8948 save_gnu_tree (gnat_entity, NULL_TREE, false);
8951 /* Now fully elaborate the type. */
8952 gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
8953 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
8955 /* If we have an old type and we've made pointers to this type, update those
8956 pointers. If this is a Taft amendment type in the main unit, we need to
8957 mark the type as used since other units referencing it don't see the full
8958 declaration and, therefore, cannot mark it as used themselves. */
8959 if (gnu_old)
8961 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
8962 TREE_TYPE (gnu_new));
8963 if (DECL_TAFT_TYPE_P (gnu_old))
8964 used_types_insert (TREE_TYPE (gnu_new));
8967 /* If this is a record type corresponding to a task or protected type
8968 that is a completion of an incomplete type, perform a similar update
8969 on the type. ??? Including protected types here is a guess. */
8970 if (IN (Ekind (gnat_entity), Record_Kind)
8971 && Is_Concurrent_Record_Type (gnat_entity)
8972 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
8974 tree gnu_task_old
8975 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
8977 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
8978 NULL_TREE, false);
8979 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
8980 gnu_new, false);
8982 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
8983 TREE_TYPE (gnu_new));
8987 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
8988 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
8989 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
8991 static tree
8992 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
8994 tree gnu_list = NULL_TREE, gnu_result;
8996 /* We test for GNU_FIELD being empty in the case where a variant
8997 was the last thing since we don't take things off GNAT_ASSOC in
8998 that case. We check GNAT_ASSOC in case we have a variant, but it
8999 has no fields. */
9001 for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc))
9003 Node_Id gnat_field = First (Choices (gnat_assoc));
9004 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
9005 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
9007 /* The expander is supposed to put a single component selector name
9008 in every record component association. */
9009 gcc_assert (No (Next (gnat_field)));
9011 /* Ignore fields that have Corresponding_Discriminants since we'll
9012 be setting that field in the parent. */
9013 if (Present (Corresponding_Discriminant (Entity (gnat_field)))
9014 && Is_Tagged_Type (Scope (Entity (gnat_field))))
9015 continue;
9017 /* Also ignore discriminants of Unchecked_Unions. */
9018 if (Is_Unchecked_Union (gnat_entity)
9019 && Ekind (Entity (gnat_field)) == E_Discriminant)
9020 continue;
9022 /* Before assigning a value in an aggregate make sure range checks
9023 are done if required. Then convert to the type of the field. */
9024 if (Do_Range_Check (Expression (gnat_assoc)))
9025 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
9027 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
9029 /* Add the field and expression to the list. */
9030 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
9033 gnu_result = extract_values (gnu_list, gnu_type);
9035 #ifdef ENABLE_CHECKING
9036 /* Verify that every entry in GNU_LIST was used. */
9037 for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list))
9038 gcc_assert (TREE_ADDRESSABLE (gnu_list));
9039 #endif
9041 return gnu_result;
9044 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
9045 the first element of an array aggregate. It may itself be an aggregate.
9046 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
9047 GNAT_COMPONENT_TYPE is the type of the array component; it is needed
9048 for range checking. */
9050 static tree
9051 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
9052 Entity_Id gnat_component_type)
9054 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
9055 tree gnu_expr;
9056 vec<constructor_elt, va_gc> *gnu_expr_vec = NULL;
9058 for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
9060 /* If the expression is itself an array aggregate then first build the
9061 innermost constructor if it is part of our array (multi-dimensional
9062 case). */
9063 if (Nkind (gnat_expr) == N_Aggregate
9064 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
9065 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
9066 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
9067 TREE_TYPE (gnu_array_type),
9068 gnat_component_type);
9069 else
9071 gnu_expr = gnat_to_gnu (gnat_expr);
9073 /* Before assigning the element to the array, make sure it is
9074 in range. */
9075 if (Do_Range_Check (gnat_expr))
9076 gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
9079 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
9080 convert (TREE_TYPE (gnu_array_type), gnu_expr));
9082 gnu_index = int_const_binop (PLUS_EXPR, gnu_index,
9083 convert (TREE_TYPE (gnu_index),
9084 integer_one_node));
9087 return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
9090 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
9091 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
9092 of the associations that are from RECORD_TYPE. If we see an internal
9093 record, make a recursive call to fill it in as well. */
9095 static tree
9096 extract_values (tree values, tree record_type)
9098 tree field, tem;
9099 vec<constructor_elt, va_gc> *v = NULL;
9101 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
9103 tree value = 0;
9105 /* _Parent is an internal field, but may have values in the aggregate,
9106 so check for values first. */
9107 if ((tem = purpose_member (field, values)))
9109 value = TREE_VALUE (tem);
9110 TREE_ADDRESSABLE (tem) = 1;
9113 else if (DECL_INTERNAL_P (field))
9115 value = extract_values (values, TREE_TYPE (field));
9116 if (TREE_CODE (value) == CONSTRUCTOR
9117 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value)))
9118 value = 0;
9120 else
9121 /* If we have a record subtype, the names will match, but not the
9122 actual FIELD_DECLs. */
9123 for (tem = values; tem; tem = TREE_CHAIN (tem))
9124 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
9126 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
9127 TREE_ADDRESSABLE (tem) = 1;
9130 if (!value)
9131 continue;
9133 CONSTRUCTOR_APPEND_ELT (v, field, value);
9136 return gnat_build_constructor (record_type, v);
9139 /* Process a N_Validate_Unchecked_Conversion node. */
9141 static void
9142 validate_unchecked_conversion (Node_Id gnat_node)
9144 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
9145 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
9147 /* If the target is a pointer type, see if we are either converting from a
9148 non-pointer or from a pointer to a type with a different alias set and
9149 warn if so, unless the pointer has been marked to alias everything. */
9150 if (POINTER_TYPE_P (gnu_target_type)
9151 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type))
9153 tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
9154 ? TREE_TYPE (gnu_source_type)
9155 : NULL_TREE;
9156 tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
9157 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
9159 if (target_alias_set != 0
9160 && (!POINTER_TYPE_P (gnu_source_type)
9161 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
9162 target_alias_set)))
9164 post_error_ne ("?possible aliasing problem for type&",
9165 gnat_node, Target_Type (gnat_node));
9166 post_error ("\\?use -fno-strict-aliasing switch for references",
9167 gnat_node);
9168 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
9169 gnat_node, Target_Type (gnat_node));
9173 /* Likewise if the target is a fat pointer type, but we have no mechanism to
9174 mitigate the problem in this case, so we unconditionally warn. */
9175 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
9177 tree gnu_source_desig_type
9178 = TYPE_IS_FAT_POINTER_P (gnu_source_type)
9179 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
9180 : NULL_TREE;
9181 tree gnu_target_desig_type
9182 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
9183 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
9185 if (target_alias_set != 0
9186 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
9187 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
9188 target_alias_set)))
9190 post_error_ne ("?possible aliasing problem for type&",
9191 gnat_node, Target_Type (gnat_node));
9192 post_error ("\\?use -fno-strict-aliasing switch for references",
9193 gnat_node);
9198 /* EXP is to be treated as an array or record. Handle the cases when it is
9199 an access object and perform the required dereferences. */
9201 static tree
9202 maybe_implicit_deref (tree exp)
9204 /* If the type is a pointer, dereference it. */
9205 if (POINTER_TYPE_P (TREE_TYPE (exp))
9206 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
9207 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
9209 /* If we got a padded type, remove it too. */
9210 if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
9211 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
9213 return exp;
9216 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
9217 location and false if it doesn't. In the former case, set the Gigi global
9218 variable REF_FILENAME to the simple debug file name as given by sinput.
9219 If clear_column is true, set column information to 0. */
9221 static bool
9222 Sloc_to_locus1 (Source_Ptr Sloc, location_t *locus, bool clear_column)
9224 if (Sloc == No_Location)
9225 return false;
9227 if (Sloc <= Standard_Location)
9229 *locus = BUILTINS_LOCATION;
9230 return false;
9232 else
9234 Source_File_Index file = Get_Source_File_Index (Sloc);
9235 Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
9236 Column_Number column = (clear_column ? 0 : Get_Column_Number (Sloc));
9237 struct line_map *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1);
9239 /* We can have zero if pragma Source_Reference is in effect. */
9240 if (line < 1)
9241 line = 1;
9243 /* Translate the location. */
9244 *locus = linemap_position_for_line_and_column (map, line, column);
9247 ref_filename
9248 = IDENTIFIER_POINTER
9249 (get_identifier
9250 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
9252 return true;
9255 /* Similar to the above, not clearing the column information. */
9257 bool
9258 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
9260 return Sloc_to_locus1 (Sloc, locus, false);
9263 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
9264 don't do anything if it doesn't correspond to a source location. */
9266 static void
9267 set_expr_location_from_node1 (tree node, Node_Id gnat_node, bool clear_column)
9269 location_t locus;
9271 if (!Sloc_to_locus1 (Sloc (gnat_node), &locus, clear_column))
9272 return;
9274 SET_EXPR_LOCATION (node, locus);
9277 /* Similar to the above, not clearing the column information. */
9279 static void
9280 set_expr_location_from_node (tree node, Node_Id gnat_node)
9282 set_expr_location_from_node1 (node, gnat_node, false);
9285 /* More elaborate version of set_expr_location_from_node to be used in more
9286 general contexts, for example the result of the translation of a generic
9287 GNAT node. */
9289 static void
9290 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
9292 /* Set the location information on the node if it is a real expression.
9293 References can be reused for multiple GNAT nodes and they would get
9294 the location information of their last use. Also make sure not to
9295 overwrite an existing location as it is probably more precise. */
9297 switch (TREE_CODE (node))
9299 CASE_CONVERT:
9300 case NON_LVALUE_EXPR:
9301 break;
9303 case COMPOUND_EXPR:
9304 if (EXPR_P (TREE_OPERAND (node, 1)))
9305 set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
9307 /* ... fall through ... */
9309 default:
9310 if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
9312 set_expr_location_from_node (node, gnat_node);
9313 set_end_locus_from_node (node, gnat_node);
9315 break;
9319 /* Return a colon-separated list of encodings contained in encoded Ada
9320 name. */
9322 static const char *
9323 extract_encoding (const char *name)
9325 char *encoding = (char *) ggc_alloc_atomic (strlen (name));
9326 get_encoding (name, encoding);
9327 return encoding;
9330 /* Extract the Ada name from an encoded name. */
9332 static const char *
9333 decode_name (const char *name)
9335 char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60);
9336 __gnat_decode (name, decoded, 0);
9337 return decoded;
9340 /* Post an error message. MSG is the error message, properly annotated.
9341 NODE is the node at which to post the error and the node to use for the
9342 '&' substitution. */
9344 void
9345 post_error (const char *msg, Node_Id node)
9347 String_Template temp;
9348 String_Pointer sp;
9350 if (No (node))
9351 return;
9353 temp.Low_Bound = 1;
9354 temp.High_Bound = strlen (msg);
9355 sp.Bounds = &temp;
9356 sp.Array = msg;
9357 Error_Msg_N (sp, node);
9360 /* Similar to post_error, but NODE is the node at which to post the error and
9361 ENT is the node to use for the '&' substitution. */
9363 void
9364 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
9366 String_Template temp;
9367 String_Pointer sp;
9369 if (No (node))
9370 return;
9372 temp.Low_Bound = 1;
9373 temp.High_Bound = strlen (msg);
9374 sp.Bounds = &temp;
9375 sp.Array = msg;
9376 Error_Msg_NE (sp, node, ent);
9379 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
9381 void
9382 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
9384 Error_Msg_Uint_1 = UI_From_Int (num);
9385 post_error_ne (msg, node, ent);
9388 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
9389 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
9390 most sense. Return true if a sensible assignment was performed. */
9392 static bool
9393 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
9395 Node_Id gnat_end_label = Empty;
9396 location_t end_locus;
9398 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
9399 end_locus when there is one. We consider only GNAT nodes with a possible
9400 End_Label attached. If the End_Label actually was unassigned, fallback
9401 on the original node. We'd better assign an explicit sloc associated with
9402 the outer construct in any case. */
9404 switch (Nkind (gnat_node))
9406 case N_Package_Body:
9407 case N_Subprogram_Body:
9408 case N_Block_Statement:
9409 gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
9410 break;
9412 case N_Package_Declaration:
9413 gnat_end_label = End_Label (Specification (gnat_node));
9414 break;
9416 default:
9417 return false;
9420 gnat_node = Present (gnat_end_label) ? gnat_end_label : gnat_node;
9422 /* Some expanded subprograms have neither an End_Label nor a Sloc
9423 attached. Notify that to callers. For a block statement with no
9424 End_Label, clear column information, so that the tree for a
9425 transient block does not receive the sloc of a source condition. */
9427 if (!Sloc_to_locus1 (Sloc (gnat_node), &end_locus,
9428 No (gnat_end_label) &&
9429 (Nkind (gnat_node) == N_Block_Statement)))
9430 return false;
9432 switch (TREE_CODE (gnu_node))
9434 case BIND_EXPR:
9435 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
9436 return true;
9438 case FUNCTION_DECL:
9439 DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
9440 return true;
9442 default:
9443 return false;
9447 /* Similar to post_error_ne, but T is a GCC tree representing the number to
9448 write. If T represents a constant, the text inside curly brackets in
9449 MSG will be output (presumably including a '^'). Otherwise it will not
9450 be output and the text inside square brackets will be output instead. */
9452 void
9453 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
9455 char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
9456 char start_yes, end_yes, start_no, end_no;
9457 const char *p;
9458 char *q;
9460 if (TREE_CODE (t) == INTEGER_CST)
9462 Error_Msg_Uint_1 = UI_From_gnu (t);
9463 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
9465 else
9466 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
9468 for (p = msg, q = new_msg; *p; p++)
9470 if (*p == start_yes)
9471 for (p++; *p != end_yes; p++)
9472 *q++ = *p;
9473 else if (*p == start_no)
9474 for (p++; *p != end_no; p++)
9476 else
9477 *q++ = *p;
9480 *q = 0;
9482 post_error_ne (new_msg, node, ent);
9485 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
9487 void
9488 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
9489 int num)
9491 Error_Msg_Uint_2 = UI_From_Int (num);
9492 post_error_ne_tree (msg, node, ent, t);
9495 /* Initialize the table that maps GNAT codes to GCC codes for simple
9496 binary and unary operations. */
9498 static void
9499 init_code_table (void)
9501 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
9502 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
9504 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
9505 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
9506 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
9507 gnu_codes[N_Op_Eq] = EQ_EXPR;
9508 gnu_codes[N_Op_Ne] = NE_EXPR;
9509 gnu_codes[N_Op_Lt] = LT_EXPR;
9510 gnu_codes[N_Op_Le] = LE_EXPR;
9511 gnu_codes[N_Op_Gt] = GT_EXPR;
9512 gnu_codes[N_Op_Ge] = GE_EXPR;
9513 gnu_codes[N_Op_Add] = PLUS_EXPR;
9514 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
9515 gnu_codes[N_Op_Multiply] = MULT_EXPR;
9516 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
9517 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
9518 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
9519 gnu_codes[N_Op_Abs] = ABS_EXPR;
9520 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
9521 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
9522 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
9523 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
9524 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
9525 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
9528 /* Return a label to branch to for the exception type in KIND or NULL_TREE
9529 if none. */
9531 tree
9532 get_exception_label (char kind)
9534 if (kind == N_Raise_Constraint_Error)
9535 return gnu_constraint_error_label_stack->last ();
9536 else if (kind == N_Raise_Storage_Error)
9537 return gnu_storage_error_label_stack->last ();
9538 else if (kind == N_Raise_Program_Error)
9539 return gnu_program_error_label_stack->last ();
9540 else
9541 return NULL_TREE;
9544 /* Return the decl for the current elaboration procedure. */
9546 tree
9547 get_elaboration_procedure (void)
9549 return gnu_elab_proc_stack->last ();
9552 #include "gt-ada-trans.h"