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