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