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