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