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