1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2010, Free Software Foundation, Inc. *
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- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
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 *
18 * Public License distributed with GNAT; see file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
35 #include "tree-iterator.h"
39 #include "adadecode.h"
56 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
57 for fear of running out of stack space. If we need more, we use xmalloc
59 #define ALLOCA_THRESHOLD 1000
61 /* Let code below know whether we are targetting VMS without need of
62 intrusive preprocessor directives. */
63 #ifndef TARGET_ABI_OPEN_VMS
64 #define TARGET_ABI_OPEN_VMS 0
67 /* For efficient float-to-int rounding, it is necessary to know whether
68 floating-point arithmetic may use wider intermediate results. When
69 FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
70 that arithmetic does not widen if double precision is emulated. */
71 #ifndef FP_ARITH_MAY_WIDEN
72 #if defined(HAVE_extendsfdf2)
73 #define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
75 #define FP_ARITH_MAY_WIDEN 0
79 /* Pointers to front-end tables accessed through macros. */
80 struct Node *Nodes_Ptr;
81 Node_Id *Next_Node_Ptr;
82 Node_Id *Prev_Node_Ptr;
83 struct Elist_Header *Elists_Ptr;
84 struct Elmt_Item *Elmts_Ptr;
85 struct String_Entry *Strings_Ptr;
86 Char_Code *String_Chars_Ptr;
87 struct List_Header *List_Headers_Ptr;
89 /* Highest number in the front-end node table. */
92 /* Current node being treated, in case abort called. */
93 Node_Id error_gnat_node;
95 /* True when gigi is being called on an analyzed but unexpanded
96 tree, and the only purpose of the call is to properly annotate
97 types with representation information. */
98 bool type_annotate_only;
100 /* Current filename without path. */
101 const char *ref_filename;
103 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
104 of unconstrained array IN parameters to avoid emitting a great deal of
105 redundant instructions to recompute them each time. */
106 struct GTY (()) parm_attr_d {
107 int id; /* GTY doesn't like Entity_Id. */
114 typedef struct parm_attr_d *parm_attr;
116 DEF_VEC_P(parm_attr);
117 DEF_VEC_ALLOC_P(parm_attr,gc);
119 struct GTY(()) language_function {
120 VEC(parm_attr,gc) *parm_attr_cache;
123 #define f_parm_attr_cache \
124 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
126 /* A structure used to gather together information about a statement group.
127 We use this to gather related statements, for example the "then" part
128 of a IF. In the case where it represents a lexical scope, we may also
129 have a BLOCK node corresponding to it and/or cleanups. */
131 struct GTY((chain_next ("%h.previous"))) stmt_group {
132 struct stmt_group *previous; /* Previous code group. */
133 tree stmt_list; /* List of statements for this code group. */
134 tree block; /* BLOCK for this code group, if any. */
135 tree cleanups; /* Cleanups for this code group, if any. */
138 static GTY(()) struct stmt_group *current_stmt_group;
140 /* List of unused struct stmt_group nodes. */
141 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
143 /* A structure used to record information on elaboration procedures
144 we've made and need to process.
146 ??? gnat_node should be Node_Id, but gengtype gets confused. */
148 struct GTY((chain_next ("%h.next"))) elab_info {
149 struct elab_info *next; /* Pointer to next in chain. */
150 tree elab_proc; /* Elaboration procedure. */
151 int gnat_node; /* The N_Compilation_Unit. */
154 static GTY(()) struct elab_info *elab_info_list;
156 /* Free list of TREE_LIST nodes used for stacks. */
157 static GTY((deletable)) tree gnu_stack_free_list;
159 /* List of TREE_LIST nodes representing a stack of exception pointer
160 variables. TREE_VALUE is the VAR_DECL that stores the address of
161 the raised exception. Nonzero means we are in an exception
162 handler. Not used in the zero-cost case. */
163 static GTY(()) tree gnu_except_ptr_stack;
165 /* List of TREE_LIST nodes used to store the current elaboration procedure
166 decl. TREE_VALUE is the decl. */
167 static GTY(()) tree gnu_elab_proc_stack;
169 /* Variable that stores a list of labels to be used as a goto target instead of
170 a return in some functions. See processing for N_Subprogram_Body. */
171 static GTY(()) tree gnu_return_label_stack;
173 /* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes.
174 TREE_VALUE of each entry is the label of the corresponding LOOP_STMT. */
175 static GTY(()) tree gnu_loop_label_stack;
177 /* List of TREE_LIST nodes representing labels for switch statements.
178 TREE_VALUE of each entry is the label at the end of the switch. */
179 static GTY(()) tree gnu_switch_label_stack;
181 /* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label. */
182 static GTY(()) tree gnu_constraint_error_label_stack;
183 static GTY(()) tree gnu_storage_error_label_stack;
184 static GTY(()) tree gnu_program_error_label_stack;
186 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
187 static enum tree_code gnu_codes[Number_Node_Kinds];
189 static void init_code_table (void);
190 static void Compilation_Unit_to_gnu (Node_Id);
191 static void record_code_position (Node_Id);
192 static void insert_code_for (Node_Id);
193 static void add_cleanup (tree, Node_Id);
194 static tree unshare_save_expr (tree *, int *, void *);
195 static void add_stmt_list (List_Id);
196 static void push_exception_label_stack (tree *, Entity_Id);
197 static tree build_stmt_group (List_Id, bool);
198 static void push_stack (tree *, tree, tree);
199 static void pop_stack (tree *);
200 static enum gimplify_status gnat_gimplify_stmt (tree *);
201 static void elaborate_all_entities (Node_Id);
202 static void process_freeze_entity (Node_Id);
203 static void process_inlined_subprograms (Node_Id);
204 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
205 static tree emit_range_check (tree, Node_Id, Node_Id);
206 static tree emit_index_check (tree, tree, tree, tree, Node_Id);
207 static tree emit_check (tree, tree, int, Node_Id);
208 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
209 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
210 static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
211 static bool smaller_packable_type_p (tree, tree);
212 static bool addressable_p (tree, tree);
213 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
214 static tree extract_values (tree, tree);
215 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
216 static tree maybe_implicit_deref (tree);
217 static void set_expr_location_from_node (tree, Node_Id);
218 static int lvalue_required_p (Node_Id, tree, bool, bool, bool);
220 /* Hooks for debug info back-ends, only supported and used in a restricted set
221 of configurations. */
222 static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
223 static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
225 /* This is the main program of the back-end. It sets up all the table
226 structures and then generates code. */
229 gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
230 struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
231 struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
232 struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
233 struct List_Header *list_headers_ptr, Nat number_file,
234 struct File_Info_Type *file_info_ptr, Entity_Id standard_boolean,
235 Entity_Id standard_integer, Entity_Id standard_long_long_float,
236 Entity_Id standard_exception_type, Int gigi_operating_mode)
238 Entity_Id gnat_literal;
239 tree long_long_float_type, exception_type, t;
240 tree int64_type = gnat_type_for_size (64, 0);
241 struct elab_info *info;
244 max_gnat_nodes = max_gnat_node;
246 Nodes_Ptr = nodes_ptr;
247 Next_Node_Ptr = next_node_ptr;
248 Prev_Node_Ptr = prev_node_ptr;
249 Elists_Ptr = elists_ptr;
250 Elmts_Ptr = elmts_ptr;
251 Strings_Ptr = strings_ptr;
252 String_Chars_Ptr = string_chars_ptr;
253 List_Headers_Ptr = list_headers_ptr;
255 type_annotate_only = (gigi_operating_mode == 1);
257 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
259 /* Declare the name of the compilation unit as the first global
260 name in order to make the middle-end fully deterministic. */
261 t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
262 first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
264 for (i = 0; i < number_file; i++)
266 /* Use the identifier table to make a permanent copy of the filename as
267 the name table gets reallocated after Gigi returns but before all the
268 debugging information is output. The __gnat_to_canonical_file_spec
269 call translates filenames from pragmas Source_Reference that contain
270 host style syntax not understood by gdb. */
274 (__gnat_to_canonical_file_spec
275 (Get_Name_String (file_info_ptr[i].File_Name))));
277 /* We rely on the order isomorphism between files and line maps. */
278 gcc_assert ((int) line_table->used == i);
280 /* We create the line map for a source file at once, with a fixed number
281 of columns chosen to avoid jumping over the next power of 2. */
282 linemap_add (line_table, LC_ENTER, 0, filename, 1);
283 linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
284 linemap_position_for_column (line_table, 252 - 1);
285 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
288 /* Initialize ourselves. */
293 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
295 if (type_annotate_only)
297 TYPE_SIZE (void_type_node) = bitsize_zero_node;
298 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
301 /* If the GNU type extensions to DWARF are available, setup the hooks. */
302 #if defined (DWARF2_DEBUGGING_INFO) && defined (DWARF2_GNU_TYPE_EXTENSIONS)
303 /* We condition the name demangling and the generation of type encoding
304 strings on -gdwarf+ and always set descriptive types on. */
305 if (use_gnu_debug_info_extensions)
307 dwarf2out_set_type_encoding_func (extract_encoding);
308 dwarf2out_set_demangle_name_func (decode_name);
310 dwarf2out_set_descriptive_type_func (get_parallel_type);
313 /* Enable GNAT stack checking method if needed */
314 if (!Stack_Check_Probes_On_Target)
315 set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
317 /* Retrieve alignment settings. */
318 double_float_alignment = get_target_double_float_alignment ();
319 double_scalar_alignment = get_target_double_scalar_alignment ();
321 /* Record the builtin types. Define `integer' and `unsigned char' first so
322 that dbx will output them first. */
323 record_builtin_type ("integer", integer_type_node);
324 record_builtin_type ("unsigned char", char_type_node);
325 record_builtin_type ("long integer", long_integer_type_node);
326 unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
327 record_builtin_type ("unsigned int", unsigned_type_node);
328 record_builtin_type (SIZE_TYPE, sizetype);
329 record_builtin_type ("boolean", boolean_type_node);
330 record_builtin_type ("void", void_type_node);
332 /* Save the type we made for integer as the type for Standard.Integer. */
333 save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node),
336 /* Save the type we made for boolean as the type for Standard.Boolean. */
337 save_gnu_tree (Base_Type (standard_boolean), TYPE_NAME (boolean_type_node),
339 gnat_literal = First_Literal (Base_Type (standard_boolean));
340 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
341 gcc_assert (t == boolean_false_node);
342 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
343 boolean_type_node, t, true, false, false, false,
345 DECL_IGNORED_P (t) = 1;
346 save_gnu_tree (gnat_literal, t, false);
347 gnat_literal = Next_Literal (gnat_literal);
348 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
349 gcc_assert (t == boolean_true_node);
350 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
351 boolean_type_node, t, true, false, false, false,
353 DECL_IGNORED_P (t) = 1;
354 save_gnu_tree (gnat_literal, t, false);
356 void_ftype = build_function_type (void_type_node, NULL_TREE);
357 ptr_void_ftype = build_pointer_type (void_ftype);
359 /* Now declare runtime functions. */
360 t = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
362 /* malloc is a function declaration tree for a function to allocate
365 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
366 build_function_type (ptr_void_type_node,
367 tree_cons (NULL_TREE,
369 NULL_TREE, false, true, true, NULL, Empty);
370 DECL_IS_MALLOC (malloc_decl) = 1;
372 /* malloc32 is a function declaration tree for a function to allocate
373 32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */
375 = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
376 build_function_type (ptr_void_type_node,
377 tree_cons (NULL_TREE,
379 NULL_TREE, false, true, true, NULL, Empty);
380 DECL_IS_MALLOC (malloc32_decl) = 1;
382 /* free is a function declaration tree for a function to free memory. */
384 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
385 build_function_type (void_type_node,
386 tree_cons (NULL_TREE,
389 NULL_TREE, false, true, true, NULL, Empty);
391 /* This is used for 64-bit multiplication with overflow checking. */
393 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
394 build_function_type_list (int64_type, int64_type,
395 int64_type, NULL_TREE),
396 NULL_TREE, false, true, true, NULL, Empty);
398 /* Name of the _Parent field in tagged record types. */
399 parent_name_id = get_identifier (Get_Name_String (Name_uParent));
401 /* Make the types and functions used for exception processing. */
403 = build_array_type (gnat_type_for_mode (Pmode, 0),
404 build_index_type (size_int (5)));
405 record_builtin_type ("JMPBUF_T", jmpbuf_type);
406 jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
408 /* Functions to get and set the jumpbuf pointer for the current thread. */
410 = create_subprog_decl
411 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
412 NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
413 NULL_TREE, false, true, true, NULL, Empty);
414 /* Avoid creating superfluous edges to __builtin_setjmp receivers. */
415 DECL_PURE_P (get_jmpbuf_decl) = 1;
418 = create_subprog_decl
419 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
421 build_function_type (void_type_node,
422 tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
423 NULL_TREE, false, true, true, NULL, Empty);
425 /* setjmp returns an integer and has one operand, which is a pointer to
428 = create_subprog_decl
429 (get_identifier ("__builtin_setjmp"), NULL_TREE,
430 build_function_type (integer_type_node,
431 tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
432 NULL_TREE, false, true, true, NULL, Empty);
434 DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
435 DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
437 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
439 update_setjmp_buf_decl
440 = create_subprog_decl
441 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
442 build_function_type (void_type_node,
443 tree_cons (NULL_TREE, jmpbuf_ptr_type, t)),
444 NULL_TREE, false, true, true, NULL, Empty);
446 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
447 DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
449 /* Hooks to call when entering/leaving an exception handler. */
451 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
452 build_function_type (void_type_node,
453 tree_cons (NULL_TREE,
456 NULL_TREE, false, true, true, NULL, Empty);
459 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
460 build_function_type (void_type_node,
461 tree_cons (NULL_TREE,
464 NULL_TREE, false, true, true, NULL, Empty);
466 /* If in no exception handlers mode, all raise statements are redirected to
467 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
468 this procedure will never be called in this mode. */
469 if (No_Exception_Handlers_Set ())
472 = create_subprog_decl
473 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
474 build_function_type (void_type_node,
475 tree_cons (NULL_TREE,
476 build_pointer_type (char_type_node),
477 tree_cons (NULL_TREE,
480 NULL_TREE, false, true, true, NULL, Empty);
482 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
483 gnat_raise_decls[i] = decl;
486 /* Otherwise, make one decl for each exception reason. */
487 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
491 sprintf (name, "__gnat_rcheck_%.2d", i);
493 = create_subprog_decl
494 (get_identifier (name), NULL_TREE,
495 build_function_type (void_type_node,
496 tree_cons (NULL_TREE,
499 tree_cons (NULL_TREE,
502 NULL_TREE, false, true, true, NULL, Empty);
505 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
507 TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1;
508 TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1;
509 TREE_TYPE (gnat_raise_decls[i])
510 = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]),
514 /* Set the types that GCC and Gigi use from the front end. We would
515 like to do this for char_type_node, but it needs to correspond to
518 = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
519 except_type_node = TREE_TYPE (exception_type);
521 /* Make other functions used for exception processing. */
523 = create_subprog_decl
524 (get_identifier ("system__soft_links__get_gnat_exception"),
526 build_function_type (build_pointer_type (except_type_node), NULL_TREE),
527 NULL_TREE, false, true, true, NULL, Empty);
528 /* Avoid creating superfluous edges to __builtin_setjmp receivers. */
529 DECL_PURE_P (get_excptr_decl) = 1;
532 = create_subprog_decl
533 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
534 build_function_type (void_type_node,
535 tree_cons (NULL_TREE,
536 build_pointer_type (except_type_node),
538 NULL_TREE, false, true, true, NULL, Empty);
540 /* Indicate that these never return. */
541 TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
542 TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
543 TREE_TYPE (raise_nodefer_decl)
544 = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
547 /* Build the special descriptor type and its null node if needed. */
548 if (TARGET_VTABLE_USES_DESCRIPTORS)
550 tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
551 tree field_list = NULL_TREE, null_list = NULL_TREE;
554 fdesc_type_node = make_node (RECORD_TYPE);
556 for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
558 tree field = create_field_decl (NULL_TREE, ptr_void_ftype,
559 fdesc_type_node, 0, 0, 0, 1);
560 TREE_CHAIN (field) = field_list;
562 null_list = tree_cons (field, null_node, null_list);
565 finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
566 record_builtin_type ("descriptor", fdesc_type_node);
567 null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
571 = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
573 if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
575 /* In this case, the builtin floating point types are VAX float,
576 so make up a type for use. */
577 longest_float_type_node = make_node (REAL_TYPE);
578 TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
579 layout_type (longest_float_type_node);
580 record_builtin_type ("longest float type", longest_float_type_node);
583 longest_float_type_node = TREE_TYPE (long_long_float_type);
585 /* Dummy objects to materialize "others" and "all others" in the exception
586 tables. These are exported by a-exexpr.adb, so see this unit for the
589 = create_var_decl (get_identifier ("OTHERS"),
590 get_identifier ("__gnat_others_value"),
591 integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
594 = create_var_decl (get_identifier ("ALL_OTHERS"),
595 get_identifier ("__gnat_all_others_value"),
596 integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
598 main_identifier_node = get_identifier ("main");
600 /* Install the builtins we might need, either internally or as
601 user available facilities for Intrinsic imports. */
602 gnat_install_builtins ();
604 gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
605 gnu_constraint_error_label_stack
606 = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
607 gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
608 gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
610 /* Process any Pragma Ident for the main unit. */
611 #ifdef ASM_OUTPUT_IDENT
612 if (Present (Ident_String (Main_Unit)))
615 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
618 /* If we are using the GCC exception mechanism, let GCC know. */
619 if (Exception_Mechanism == Back_End_Exceptions)
622 /* Now translate the compilation unit proper. */
623 Compilation_Unit_to_gnu (gnat_root);
625 /* Finally see if we have any elaboration procedures to deal with. */
626 for (info = elab_info_list; info; info = info->next)
628 tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
630 /* Unshare SAVE_EXPRs between subprograms. These are not unshared by
631 the gimplifier for obvious reasons, but it turns out that we need to
632 unshare them for the global level because of SAVE_EXPRs made around
633 checks for global objects and around allocators for global objects
634 of variable size, in order to prevent node sharing in the underlying
635 expression. Note that this implicitly assumes that the SAVE_EXPR
636 nodes themselves are not shared between subprograms, which would be
637 an upstream bug for which we would not change the outcome. */
638 walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL);
640 /* We should have a BIND_EXPR but it may not have any statements in it.
641 If it doesn't have any, we have nothing to do except for setting the
642 flag on the GNAT node. Otherwise, process the function as others. */
643 gnu_stmts = gnu_body;
644 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
645 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
646 if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
647 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
650 begin_subprog_body (info->elab_proc);
651 end_subprog_body (gnu_body);
655 /* We cannot track the location of errors past this point. */
656 error_gnat_node = Empty;
659 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
660 an N_Attribute_Reference. */
663 lvalue_required_for_attribute_p (Node_Id gnat_node)
665 switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
673 case Attr_Range_Length:
675 case Attr_Object_Size:
676 case Attr_Value_Size:
677 case Attr_Component_Size:
678 case Attr_Max_Size_In_Storage_Elements:
681 case Attr_Null_Parameter:
682 case Attr_Passed_By_Reference:
683 case Attr_Mechanism_Code:
688 case Attr_Unchecked_Access:
689 case Attr_Unrestricted_Access:
690 case Attr_Code_Address:
691 case Attr_Pool_Address:
694 case Attr_Bit_Position:
704 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
705 is the type that will be used for GNAT_NODE in the translated GNU tree.
706 CONSTANT indicates whether the underlying object represented by GNAT_NODE
707 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
708 whether its value is the address of a constant and ALIASED whether it is
709 aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored.
711 The function climbs up the GNAT tree starting from the node and returns 1
712 upon encountering a node that effectively requires an lvalue downstream.
713 It returns int instead of bool to facilitate usage in non-purely binary
717 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
718 bool address_of_constant, bool aliased)
720 Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
722 switch (Nkind (gnat_parent))
727 case N_Attribute_Reference:
728 return lvalue_required_for_attribute_p (gnat_parent);
730 case N_Parameter_Association:
731 case N_Function_Call:
732 case N_Procedure_Call_Statement:
733 return (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type));
735 case N_Indexed_Component:
736 /* Only the array expression can require an lvalue. */
737 if (Prefix (gnat_parent) != gnat_node)
740 /* ??? Consider that referencing an indexed component with a
741 non-constant index forces the whole aggregate to memory.
742 Note that N_Integer_Literal is conservative, any static
743 expression in the RM sense could probably be accepted. */
744 for (gnat_temp = First (Expressions (gnat_parent));
746 gnat_temp = Next (gnat_temp))
747 if (Nkind (gnat_temp) != N_Integer_Literal)
750 /* ... fall through ... */
753 /* Only the array expression can require an lvalue. */
754 if (Prefix (gnat_parent) != gnat_node)
757 aliased |= Has_Aliased_Components (Etype (gnat_node));
758 return lvalue_required_p (gnat_parent, gnu_type, constant,
759 address_of_constant, aliased);
761 case N_Selected_Component:
762 aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
763 return lvalue_required_p (gnat_parent, gnu_type, constant,
764 address_of_constant, aliased);
766 case N_Object_Renaming_Declaration:
767 /* We need to make a real renaming only if the constant object is
768 aliased or if we may use a renaming pointer; otherwise we can
769 optimize and return the rvalue. We make an exception if the object
770 is an identifier since in this case the rvalue can be propagated
771 attached to the CONST_DECL. */
774 /* This should match the constant case of the renaming code. */
776 (Underlying_Type (Etype (Name (gnat_parent))))
777 || Nkind (Name (gnat_parent)) == N_Identifier);
779 case N_Object_Declaration:
780 /* We cannot use a constructor if this is an atomic object because
781 the actual assignment might end up being done component-wise. */
782 return ((Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
783 && Is_Atomic (Defining_Entity (gnat_parent)))
784 /* We don't use a constructor if this is a class-wide object
785 because the effective type of the object is the equivalent
786 type of the class-wide subtype and it smashes most of the
787 data into an array of bytes to which we cannot convert. */
788 || Ekind ((Etype (Defining_Entity (gnat_parent))))
789 == E_Class_Wide_Subtype);
791 case N_Assignment_Statement:
792 /* We cannot use a constructor if the LHS is an atomic object because
793 the actual assignment might end up being done component-wise. */
794 return (Name (gnat_parent) == gnat_node
795 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
796 && Is_Atomic (Entity (Name (gnat_parent)))));
798 case N_Type_Conversion:
799 case N_Qualified_Expression:
800 /* We must look through all conversions for composite types because we
801 may need to bypass an intermediate conversion to a narrower record
802 type that is generated for a formal conversion, e.g. the conversion
803 to the root type of a hierarchy of tagged types generated for the
804 formal conversion to the class-wide type. */
805 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_node))))
808 /* ... fall through ... */
810 case N_Unchecked_Type_Conversion:
811 return lvalue_required_p (gnat_parent,
812 get_unpadded_type (Etype (gnat_parent)),
813 constant, address_of_constant, aliased);
816 /* We should only reach here through the N_Qualified_Expression case
817 and, therefore, only for composite types. Force an lvalue since
818 a block-copy to the newly allocated area of memory is made. */
821 case N_Explicit_Dereference:
822 /* We look through dereferences for address of constant because we need
823 to handle the special cases listed above. */
824 if (constant && address_of_constant)
825 return lvalue_required_p (gnat_parent,
826 get_unpadded_type (Etype (gnat_parent)),
829 /* ... fall through ... */
838 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
839 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
840 to where we should place the result type. */
843 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
845 Node_Id gnat_temp, gnat_temp_type;
846 tree gnu_result, gnu_result_type;
848 /* Whether we should require an lvalue for GNAT_NODE. Needed in
849 specific circumstances only, so evaluated lazily. < 0 means
850 unknown, > 0 means known true, 0 means known false. */
851 int require_lvalue = -1;
853 /* If GNAT_NODE is a constant, whether we should use the initialization
854 value instead of the constant entity, typically for scalars with an
855 address clause when the parent doesn't require an lvalue. */
856 bool use_constant_initializer = false;
858 /* If the Etype of this node does not equal the Etype of the Entity,
859 something is wrong with the entity map, probably in generic
860 instantiation. However, this does not apply to types. Since we sometime
861 have strange Ekind's, just do this test for objects. Also, if the Etype of
862 the Entity is private, the Etype of the N_Identifier is allowed to be the
863 full type and also we consider a packed array type to be the same as the
864 original type. Similarly, a class-wide type is equivalent to a subtype of
865 itself. Finally, if the types are Itypes, one may be a copy of the other,
866 which is also legal. */
867 gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
868 ? gnat_node : Entity (gnat_node));
869 gnat_temp_type = Etype (gnat_temp);
871 gcc_assert (Etype (gnat_node) == gnat_temp_type
872 || (Is_Packed (gnat_temp_type)
873 && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
874 || (Is_Class_Wide_Type (Etype (gnat_node)))
875 || (IN (Ekind (gnat_temp_type), Private_Kind)
876 && Present (Full_View (gnat_temp_type))
877 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
878 || (Is_Packed (Full_View (gnat_temp_type))
879 && (Etype (gnat_node)
880 == Packed_Array_Type (Full_View
881 (gnat_temp_type))))))
882 || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
883 || !(Ekind (gnat_temp) == E_Variable
884 || Ekind (gnat_temp) == E_Component
885 || Ekind (gnat_temp) == E_Constant
886 || Ekind (gnat_temp) == E_Loop_Parameter
887 || IN (Ekind (gnat_temp), Formal_Kind)));
889 /* If this is a reference to a deferred constant whose partial view is an
890 unconstrained private type, the proper type is on the full view of the
891 constant, not on the full view of the type, which may be unconstrained.
893 This may be a reference to a type, for example in the prefix of the
894 attribute Position, generated for dispatching code (see Make_DT in
895 exp_disp,adb). In that case we need the type itself, not is parent,
896 in particular if it is a derived type */
897 if (Is_Private_Type (gnat_temp_type)
898 && Has_Unknown_Discriminants (gnat_temp_type)
899 && Ekind (gnat_temp) == E_Constant
900 && Present (Full_View (gnat_temp)))
902 gnat_temp = Full_View (gnat_temp);
903 gnat_temp_type = Etype (gnat_temp);
907 /* We want to use the Actual_Subtype if it has already been elaborated,
908 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
910 if ((Ekind (gnat_temp) == E_Constant
911 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
912 && !(Is_Array_Type (Etype (gnat_temp))
913 && Present (Packed_Array_Type (Etype (gnat_temp))))
914 && Present (Actual_Subtype (gnat_temp))
915 && present_gnu_tree (Actual_Subtype (gnat_temp)))
916 gnat_temp_type = Actual_Subtype (gnat_temp);
918 gnat_temp_type = Etype (gnat_node);
921 /* Expand the type of this identifier first, in case it is an enumeral
922 literal, which only get made when the type is expanded. There is no
923 order-of-elaboration issue here. */
924 gnu_result_type = get_unpadded_type (gnat_temp_type);
926 /* If this is a non-imported scalar constant with an address clause,
927 retrieve the value instead of a pointer to be dereferenced unless
928 an lvalue is required. This is generally more efficient and actually
929 required if this is a static expression because it might be used
930 in a context where a dereference is inappropriate, such as a case
931 statement alternative or a record discriminant. There is no possible
932 volatile-ness short-circuit here since Volatile constants must bei
934 if (Ekind (gnat_temp) == E_Constant
935 && Is_Scalar_Type (gnat_temp_type)
936 && !Is_Imported (gnat_temp)
937 && Present (Address_Clause (gnat_temp)))
939 require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
940 false, Is_Aliased (gnat_temp));
941 use_constant_initializer = !require_lvalue;
944 if (use_constant_initializer)
946 /* If this is a deferred constant, the initializer is attached to
948 if (Present (Full_View (gnat_temp)))
949 gnat_temp = Full_View (gnat_temp);
951 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
954 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
956 /* If we are in an exception handler, force this variable into memory to
957 ensure optimization does not remove stores that appear redundant but are
958 actually needed in case an exception occurs.
960 ??? Note that we need not do this if the variable is declared within the
961 handler, only if it is referenced in the handler and declared in an
962 enclosing block, but we have no way of testing that right now.
964 ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable
965 here, but it can now be removed by the Tree aliasing machinery if the
966 address of the variable is never taken. All we can do is to make the
967 variable volatile, which might incur the generation of temporaries just
968 to access the memory in some circumstances. This can be avoided for
969 variables of non-constant size because they are automatically allocated
970 to memory. There might be no way of allocating a proper temporary for
971 them in any case. We only do this for SJLJ though. */
972 if (TREE_VALUE (gnu_except_ptr_stack)
973 && TREE_CODE (gnu_result) == VAR_DECL
974 && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST)
975 TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
977 /* Some objects (such as parameters passed by reference, globals of
978 variable size, and renamed objects) actually represent the address
979 of the object. In that case, we must do the dereference. Likewise,
980 deal with parameters to foreign convention subprograms. */
981 if (DECL_P (gnu_result)
982 && (DECL_BY_REF_P (gnu_result)
983 || (TREE_CODE (gnu_result) == PARM_DECL
984 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
986 const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
989 if (TREE_CODE (gnu_result) == PARM_DECL
990 && DECL_BY_COMPONENT_PTR_P (gnu_result))
992 = build_unary_op (INDIRECT_REF, NULL_TREE,
993 convert (build_pointer_type (gnu_result_type),
996 /* If it's a renaming pointer and we are at the right binding level,
997 we can reference the renamed object directly, since the renamed
998 expression has been protected against multiple evaluations. */
999 else if (TREE_CODE (gnu_result) == VAR_DECL
1000 && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result))
1001 && (!DECL_RENAMING_GLOBAL_P (gnu_result)
1002 || global_bindings_p ()))
1003 gnu_result = renamed_obj;
1005 /* Return the underlying CST for a CONST_DECL like a few lines below,
1006 after dereferencing in this case. */
1007 else if (TREE_CODE (gnu_result) == CONST_DECL)
1008 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
1009 DECL_INITIAL (gnu_result));
1012 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1015 TREE_READONLY (gnu_result) = 1;
1018 /* The GNAT tree has the type of a function as the type of its result. Also
1019 use the type of the result if the Etype is a subtype which is nominally
1020 unconstrained. But remove any padding from the resulting type. */
1021 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
1022 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
1024 gnu_result_type = TREE_TYPE (gnu_result);
1025 if (TYPE_IS_PADDING_P (gnu_result_type))
1026 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1029 /* If we have a constant declaration and its initializer at hand,
1030 try to return the latter to avoid the need to call fold in lots
1031 of places and the need of elaboration code if this Id is used as
1032 an initializer itself. */
1033 if (TREE_CONSTANT (gnu_result)
1034 && DECL_P (gnu_result)
1035 && DECL_INITIAL (gnu_result))
1037 bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1038 && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1039 bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1040 && DECL_CONST_ADDRESS_P (gnu_result));
1042 /* If there is a (corresponding) variable or this is the address of a
1043 constant, we only want to return the initializer if an lvalue isn't
1044 required. Evaluate this now if we have not already done so. */
1045 if ((!constant_only || address_of_constant) && require_lvalue < 0)
1047 = lvalue_required_p (gnat_node, gnu_result_type, true,
1048 address_of_constant, Is_Aliased (gnat_temp));
1050 if ((constant_only && !address_of_constant) || !require_lvalue)
1051 gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
1054 *gnu_result_type_p = gnu_result_type;
1058 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1059 any statements we generate. */
1062 Pragma_to_gnu (Node_Id gnat_node)
1065 tree gnu_result = alloc_stmt_list ();
1067 /* Check for (and ignore) unrecognized pragma and do nothing if we are just
1068 annotating types. */
1069 if (type_annotate_only
1070 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1073 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
1075 case Pragma_Inspection_Point:
1076 /* Do nothing at top level: all such variables are already viewable. */
1077 if (global_bindings_p ())
1080 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1081 Present (gnat_temp);
1082 gnat_temp = Next (gnat_temp))
1084 Node_Id gnat_expr = Expression (gnat_temp);
1085 tree gnu_expr = gnat_to_gnu (gnat_expr);
1087 enum machine_mode mode;
1088 tree asm_constraint = NULL_TREE;
1089 #ifdef ASM_COMMENT_START
1093 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
1094 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1096 /* Use the value only if it fits into a normal register,
1097 otherwise use the address. */
1098 mode = TYPE_MODE (TREE_TYPE (gnu_expr));
1099 use_address = ((GET_MODE_CLASS (mode) != MODE_INT
1100 && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
1101 || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
1104 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
1106 #ifdef ASM_COMMENT_START
1107 comment = concat (ASM_COMMENT_START,
1108 " inspection point: ",
1109 Get_Name_String (Chars (gnat_expr)),
1110 use_address ? " address" : "",
1113 asm_constraint = build_string (strlen (comment), comment);
1116 gnu_expr = build5 (ASM_EXPR, void_type_node,
1120 (build_tree_list (NULL_TREE,
1121 build_string (1, "g")),
1122 gnu_expr, NULL_TREE),
1123 NULL_TREE, NULL_TREE);
1124 ASM_VOLATILE_P (gnu_expr) = 1;
1125 set_expr_location_from_node (gnu_expr, gnat_node);
1126 append_to_statement_list (gnu_expr, &gnu_result);
1130 case Pragma_Optimize:
1131 switch (Chars (Expression
1132 (First (Pragma_Argument_Associations (gnat_node)))))
1134 case Name_Time: case Name_Space:
1136 post_error ("insufficient -O value?", gnat_node);
1141 post_error ("must specify -O0?", gnat_node);
1149 case Pragma_Reviewable:
1150 if (write_symbols == NO_DEBUG)
1151 post_error ("must specify -g?", gnat_node);
1158 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1159 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1160 where we should place the result type. ATTRIBUTE is the attribute ID. */
1163 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1165 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
1166 tree gnu_type = TREE_TYPE (gnu_prefix);
1167 tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1168 bool prefix_unused = false;
1170 /* If the input is a NULL_EXPR, make a new one. */
1171 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1173 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1174 *gnu_result_type_p = gnu_result_type;
1175 return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1182 /* These are just conversions since representation clauses for
1183 enumeration types are handled in the front-end. */
1185 bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
1186 gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
1187 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1188 gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
1189 checkp, checkp, true, gnat_node);
1195 /* These just add or subtract the constant 1 since representation
1196 clauses for enumeration types are handled in the front-end. */
1197 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1198 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1200 if (Do_Range_Check (First (Expressions (gnat_node))))
1202 gnu_expr = gnat_protect_expr (gnu_expr);
1205 (build_binary_op (EQ_EXPR, integer_type_node,
1207 attribute == Attr_Pred
1208 ? TYPE_MIN_VALUE (gnu_result_type)
1209 : TYPE_MAX_VALUE (gnu_result_type)),
1210 gnu_expr, CE_Range_Check_Failed, gnat_node);
1214 = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1215 gnu_result_type, gnu_expr,
1216 convert (gnu_result_type, integer_one_node));
1220 case Attr_Unrestricted_Access:
1221 /* Conversions don't change addresses but can cause us to miss the
1222 COMPONENT_REF case below, so strip them off. */
1223 gnu_prefix = remove_conversions (gnu_prefix,
1224 !Must_Be_Byte_Aligned (gnat_node));
1226 /* If we are taking 'Address of an unconstrained object, this is the
1227 pointer to the underlying array. */
1228 if (attribute == Attr_Address)
1229 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1231 /* If we are building a static dispatch table, we have to honor
1232 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1233 with the C++ ABI. We do it in the non-static case as well,
1234 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1235 else if (TARGET_VTABLE_USES_DESCRIPTORS
1236 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1238 tree gnu_field, gnu_list = NULL_TREE, t;
1239 /* Descriptors can only be built here for top-level functions. */
1240 bool build_descriptor = (global_bindings_p () != 0);
1243 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1245 /* If we're not going to build the descriptor, we have to retrieve
1246 the one which will be built by the linker (or by the compiler
1247 later if a static chain is requested). */
1248 if (!build_descriptor)
1250 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1251 gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1253 gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1256 for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1257 i < TARGET_VTABLE_USES_DESCRIPTORS;
1258 gnu_field = TREE_CHAIN (gnu_field), i++)
1260 if (build_descriptor)
1262 t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1263 build_int_cst (NULL_TREE, i));
1264 TREE_CONSTANT (t) = 1;
1267 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1268 gnu_field, NULL_TREE);
1270 gnu_list = tree_cons (gnu_field, t, gnu_list);
1273 gnu_result = gnat_build_constructor (gnu_result_type, gnu_list);
1277 /* ... fall through ... */
1280 case Attr_Unchecked_Access:
1281 case Attr_Code_Address:
1282 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1284 = build_unary_op (((attribute == Attr_Address
1285 || attribute == Attr_Unrestricted_Access)
1286 && !Must_Be_Byte_Aligned (gnat_node))
1287 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1288 gnu_result_type, gnu_prefix);
1290 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1291 don't try to build a trampoline. */
1292 if (attribute == Attr_Code_Address)
1294 for (gnu_expr = gnu_result;
1295 CONVERT_EXPR_P (gnu_expr);
1296 gnu_expr = TREE_OPERAND (gnu_expr, 0))
1297 TREE_CONSTANT (gnu_expr) = 1;
1299 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1300 TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1303 /* For other address attributes applied to a nested function,
1304 find an inner ADDR_EXPR and annotate it so that we can issue
1305 a useful warning with -Wtrampolines. */
1306 else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
1308 for (gnu_expr = gnu_result;
1309 CONVERT_EXPR_P (gnu_expr);
1310 gnu_expr = TREE_OPERAND (gnu_expr, 0))
1313 if (TREE_CODE (gnu_expr) == ADDR_EXPR
1314 && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1316 set_expr_location_from_node (gnu_expr, gnat_node);
1318 /* Check that we're not violating the No_Implicit_Dynamic_Code
1319 restriction. Be conservative if we don't know anything
1320 about the trampoline strategy for the target. */
1321 Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1326 case Attr_Pool_Address:
1329 tree gnu_ptr = gnu_prefix;
1331 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1333 /* If this is an unconstrained array, we know the object has been
1334 allocated with the template in front of the object. So compute
1335 the template address. */
1336 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1338 = convert (build_pointer_type
1339 (TYPE_OBJECT_RECORD_TYPE
1340 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1343 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1344 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
1345 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
1347 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
1348 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
1349 tree gnu_byte_offset
1350 = convert (sizetype,
1351 size_diffop (size_zero_node, gnu_pos));
1352 gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
1354 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
1355 gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
1356 gnu_ptr, gnu_byte_offset);
1359 gnu_result = convert (gnu_result_type, gnu_ptr);
1364 case Attr_Object_Size:
1365 case Attr_Value_Size:
1366 case Attr_Max_Size_In_Storage_Elements:
1367 gnu_expr = gnu_prefix;
1369 /* Remove NOPs and conversions between original and packable version
1370 from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
1371 to see if a COMPONENT_REF was involved. */
1372 while (TREE_CODE (gnu_expr) == NOP_EXPR
1373 || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
1374 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1375 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
1377 && TYPE_NAME (TREE_TYPE (gnu_expr))
1378 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
1379 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1381 gnu_prefix = remove_conversions (gnu_prefix, true);
1382 prefix_unused = true;
1383 gnu_type = TREE_TYPE (gnu_prefix);
1385 /* Replace an unconstrained array type with the type of the underlying
1386 array. We can't do this with a call to maybe_unconstrained_array
1387 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
1388 use the record type that will be used to allocate the object and its
1390 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1392 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1393 if (attribute != Attr_Max_Size_In_Storage_Elements)
1394 gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
1397 /* If we're looking for the size of a field, return the field size.
1398 Otherwise, if the prefix is an object, or if we're looking for
1399 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1400 GCC size of the type. Otherwise, it is the RM size of the type. */
1401 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1402 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1403 else if (TREE_CODE (gnu_prefix) != TYPE_DECL
1404 || attribute == Attr_Object_Size
1405 || attribute == Attr_Max_Size_In_Storage_Elements)
1407 /* If the prefix is an object of a padded type, the GCC size isn't
1408 relevant to the programmer. Normally what we want is the RM size,
1409 which was set from the specified size, but if it was not set, we
1410 want the size of the field. Using the MAX of those two produces
1411 the right result in all cases. Don't use the size of the field
1412 if it's self-referential, since that's never what's wanted. */
1413 if (TREE_CODE (gnu_prefix) != TYPE_DECL
1414 && TYPE_IS_PADDING_P (gnu_type)
1415 && TREE_CODE (gnu_expr) == COMPONENT_REF)
1417 gnu_result = rm_size (gnu_type);
1418 if (!CONTAINS_PLACEHOLDER_P
1419 (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))
1421 = size_binop (MAX_EXPR, gnu_result,
1422 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
1424 else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
1426 Node_Id gnat_deref = Prefix (gnat_node);
1427 Node_Id gnat_actual_subtype
1428 = Actual_Designated_Subtype (gnat_deref);
1430 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
1432 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1433 && Present (gnat_actual_subtype))
1435 tree gnu_actual_obj_type
1436 = gnat_to_gnu_type (gnat_actual_subtype);
1438 = build_unc_object_type_from_ptr (gnu_ptr_type,
1439 gnu_actual_obj_type,
1440 get_identifier ("SIZE"));
1443 gnu_result = TYPE_SIZE (gnu_type);
1446 gnu_result = TYPE_SIZE (gnu_type);
1449 gnu_result = rm_size (gnu_type);
1451 gcc_assert (gnu_result);
1453 /* Deal with a self-referential size by returning the maximum size for
1454 a type and by qualifying the size with the object for 'Size of an
1456 if (CONTAINS_PLACEHOLDER_P (gnu_result))
1458 if (TREE_CODE (gnu_prefix) != TYPE_DECL)
1459 gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
1461 gnu_result = max_size (gnu_result, true);
1464 /* If the type contains a template, subtract its size. */
1465 if (TREE_CODE (gnu_type) == RECORD_TYPE
1466 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1467 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1468 DECL_SIZE (TYPE_FIELDS (gnu_type)));
1470 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1472 if (attribute == Attr_Max_Size_In_Storage_Elements)
1473 gnu_result = fold_build2 (CEIL_DIV_EXPR, bitsizetype,
1474 gnu_result, bitsize_unit_node);
1477 case Attr_Alignment:
1481 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1482 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1483 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1485 gnu_type = TREE_TYPE (gnu_prefix);
1486 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1487 prefix_unused = true;
1489 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1490 align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
1493 Node_Id gnat_prefix = Prefix (gnat_node);
1494 Entity_Id gnat_type = Etype (gnat_prefix);
1495 unsigned int double_align;
1496 bool is_capped_double, align_clause;
1498 /* If the default alignment of "double" or larger scalar types is
1499 specifically capped and there is an alignment clause neither
1500 on the type nor on the prefix itself, return the cap. */
1501 if ((double_align = double_float_alignment) > 0)
1503 = is_double_float_or_array (gnat_type, &align_clause);
1504 else if ((double_align = double_scalar_alignment) > 0)
1506 = is_double_scalar_or_array (gnat_type, &align_clause);
1508 is_capped_double = align_clause = false;
1510 if (is_capped_double
1511 && Nkind (gnat_prefix) == N_Identifier
1512 && Present (Alignment_Clause (Entity (gnat_prefix))))
1513 align_clause = true;
1515 if (is_capped_double && !align_clause)
1516 align = double_align;
1518 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
1521 gnu_result = size_int (align);
1527 case Attr_Range_Length:
1528 prefix_unused = true;
1530 if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1532 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1534 if (attribute == Attr_First)
1535 gnu_result = TYPE_MIN_VALUE (gnu_type);
1536 else if (attribute == Attr_Last)
1537 gnu_result = TYPE_MAX_VALUE (gnu_type);
1541 (MAX_EXPR, get_base_type (gnu_result_type),
1543 (PLUS_EXPR, get_base_type (gnu_result_type),
1544 build_binary_op (MINUS_EXPR,
1545 get_base_type (gnu_result_type),
1546 convert (gnu_result_type,
1547 TYPE_MAX_VALUE (gnu_type)),
1548 convert (gnu_result_type,
1549 TYPE_MIN_VALUE (gnu_type))),
1550 convert (gnu_result_type, integer_one_node)),
1551 convert (gnu_result_type, integer_zero_node));
1556 /* ... fall through ... */
1560 int Dimension = (Present (Expressions (gnat_node))
1561 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1563 struct parm_attr_d *pa = NULL;
1564 Entity_Id gnat_param = Empty;
1566 /* Make sure any implicit dereference gets done. */
1567 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1568 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1569 /* We treat unconstrained array In parameters specially. */
1570 if (Nkind (Prefix (gnat_node)) == N_Identifier
1571 && !Is_Constrained (Etype (Prefix (gnat_node)))
1572 && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1573 gnat_param = Entity (Prefix (gnat_node));
1574 gnu_type = TREE_TYPE (gnu_prefix);
1575 prefix_unused = true;
1576 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1578 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1583 for (ndim = 1, gnu_type_temp = gnu_type;
1584 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1585 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1586 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1589 Dimension = ndim + 1 - Dimension;
1592 for (i = 1; i < Dimension; i++)
1593 gnu_type = TREE_TYPE (gnu_type);
1595 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1597 /* When not optimizing, look up the slot associated with the parameter
1598 and the dimension in the cache and create a new one on failure. */
1599 if (!optimize && Present (gnat_param))
1601 for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
1602 if (pa->id == gnat_param && pa->dim == Dimension)
1607 pa = GGC_CNEW (struct parm_attr_d);
1608 pa->id = gnat_param;
1609 pa->dim = Dimension;
1610 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1614 /* Return the cached expression or build a new one. */
1615 if (attribute == Attr_First)
1617 if (pa && pa->first)
1619 gnu_result = pa->first;
1624 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1627 else if (attribute == Attr_Last)
1631 gnu_result = pa->last;
1636 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1639 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
1641 if (pa && pa->length)
1643 gnu_result = pa->length;
1648 /* We used to compute the length as max (hb - lb + 1, 0),
1649 which could overflow for some cases of empty arrays, e.g.
1650 when lb == index_type'first. We now compute the length as
1651 (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in
1652 much rarer cases, for extremely large arrays we expect
1653 never to encounter in practice. In addition, the former
1654 computation required the use of potentially constraining
1655 signed arithmetic while the latter doesn't. Note that
1656 the comparison must be done in the original index type,
1657 to avoid any overflow during the conversion. */
1658 tree comp_type = get_base_type (gnu_result_type);
1659 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
1660 tree lb = TYPE_MIN_VALUE (index_type);
1661 tree hb = TYPE_MAX_VALUE (index_type);
1663 = build_binary_op (PLUS_EXPR, comp_type,
1664 build_binary_op (MINUS_EXPR,
1666 convert (comp_type, hb),
1667 convert (comp_type, lb)),
1668 convert (comp_type, integer_one_node));
1670 = build_cond_expr (comp_type,
1671 build_binary_op (GE_EXPR,
1675 convert (comp_type, integer_zero_node));
1679 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1680 handling. Note that these attributes could not have been used on
1681 an unconstrained array type. */
1682 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1684 /* Cache the expression we have just computed. Since we want to do it
1685 at runtime, we force the use of a SAVE_EXPR and let the gimplifier
1686 create the temporary. */
1690 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1691 TREE_SIDE_EFFECTS (gnu_result) = 1;
1692 if (attribute == Attr_First)
1693 pa->first = gnu_result;
1694 else if (attribute == Attr_Last)
1695 pa->last = gnu_result;
1697 pa->length = gnu_result;
1700 /* Set the source location onto the predicate of the condition in the
1701 'Length case but do not do it if the expression is cached to avoid
1702 messing up the debug info. */
1703 else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
1704 && TREE_CODE (gnu_result) == COND_EXPR
1705 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
1706 set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
1712 case Attr_Bit_Position:
1714 case Attr_First_Bit:
1718 HOST_WIDE_INT bitsize;
1719 HOST_WIDE_INT bitpos;
1721 tree gnu_field_bitpos;
1722 tree gnu_field_offset;
1724 enum machine_mode mode;
1725 int unsignedp, volatilep;
1727 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1728 gnu_prefix = remove_conversions (gnu_prefix, true);
1729 prefix_unused = true;
1731 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1732 the result is 0. Don't allow 'Bit on a bare component, though. */
1733 if (attribute == Attr_Bit
1734 && TREE_CODE (gnu_prefix) != COMPONENT_REF
1735 && TREE_CODE (gnu_prefix) != FIELD_DECL)
1737 gnu_result = integer_zero_node;
1742 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1743 || (attribute == Attr_Bit_Position
1744 && TREE_CODE (gnu_prefix) == FIELD_DECL));
1746 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1747 &mode, &unsignedp, &volatilep, false);
1749 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1751 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1752 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1754 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1755 TREE_CODE (gnu_inner) == COMPONENT_REF
1756 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1757 gnu_inner = TREE_OPERAND (gnu_inner, 0))
1760 = size_binop (PLUS_EXPR, gnu_field_bitpos,
1761 bit_position (TREE_OPERAND (gnu_inner, 1)));
1763 = size_binop (PLUS_EXPR, gnu_field_offset,
1764 byte_position (TREE_OPERAND (gnu_inner, 1)));
1767 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1769 gnu_field_bitpos = bit_position (gnu_prefix);
1770 gnu_field_offset = byte_position (gnu_prefix);
1774 gnu_field_bitpos = bitsize_zero_node;
1775 gnu_field_offset = size_zero_node;
1781 gnu_result = gnu_field_offset;
1784 case Attr_First_Bit:
1786 gnu_result = size_int (bitpos % BITS_PER_UNIT);
1790 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1791 gnu_result = size_binop (PLUS_EXPR, gnu_result,
1792 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1793 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1797 case Attr_Bit_Position:
1798 gnu_result = gnu_field_bitpos;
1802 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1804 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1811 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1812 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1814 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1815 gnu_result = build_binary_op (attribute == Attr_Min
1816 ? MIN_EXPR : MAX_EXPR,
1817 gnu_result_type, gnu_lhs, gnu_rhs);
1821 case Attr_Passed_By_Reference:
1822 gnu_result = size_int (default_pass_by_ref (gnu_type)
1823 || must_pass_by_ref (gnu_type));
1824 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1827 case Attr_Component_Size:
1828 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1829 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1830 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1832 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1833 gnu_type = TREE_TYPE (gnu_prefix);
1835 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1836 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1838 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1839 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1840 gnu_type = TREE_TYPE (gnu_type);
1842 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1844 /* Note this size cannot be self-referential. */
1845 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1846 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1847 prefix_unused = true;
1850 case Attr_Null_Parameter:
1851 /* This is just a zero cast to the pointer type for our prefix and
1853 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1855 = build_unary_op (INDIRECT_REF, NULL_TREE,
1856 convert (build_pointer_type (gnu_result_type),
1857 integer_zero_node));
1858 TREE_PRIVATE (gnu_result) = 1;
1861 case Attr_Mechanism_Code:
1864 Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1866 prefix_unused = true;
1867 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1868 if (Present (Expressions (gnat_node)))
1870 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1872 for (gnat_obj = First_Formal (gnat_obj); i > 1;
1873 i--, gnat_obj = Next_Formal (gnat_obj))
1877 code = Mechanism (gnat_obj);
1878 if (code == Default)
1879 code = ((present_gnu_tree (gnat_obj)
1880 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1881 || ((TREE_CODE (get_gnu_tree (gnat_obj))
1883 && (DECL_BY_COMPONENT_PTR_P
1884 (get_gnu_tree (gnat_obj))))))
1885 ? By_Reference : By_Copy);
1886 gnu_result = convert (gnu_result_type, size_int (- code));
1891 /* Say we have an unimplemented attribute. Then set the value to be
1892 returned to be a zero and hope that's something we can convert to
1893 the type of this attribute. */
1894 post_error ("unimplemented attribute", gnat_node);
1895 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1896 gnu_result = integer_zero_node;
1900 /* If this is an attribute where the prefix was unused, force a use of it if
1901 it has a side-effect. But don't do it if the prefix is just an entity
1902 name. However, if an access check is needed, we must do it. See second
1903 example in AARM 11.6(5.e). */
1904 if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1905 && !Is_Entity_Name (Prefix (gnat_node)))
1906 gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1907 gnu_prefix, gnu_result);
1909 *gnu_result_type_p = gnu_result_type;
1913 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1914 to a GCC tree, which is returned. */
1917 Case_Statement_to_gnu (Node_Id gnat_node)
1923 gnu_expr = gnat_to_gnu (Expression (gnat_node));
1924 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1926 /* The range of values in a case statement is determined by the rules in
1927 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1928 of the expression. One exception arises in the case of a simple name that
1929 is parenthesized. This still has the Etype of the name, but since it is
1930 not a name, para 7 does not apply, and we need to go to the base type.
1931 This is the only case where parenthesization affects the dynamic
1932 semantics (i.e. the range of possible values at runtime that is covered
1933 by the others alternative.
1935 Another exception is if the subtype of the expression is non-static. In
1936 that case, we also have to use the base type. */
1937 if (Paren_Count (Expression (gnat_node)) != 0
1938 || !Is_OK_Static_Subtype (Underlying_Type
1939 (Etype (Expression (gnat_node)))))
1940 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1942 /* We build a SWITCH_EXPR that contains the code with interspersed
1943 CASE_LABEL_EXPRs for each label. */
1945 push_stack (&gnu_switch_label_stack, NULL_TREE,
1946 create_artificial_label (input_location));
1947 start_stmt_group ();
1948 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1949 Present (gnat_when);
1950 gnat_when = Next_Non_Pragma (gnat_when))
1952 bool choices_added_p = false;
1953 Node_Id gnat_choice;
1955 /* First compile all the different case choices for the current WHEN
1957 for (gnat_choice = First (Discrete_Choices (gnat_when));
1958 Present (gnat_choice); gnat_choice = Next (gnat_choice))
1960 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1962 switch (Nkind (gnat_choice))
1965 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1966 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1969 case N_Subtype_Indication:
1970 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1971 (Constraint (gnat_choice))));
1972 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1973 (Constraint (gnat_choice))));
1977 case N_Expanded_Name:
1978 /* This represents either a subtype range or a static value of
1979 some kind; Ekind says which. */
1980 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1982 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1984 gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1985 gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
1989 /* ... fall through ... */
1991 case N_Character_Literal:
1992 case N_Integer_Literal:
1993 gnu_low = gnat_to_gnu (gnat_choice);
1996 case N_Others_Choice:
2003 /* If the case value is a subtype that raises Constraint_Error at
2004 run-time because of a wrong bound, then gnu_low or gnu_high is
2005 not translated into an INTEGER_CST. In such a case, we need
2006 to ensure that the when statement is not added in the tree,
2007 otherwise it will crash the gimplifier. */
2008 if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
2009 && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
2011 add_stmt_with_node (build3
2012 (CASE_LABEL_EXPR, void_type_node,
2014 create_artificial_label (input_location)),
2016 choices_added_p = true;
2020 /* Push a binding level here in case variables are declared as we want
2021 them to be local to this set of statements instead of to the block
2022 containing the Case statement. */
2023 if (choices_added_p)
2025 add_stmt (build_stmt_group (Statements (gnat_when), true));
2026 add_stmt (build1 (GOTO_EXPR, void_type_node,
2027 TREE_VALUE (gnu_switch_label_stack)));
2031 /* Now emit a definition of the label all the cases branched to. */
2032 add_stmt (build1 (LABEL_EXPR, void_type_node,
2033 TREE_VALUE (gnu_switch_label_stack)));
2034 gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
2035 end_stmt_group (), NULL_TREE);
2036 pop_stack (&gnu_switch_label_stack);
2041 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2042 to a GCC tree, which is returned. */
2045 Loop_Statement_to_gnu (Node_Id gnat_node)
2047 /* ??? It would be nice to use "build" here, but there's no build5. */
2048 tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
2049 NULL_TREE, NULL_TREE, NULL_TREE);
2050 tree gnu_loop_var = NULL_TREE;
2051 Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2052 tree gnu_cond_expr = NULL_TREE;
2055 TREE_TYPE (gnu_loop_stmt) = void_type_node;
2056 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
2057 LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (input_location);
2058 set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2059 Sloc_to_locus (Sloc (End_Label (gnat_node)),
2060 &DECL_SOURCE_LOCATION (LOOP_STMT_LABEL (gnu_loop_stmt)));
2062 /* Save the end label of this LOOP_STMT in a stack so that the corresponding
2063 N_Exit_Statement can find it. */
2064 push_stack (&gnu_loop_label_stack, NULL_TREE,
2065 LOOP_STMT_LABEL (gnu_loop_stmt));
2067 /* Set the condition under which the loop must keep going.
2068 For the case "LOOP .... END LOOP;" the condition is always true. */
2069 if (No (gnat_iter_scheme))
2072 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2073 else if (Present (Condition (gnat_iter_scheme)))
2074 LOOP_STMT_TOP_COND (gnu_loop_stmt)
2075 = gnat_to_gnu (Condition (gnat_iter_scheme));
2077 /* Otherwise we have an iteration scheme and the condition is given by
2078 the bounds of the subtype of the iteration variable. */
2081 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2082 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2083 Entity_Id gnat_type = Etype (gnat_loop_var);
2084 tree gnu_type = get_unpadded_type (gnat_type);
2085 tree gnu_low = TYPE_MIN_VALUE (gnu_type);
2086 tree gnu_high = TYPE_MAX_VALUE (gnu_type);
2087 tree gnu_first, gnu_last, gnu_limit;
2088 enum tree_code update_code, end_code;
2089 tree gnu_base_type = get_base_type (gnu_type);
2091 /* We must disable modulo reduction for the loop variable, if any,
2092 in order for the loop comparison to be effective. */
2093 if (Reverse_Present (gnat_loop_spec))
2095 gnu_first = gnu_high;
2097 update_code = MINUS_NOMOD_EXPR;
2099 gnu_limit = TYPE_MIN_VALUE (gnu_base_type);
2103 gnu_first = gnu_low;
2104 gnu_last = gnu_high;
2105 update_code = PLUS_NOMOD_EXPR;
2107 gnu_limit = TYPE_MAX_VALUE (gnu_base_type);
2110 /* We know the loop variable will not overflow if GNU_LAST is a constant
2111 and is not equal to GNU_LIMIT. If it might overflow, we have to move
2112 the limit test to the end of the loop. In that case, we have to test
2113 for an empty loop outside the loop. */
2114 if (TREE_CODE (gnu_last) != INTEGER_CST
2115 || TREE_CODE (gnu_limit) != INTEGER_CST
2116 || tree_int_cst_equal (gnu_last, gnu_limit))
2119 = build3 (COND_EXPR, void_type_node,
2120 build_binary_op (LE_EXPR, integer_type_node,
2122 NULL_TREE, alloc_stmt_list ());
2123 set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
2126 /* Open a new nesting level that will surround the loop to declare the
2127 loop index variable. */
2128 start_stmt_group ();
2131 /* Declare the loop index and set it to its initial value. */
2132 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
2133 if (DECL_BY_REF_P (gnu_loop_var))
2134 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
2136 /* The loop variable might be a padded type, so use `convert' to get a
2137 reference to the inner variable if so. */
2138 gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
2140 /* Set either the top or bottom exit condition as appropriate depending
2141 on whether or not we know an overflow cannot occur. */
2143 LOOP_STMT_BOT_COND (gnu_loop_stmt)
2144 = build_binary_op (NE_EXPR, integer_type_node,
2145 gnu_loop_var, gnu_last);
2147 LOOP_STMT_TOP_COND (gnu_loop_stmt)
2148 = build_binary_op (end_code, integer_type_node,
2149 gnu_loop_var, gnu_last);
2151 LOOP_STMT_UPDATE (gnu_loop_stmt)
2152 = build_binary_op (MODIFY_EXPR, NULL_TREE,
2154 build_binary_op (update_code,
2155 TREE_TYPE (gnu_loop_var),
2157 convert (TREE_TYPE (gnu_loop_var),
2158 integer_one_node)));
2159 set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
2163 /* If the loop was named, have the name point to this loop. In this case,
2164 the association is not a ..._DECL node, but the end label from this
2166 if (Present (Identifier (gnat_node)))
2167 save_gnu_tree (Entity (Identifier (gnat_node)),
2168 LOOP_STMT_LABEL (gnu_loop_stmt), true);
2170 /* Make the loop body into its own block, so any allocated storage will be
2171 released every iteration. This is needed for stack allocation. */
2172 LOOP_STMT_BODY (gnu_loop_stmt)
2173 = build_stmt_group (Statements (gnat_node), true);
2175 /* If we declared a variable, then we are in a statement group for that
2176 declaration. Add the LOOP_STMT to it and make that the "loop". */
2179 add_stmt (gnu_loop_stmt);
2181 gnu_loop_stmt = end_stmt_group ();
2184 /* If we have an outer COND_EXPR, that's our result and this loop is its
2185 "true" statement. Otherwise, the result is the LOOP_STMT. */
2188 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
2189 gnu_result = gnu_cond_expr;
2190 recalculate_side_effects (gnu_cond_expr);
2193 gnu_result = gnu_loop_stmt;
2195 pop_stack (&gnu_loop_label_stack);
2200 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
2201 handler for the current function. */
2203 /* This is implemented by issuing a call to the appropriate VMS specific
2204 builtin. To avoid having VMS specific sections in the global gigi decls
2205 array, we maintain the decls of interest here. We can't declare them
2206 inside the function because we must mark them never to be GC'd, which we
2207 can only do at the global level. */
2209 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
2210 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
2213 establish_gnat_vms_condition_handler (void)
2215 tree establish_stmt;
2217 /* Elaborate the required decls on the first call. Check on the decl for
2218 the gnat condition handler to decide, as this is one we create so we are
2219 sure that it will be non null on subsequent calls. The builtin decl is
2220 looked up so remains null on targets where it is not implemented yet. */
2221 if (gnat_vms_condition_handler_decl == NULL_TREE)
2223 vms_builtin_establish_handler_decl
2225 (get_identifier ("__builtin_establish_vms_condition_handler"));
2227 gnat_vms_condition_handler_decl
2228 = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
2230 build_function_type_list (integer_type_node,
2234 NULL_TREE, 0, 1, 1, 0, Empty);
2236 /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */
2237 DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
2240 /* Do nothing if the establish builtin is not available, which might happen
2241 on targets where the facility is not implemented. */
2242 if (vms_builtin_establish_handler_decl == NULL_TREE)
2246 = build_call_1_expr (vms_builtin_establish_handler_decl,
2248 (ADDR_EXPR, NULL_TREE,
2249 gnat_vms_condition_handler_decl));
2251 add_stmt (establish_stmt);
2254 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
2255 don't return anything. */
2258 Subprogram_Body_to_gnu (Node_Id gnat_node)
2260 /* Defining identifier of a parameter to the subprogram. */
2261 Entity_Id gnat_param;
2262 /* The defining identifier for the subprogram body. Note that if a
2263 specification has appeared before for this body, then the identifier
2264 occurring in that specification will also be a defining identifier and all
2265 the calls to this subprogram will point to that specification. */
2266 Entity_Id gnat_subprog_id
2267 = (Present (Corresponding_Spec (gnat_node))
2268 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
2269 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
2270 tree gnu_subprog_decl;
2271 /* Its RESULT_DECL node. */
2272 tree gnu_result_decl;
2273 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
2274 tree gnu_subprog_type;
2277 VEC(parm_attr,gc) *cache;
2279 /* If this is a generic object or if it has been eliminated,
2281 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
2282 || Ekind (gnat_subprog_id) == E_Generic_Function
2283 || Is_Eliminated (gnat_subprog_id))
2286 /* If this subprogram acts as its own spec, define it. Otherwise, just get
2287 the already-elaborated tree node. However, if this subprogram had its
2288 elaboration deferred, we will already have made a tree node for it. So
2289 treat it as not being defined in that case. Such a subprogram cannot
2290 have an address clause or a freeze node, so this test is safe, though it
2291 does disable some otherwise-useful error checking. */
2293 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
2294 Acts_As_Spec (gnat_node)
2295 && !present_gnu_tree (gnat_subprog_id));
2296 gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
2297 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
2299 /* If the function returns by invisible reference, make it explicit in the
2300 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
2301 if (TREE_ADDRESSABLE (gnu_subprog_type))
2303 TREE_TYPE (gnu_result_decl)
2304 = build_reference_type (TREE_TYPE (gnu_result_decl));
2305 relayout_decl (gnu_result_decl);
2308 /* Propagate the debug mode. */
2309 if (!Needs_Debug_Info (gnat_subprog_id))
2310 DECL_IGNORED_P (gnu_subprog_decl) = 1;
2312 /* Set the line number in the decl to correspond to that of the body so that
2313 the line number notes are written correctly. */
2314 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
2316 /* Initialize the information structure for the function. */
2317 allocate_struct_function (gnu_subprog_decl, false);
2318 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
2319 = GGC_CNEW (struct language_function);
2321 begin_subprog_body (gnu_subprog_decl);
2322 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2324 /* If there are Out parameters, we need to ensure that the return statement
2325 properly copies them out. We do this by making a new block and converting
2326 any inner return into a goto to a label at the end of the block. */
2327 push_stack (&gnu_return_label_stack, NULL_TREE,
2328 gnu_cico_list ? create_artificial_label (input_location)
2331 /* Get a tree corresponding to the code for the subprogram. */
2332 start_stmt_group ();
2335 /* See if there are any parameters for which we don't yet have GCC entities.
2336 These must be for Out parameters for which we will be making VAR_DECL
2337 nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty
2338 entry as well. We can match up the entries because TYPE_CI_CO_LIST is in
2339 the order of the parameters. */
2340 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2341 Present (gnat_param);
2342 gnat_param = Next_Formal_With_Extras (gnat_param))
2343 if (!present_gnu_tree (gnat_param))
2345 /* Skip any entries that have been already filled in; they must
2346 correspond to In Out parameters. */
2347 for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
2348 gnu_cico_list = TREE_CHAIN (gnu_cico_list))
2351 /* Do any needed references for padded types. */
2352 TREE_VALUE (gnu_cico_list)
2353 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
2354 gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
2357 /* On VMS, establish our condition handler to possibly turn a condition into
2358 the corresponding exception if the subprogram has a foreign convention or
2361 To ensure proper execution of local finalizations on condition instances,
2362 we must turn a condition into the corresponding exception even if there
2363 is no applicable Ada handler, and need at least one condition handler per
2364 possible call chain involving GNAT code. OTOH, establishing the handler
2365 has a cost so we want to minimize the number of subprograms into which
2366 this happens. The foreign or exported condition is expected to satisfy
2367 all the constraints. */
2368 if (TARGET_ABI_OPEN_VMS
2369 && (Has_Foreign_Convention (gnat_subprog_id)
2370 || Is_Exported (gnat_subprog_id)))
2371 establish_gnat_vms_condition_handler ();
2373 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
2375 /* Generate the code of the subprogram itself. A return statement will be
2376 present and any Out parameters will be handled there. */
2377 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
2379 gnu_result = end_stmt_group ();
2381 /* If we populated the parameter attributes cache, we need to make sure
2382 that the cached expressions are evaluated on all possible paths. */
2383 cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
2386 struct parm_attr_d *pa;
2389 start_stmt_group ();
2391 for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
2394 add_stmt_with_node (pa->first, gnat_node);
2396 add_stmt_with_node (pa->last, gnat_node);
2398 add_stmt_with_node (pa->length, gnat_node);
2401 add_stmt (gnu_result);
2402 gnu_result = end_stmt_group ();
2405 /* If we are dealing with a return from an Ada procedure with parameters
2406 passed by copy-in/copy-out, we need to return a record containing the
2407 final values of these parameters. If the list contains only one entry,
2408 return just that entry though.
2410 For a full description of the copy-in/copy-out parameter mechanism, see
2411 the part of the gnat_to_gnu_entity routine dealing with the translation
2414 We need to make a block that contains the definition of that label and
2415 the copying of the return value. It first contains the function, then
2416 the label and copy statement. */
2417 if (TREE_VALUE (gnu_return_label_stack))
2421 start_stmt_group ();
2423 add_stmt (gnu_result);
2424 add_stmt (build1 (LABEL_EXPR, void_type_node,
2425 TREE_VALUE (gnu_return_label_stack)));
2427 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2428 if (list_length (gnu_cico_list) == 1)
2429 gnu_retval = TREE_VALUE (gnu_cico_list);
2431 gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
2434 add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
2435 End_Label (Handled_Statement_Sequence (gnat_node)));
2437 gnu_result = end_stmt_group ();
2440 pop_stack (&gnu_return_label_stack);
2442 /* Set the end location. */
2444 ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
2445 ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
2446 : Sloc (gnat_node)),
2447 &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
2449 end_subprog_body (gnu_result);
2451 /* Finally annotate the parameters and disconnect the trees for parameters
2452 that we have turned into variables since they are now unusable. */
2453 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
2454 Present (gnat_param);
2455 gnat_param = Next_Formal_With_Extras (gnat_param))
2457 tree gnu_param = get_gnu_tree (gnat_param);
2458 annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
2459 DECL_BY_REF_P (gnu_param));
2460 if (TREE_CODE (gnu_param) == VAR_DECL)
2461 save_gnu_tree (gnat_param, NULL_TREE, false);
2464 if (DECL_FUNCTION_STUB (gnu_subprog_decl))
2465 build_function_stub (gnu_subprog_decl, gnat_subprog_id);
2467 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
2470 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
2471 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
2472 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
2473 If GNU_TARGET is non-null, this must be a function call on the RHS of a
2474 N_Assignment_Statement and the result is to be placed into that object. */
2477 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
2479 /* The GCC node corresponding to the GNAT subprogram name. This can either
2480 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
2481 or an indirect reference expression (an INDIRECT_REF node) pointing to a
2483 tree gnu_subprog = gnat_to_gnu (Name (gnat_node));
2484 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
2485 tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
2486 tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
2487 Entity_Id gnat_formal;
2488 Node_Id gnat_actual;
2489 tree gnu_actual_list = NULL_TREE;
2490 tree gnu_name_list = NULL_TREE;
2491 tree gnu_before_list = NULL_TREE;
2492 tree gnu_after_list = NULL_TREE;
2494 bool went_into_elab_proc = false;
2496 gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
2498 /* If we are calling a stubbed function, raise Program_Error, but Elaborate
2499 all our args first. */
2500 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
2502 tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
2503 gnat_node, N_Raise_Program_Error);
2505 for (gnat_actual = First_Actual (gnat_node);
2506 Present (gnat_actual);
2507 gnat_actual = Next_Actual (gnat_actual))
2508 add_stmt (gnat_to_gnu (gnat_actual));
2510 if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
2512 *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
2513 return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr);
2519 /* The only way we can be making a call via an access type is if Name is an
2520 explicit dereference. In that case, get the list of formal args from the
2521 type the access type is pointing to. Otherwise, get the formals from the
2522 entity being called. */
2523 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2524 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2525 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
2526 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2527 gnat_formal = Empty;
2529 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2531 /* If we are translating a statement, open a new nesting level that will
2532 surround it to declare the temporaries created for the call. */
2533 if (Nkind (gnat_node) == N_Procedure_Call_Statement || gnu_target)
2535 start_stmt_group ();
2539 /* The lifetime of the temporaries created for the call ends with the call
2540 so we can give them the scope of the elaboration routine at top level. */
2541 else if (!current_function_decl)
2543 current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
2544 went_into_elab_proc = true;
2547 /* Create the list of the actual parameters as GCC expects it, namely a
2548 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
2549 is an expression and the TREE_PURPOSE field is null. But skip Out
2550 parameters not passed by reference and that need not be copied in. */
2551 for (gnat_actual = First_Actual (gnat_node);
2552 Present (gnat_actual);
2553 gnat_formal = Next_Formal_With_Extras (gnat_formal),
2554 gnat_actual = Next_Actual (gnat_actual))
2556 tree gnu_formal = present_gnu_tree (gnat_formal)
2557 ? get_gnu_tree (gnat_formal) : NULL_TREE;
2558 tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2559 /* In the Out or In Out case, we must suppress conversions that yield
2560 an lvalue but can nevertheless cause the creation of a temporary,
2561 because we need the real object in this case, either to pass its
2562 address if it's passed by reference or as target of the back copy
2563 done after the call if it uses the copy-in copy-out mechanism.
2564 We do it in the In case too, except for an unchecked conversion
2565 because it alone can cause the actual to be misaligned and the
2566 addressability test is applied to the real object. */
2567 bool suppress_type_conversion
2568 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2569 && Ekind (gnat_formal) != E_In_Parameter)
2570 || (Nkind (gnat_actual) == N_Type_Conversion
2571 && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2572 Node_Id gnat_name = suppress_type_conversion
2573 ? Expression (gnat_actual) : gnat_actual;
2574 tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
2577 /* If it's possible we may need to use this expression twice, make sure
2578 that any side-effects are handled via SAVE_EXPRs; likewise if we need
2579 to force side-effects before the call.
2580 ??? This is more conservative than we need since we don't need to do
2581 this for pass-by-ref with no conversion. */
2582 if (Ekind (gnat_formal) != E_In_Parameter)
2583 gnu_name = gnat_stabilize_reference (gnu_name, true, NULL);
2585 /* If we are passing a non-addressable parameter by reference, pass the
2586 address of a copy. In the Out or In Out case, set up to copy back
2587 out after the call. */
2589 && (DECL_BY_REF_P (gnu_formal)
2590 || (TREE_CODE (gnu_formal) == PARM_DECL
2591 && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2592 || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
2593 && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
2594 && !addressable_p (gnu_name, gnu_name_type))
2596 tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
2598 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
2599 but sort of an instantiation for them. */
2600 if (TREE_CODE (gnu_name) == CONSTRUCTOR)
2603 /* If the type is passed by reference, a copy is not allowed. */
2604 else if (TREE_ADDRESSABLE (gnu_formal_type))
2605 post_error ("misaligned actual cannot be passed by reference",
2608 /* For users of Starlet we issue a warning because the interface
2609 apparently assumes that by-ref parameters outlive the procedure
2610 invocation. The code still will not work as intended, but we
2611 cannot do much better since low-level parts of the back-end
2612 would allocate temporaries at will because of the misalignment
2613 if we did not do so here. */
2614 else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
2617 ("?possible violation of implicit assumption", gnat_actual);
2619 ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
2620 Entity (Name (gnat_node)));
2621 post_error_ne ("?because of misalignment of &", gnat_actual,
2625 /* If the actual type of the object is already the nominal type,
2626 we have nothing to do, except if the size is self-referential
2627 in which case we'll remove the unpadding below. */
2628 if (TREE_TYPE (gnu_name) == gnu_name_type
2629 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
2632 /* Otherwise remove the unpadding from all the objects. */
2633 else if (TREE_CODE (gnu_name) == COMPONENT_REF
2634 && TYPE_IS_PADDING_P
2635 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
2636 gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
2638 /* Otherwise convert to the nominal type of the object if it's
2639 a record type. There are several cases in which we need to
2640 make the temporary using this type instead of the actual type
2641 of the object if they are distinct, because the expectations
2642 of the callee would otherwise not be met:
2643 - if it's a justified modular type,
2644 - if the actual type is a smaller packable version of it. */
2645 else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
2646 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
2647 || smaller_packable_type_p (TREE_TYPE (gnu_name),
2649 gnu_name = convert (gnu_name_type, gnu_name);
2651 /* Create an explicit temporary holding the copy. This ensures that
2652 its lifetime is as narrow as possible around a statement. */
2653 gnu_temp = create_var_decl (create_tmp_var_name ("A"), NULL_TREE,
2654 TREE_TYPE (gnu_name), NULL_TREE, false,
2655 false, false, false, NULL, Empty);
2656 DECL_ARTIFICIAL (gnu_temp) = 1;
2657 DECL_IGNORED_P (gnu_temp) = 1;
2659 /* But initialize it on the fly like for an implicit temporary as
2660 we aren't necessarily dealing with a statement. */
2662 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_name);
2663 set_expr_location_from_node (gnu_stmt, gnat_actual);
2665 /* From now on, the real object is the temporary. */
2666 gnu_name = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_name), gnu_stmt,
2669 /* Set up to move the copy back to the original if needed. */
2670 if (Ekind (gnat_formal) != E_In_Parameter)
2672 gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
2674 set_expr_location_from_node (gnu_stmt, gnat_node);
2675 append_to_statement_list (gnu_stmt, &gnu_after_list);
2679 /* Start from the real object and build the actual. */
2680 gnu_actual = gnu_name;
2682 /* If this was a procedure call, we may not have removed any padding.
2683 So do it here for the part we will use as an input, if any. */
2684 if (Ekind (gnat_formal) != E_Out_Parameter
2685 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2687 = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
2689 /* Put back the conversion we suppressed above in the computation of the
2690 real object. And even if we didn't suppress any conversion there, we
2691 may have suppressed a conversion to the Etype of the actual earlier,
2692 since the parent is a procedure call, so put it back here. */
2693 if (suppress_type_conversion
2694 && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2696 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2697 gnu_actual, No_Truncation (gnat_actual));
2700 = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
2702 /* Make sure that the actual is in range of the formal's type. */
2703 if (Ekind (gnat_formal) != E_Out_Parameter
2704 && Do_Range_Check (gnat_actual))
2706 = emit_range_check (gnu_actual, Etype (gnat_formal), gnat_actual);
2708 /* Unless this is an In parameter, we must remove any justified modular
2709 building from GNU_NAME to get an lvalue. */
2710 if (Ekind (gnat_formal) != E_In_Parameter
2711 && TREE_CODE (gnu_name) == CONSTRUCTOR
2712 && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
2713 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
2715 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name);
2717 /* If we have not saved a GCC object for the formal, it means it is an
2718 Out parameter not passed by reference and that need not be copied in.
2719 Otherwise, first see if the parameter is passed by reference. */
2721 && TREE_CODE (gnu_formal) == PARM_DECL
2722 && DECL_BY_REF_P (gnu_formal))
2724 if (Ekind (gnat_formal) != E_In_Parameter)
2726 /* In Out or Out parameters passed by reference don't use the
2727 copy-in copy-out mechanism so the address of the real object
2728 must be passed to the function. */
2729 gnu_actual = gnu_name;
2731 /* If we have a padded type, be sure we've removed padding. */
2732 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2733 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2736 /* If we have the constructed subtype of an aliased object
2737 with an unconstrained nominal subtype, the type of the
2738 actual includes the template, although it is formally
2739 constrained. So we need to convert it back to the real
2740 constructed subtype to retrieve the constrained part
2741 and takes its address. */
2742 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2743 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
2744 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
2745 && Is_Array_Type (Etype (gnat_actual)))
2746 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2750 /* There is no need to convert the actual to the formal's type before
2751 taking its address. The only exception is for unconstrained array
2752 types because of the way we build fat pointers. */
2753 else if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
2754 gnu_actual = convert (gnu_formal_type, gnu_actual);
2756 /* The symmetry of the paths to the type of an entity is broken here
2757 since arguments don't know that they will be passed by ref. */
2758 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2759 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2762 && TREE_CODE (gnu_formal) == PARM_DECL
2763 && DECL_BY_COMPONENT_PTR_P (gnu_formal))
2765 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2766 gnu_actual = maybe_implicit_deref (gnu_actual);
2767 gnu_actual = maybe_unconstrained_array (gnu_actual);
2769 if (TYPE_IS_PADDING_P (gnu_formal_type))
2771 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
2772 gnu_actual = convert (gnu_formal_type, gnu_actual);
2775 /* Take the address of the object and convert to the proper pointer
2776 type. We'd like to actually compute the address of the beginning
2777 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
2778 possibility that the ARRAY_REF might return a constant and we'd be
2779 getting the wrong address. Neither approach is exactly correct,
2780 but this is the most likely to work in all cases. */
2781 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2784 && TREE_CODE (gnu_formal) == PARM_DECL
2785 && DECL_BY_DESCRIPTOR_P (gnu_formal))
2787 gnu_actual = convert (gnu_formal_type, gnu_actual);
2789 /* If this is 'Null_Parameter, pass a zero descriptor. */
2790 if ((TREE_CODE (gnu_actual) == INDIRECT_REF
2791 || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
2792 && TREE_PRIVATE (gnu_actual))
2794 = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
2796 gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
2797 fill_vms_descriptor (gnu_actual,
2805 if (Ekind (gnat_formal) != E_In_Parameter)
2806 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
2808 if (!(gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL))
2810 /* Make sure side-effects are evaluated before the call. */
2811 if (TREE_SIDE_EFFECTS (gnu_name))
2812 append_to_statement_list (gnu_name, &gnu_before_list);
2816 gnu_actual = convert (gnu_formal_type, gnu_actual);
2818 /* If this is 'Null_Parameter, pass a zero even though we are
2819 dereferencing it. */
2820 if (TREE_CODE (gnu_actual) == INDIRECT_REF
2821 && TREE_PRIVATE (gnu_actual)
2822 && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
2823 && TREE_CODE (gnu_size) == INTEGER_CST
2824 && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
2826 = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
2827 convert (gnat_type_for_size
2828 (TREE_INT_CST_LOW (gnu_size), 1),
2832 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
2835 gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
2838 gnu_call = build_call_list (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr,
2839 nreverse (gnu_actual_list));
2840 set_expr_location_from_node (gnu_call, gnat_node);
2842 /* If it's a function call, the result is the call expression unless a target
2843 is specified, in which case we copy the result into the target and return
2844 the assignment statement. */
2845 if (Nkind (gnat_node) == N_Function_Call)
2847 tree gnu_result = gnu_call;
2849 /* If the function returns an unconstrained array or by direct reference,
2850 we have to dereference the pointer. */
2851 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
2852 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
2853 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2857 Node_Id gnat_parent = Parent (gnat_node);
2858 enum tree_code op_code;
2860 /* If range check is needed, emit code to generate it. */
2861 if (Do_Range_Check (gnat_node))
2863 = emit_range_check (gnu_result, Etype (Name (gnat_parent)),
2866 /* ??? If the return type has non-constant size, then force the
2867 return slot optimization as we would not be able to generate
2868 a temporary. That's what has been done historically. */
2869 if (TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_subprog_type))))
2870 op_code = MODIFY_EXPR;
2872 op_code = INIT_EXPR;
2875 = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_result);
2876 add_stmt_with_node (gnu_result, gnat_parent);
2878 gnu_result = end_stmt_group ();
2882 if (went_into_elab_proc)
2883 current_function_decl = NULL_TREE;
2884 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
2890 /* If this is the case where the GNAT tree contains a procedure call but the
2891 Ada procedure has copy-in/copy-out parameters, then the special parameter
2892 passing mechanism must be used. */
2893 if (TYPE_CI_CO_LIST (gnu_subprog_type))
2895 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
2896 copy-out parameters. */
2897 tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2898 const int length = list_length (gnu_cico_list);
2902 tree gnu_temp, gnu_stmt;
2904 /* The call sequence must contain one and only one call, even though
2905 the function is pure. Save the result into a temporary. */
2906 gnu_temp = create_var_decl (create_tmp_var_name ("R"), NULL_TREE,
2907 TREE_TYPE (gnu_call), NULL_TREE, false,
2908 false, false, false, NULL, Empty);
2909 DECL_ARTIFICIAL (gnu_temp) = 1;
2910 DECL_IGNORED_P (gnu_temp) = 1;
2913 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_call);
2914 set_expr_location_from_node (gnu_stmt, gnat_node);
2916 /* Add the call statement to the list and start from its result. */
2917 append_to_statement_list (gnu_stmt, &gnu_before_list);
2918 gnu_call = gnu_temp;
2920 gnu_name_list = nreverse (gnu_name_list);
2923 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2924 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2926 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2928 for (gnat_actual = First_Actual (gnat_node);
2929 Present (gnat_actual);
2930 gnat_formal = Next_Formal_With_Extras (gnat_formal),
2931 gnat_actual = Next_Actual (gnat_actual))
2932 /* If we are dealing with a copy in copy out parameter, we must
2933 retrieve its value from the record returned in the call. */
2934 if (!(present_gnu_tree (gnat_formal)
2935 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2936 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2937 || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2938 && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
2939 || (DECL_BY_DESCRIPTOR_P
2940 (get_gnu_tree (gnat_formal))))))))
2941 && Ekind (gnat_formal) != E_In_Parameter)
2943 /* Get the value to assign to this Out or In Out parameter. It is
2944 either the result of the function if there is only a single such
2945 parameter or the appropriate field from the record returned. */
2949 : build_component_ref (gnu_call, NULL_TREE,
2950 TREE_PURPOSE (gnu_cico_list), false);
2952 /* If the actual is a conversion, get the inner expression, which
2953 will be the real destination, and convert the result to the
2954 type of the actual parameter. */
2956 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
2958 /* If the result is a padded type, remove the padding. */
2959 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
2961 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
2964 /* If the actual is a type conversion, the real target object is
2965 denoted by the inner Expression and we need to convert the
2966 result to the associated type.
2967 We also need to convert our gnu assignment target to this type
2968 if the corresponding GNU_NAME was constructed from the GNAT
2969 conversion node and not from the inner Expression. */
2970 if (Nkind (gnat_actual) == N_Type_Conversion)
2973 = convert_with_check
2974 (Etype (Expression (gnat_actual)), gnu_result,
2975 Do_Overflow_Check (gnat_actual),
2976 Do_Range_Check (Expression (gnat_actual)),
2977 Float_Truncate (gnat_actual), gnat_actual);
2979 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
2980 gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
2983 /* Unchecked conversions as actuals for Out parameters are not
2984 allowed in user code because they are not variables, but do
2985 occur in front-end expansions. The associated GNU_NAME is
2986 always obtained from the inner expression in such cases. */
2987 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2988 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
2990 No_Truncation (gnat_actual));
2993 if (Do_Range_Check (gnat_actual))
2995 = emit_range_check (gnu_result, Etype (gnat_actual),
2998 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
2999 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
3000 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
3003 /* Undo wrapping of boolean rvalues. */
3004 if (TREE_CODE (gnu_actual) == NE_EXPR
3005 && TREE_CODE (get_base_type (TREE_TYPE (gnu_actual)))
3007 && integer_zerop (TREE_OPERAND (gnu_actual, 1)))
3008 gnu_actual = TREE_OPERAND (gnu_actual, 0);
3009 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
3010 gnu_actual, gnu_result);
3011 set_expr_location_from_node (gnu_result, gnat_node);
3012 append_to_statement_list (gnu_result, &gnu_before_list);
3013 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
3014 gnu_name_list = TREE_CHAIN (gnu_name_list);
3018 append_to_statement_list (gnu_call, &gnu_before_list);
3020 append_to_statement_list (gnu_after_list, &gnu_before_list);
3022 add_stmt (gnu_before_list);
3024 return end_stmt_group ();
3027 /* Subroutine of gnat_to_gnu to translate gnat_node, an
3028 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
3031 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
3033 tree gnu_jmpsave_decl = NULL_TREE;
3034 tree gnu_jmpbuf_decl = NULL_TREE;
3035 /* If just annotating, ignore all EH and cleanups. */
3036 bool gcc_zcx = (!type_annotate_only
3037 && Present (Exception_Handlers (gnat_node))
3038 && Exception_Mechanism == Back_End_Exceptions);
3040 = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
3041 && Exception_Mechanism == Setjmp_Longjmp);
3042 bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
3043 bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
3044 tree gnu_inner_block; /* The statement(s) for the block itself. */
3049 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
3050 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
3051 add_cleanup, and when we leave the binding, end_stmt_group will create
3052 the TRY_FINALLY_EXPR.
3054 ??? The region level calls down there have been specifically put in place
3055 for a ZCX context and currently the order in which things are emitted
3056 (region/handlers) is different from the SJLJ case. Instead of putting
3057 other calls with different conditions at other places for the SJLJ case,
3058 it seems cleaner to reorder things for the SJLJ case and generalize the
3059 condition to make it not ZCX specific.
3061 If there are any exceptions or cleanup processing involved, we need an
3062 outer statement group (for Setjmp_Longjmp) and binding level. */
3063 if (binding_for_block)
3065 start_stmt_group ();
3069 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
3070 area for address of previous buffer. Do this first since we need to have
3071 the setjmp buf known for any decls in this block. */
3074 gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
3075 NULL_TREE, jmpbuf_ptr_type,
3076 build_call_0_expr (get_jmpbuf_decl),
3077 false, false, false, false, NULL,
3079 DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
3081 /* The __builtin_setjmp receivers will immediately reinstall it. Now
3082 because of the unstructured form of EH used by setjmp_longjmp, there
3083 might be forward edges going to __builtin_setjmp receivers on which
3084 it is uninitialized, although they will never be actually taken. */
3085 TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
3086 gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
3087 NULL_TREE, jmpbuf_type,
3088 NULL_TREE, false, false, false, false,
3090 DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
3092 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
3094 /* When we exit this block, restore the saved value. */
3095 add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
3096 End_Label (gnat_node));
3099 /* If we are to call a function when exiting this block, add a cleanup
3100 to the binding level we made above. Note that add_cleanup is FIFO
3101 so we must register this cleanup after the EH cleanup just above. */
3103 add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
3104 End_Label (gnat_node));
3106 /* Now build the tree for the declarations and statements inside this block.
3107 If this is SJLJ, set our jmp_buf as the current buffer. */
3108 start_stmt_group ();
3111 add_stmt (build_call_1_expr (set_jmpbuf_decl,
3112 build_unary_op (ADDR_EXPR, NULL_TREE,
3115 if (Present (First_Real_Statement (gnat_node)))
3116 process_decls (Statements (gnat_node), Empty,
3117 First_Real_Statement (gnat_node), true, true);
3119 /* Generate code for each statement in the block. */
3120 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
3121 ? First_Real_Statement (gnat_node)
3122 : First (Statements (gnat_node)));
3123 Present (gnat_temp); gnat_temp = Next (gnat_temp))
3124 add_stmt (gnat_to_gnu (gnat_temp));
3125 gnu_inner_block = end_stmt_group ();
3127 /* Now generate code for the two exception models, if either is relevant for
3131 tree *gnu_else_ptr = 0;
3134 /* Make a binding level for the exception handling declarations and code
3135 and set up gnu_except_ptr_stack for the handlers to use. */
3136 start_stmt_group ();
3139 push_stack (&gnu_except_ptr_stack, NULL_TREE,
3140 create_var_decl (get_identifier ("EXCEPT_PTR"),
3142 build_pointer_type (except_type_node),
3143 build_call_0_expr (get_excptr_decl), false,
3144 false, false, false, NULL, gnat_node));
3146 /* Generate code for each handler. The N_Exception_Handler case does the
3147 real work and returns a COND_EXPR for each handler, which we chain
3149 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3150 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
3152 gnu_expr = gnat_to_gnu (gnat_temp);
3154 /* If this is the first one, set it as the outer one. Otherwise,
3155 point the "else" part of the previous handler to us. Then point
3156 to our "else" part. */
3158 add_stmt (gnu_expr);
3160 *gnu_else_ptr = gnu_expr;
3162 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3165 /* If none of the exception handlers did anything, re-raise but do not
3167 gnu_expr = build_call_1_expr (raise_nodefer_decl,
3168 TREE_VALUE (gnu_except_ptr_stack));
3169 set_expr_location_from_node
3171 Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
3174 *gnu_else_ptr = gnu_expr;
3176 add_stmt (gnu_expr);
3178 /* End the binding level dedicated to the exception handlers and get the
3179 whole statement group. */
3180 pop_stack (&gnu_except_ptr_stack);
3182 gnu_handler = end_stmt_group ();
3184 /* If the setjmp returns 1, we restore our incoming longjmp value and
3185 then check the handlers. */
3186 start_stmt_group ();
3187 add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
3190 add_stmt (gnu_handler);
3191 gnu_handler = end_stmt_group ();
3193 /* This block is now "if (setjmp) ... <handlers> else <block>". */
3194 gnu_result = build3 (COND_EXPR, void_type_node,
3197 build_unary_op (ADDR_EXPR, NULL_TREE,
3199 gnu_handler, gnu_inner_block);
3205 /* First make a block containing the handlers. */
3206 start_stmt_group ();
3207 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
3208 Present (gnat_temp);
3209 gnat_temp = Next_Non_Pragma (gnat_temp))
3210 add_stmt (gnat_to_gnu (gnat_temp));
3211 gnu_handlers = end_stmt_group ();
3213 /* Now make the TRY_CATCH_EXPR for the block. */
3214 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
3215 gnu_inner_block, gnu_handlers);
3218 gnu_result = gnu_inner_block;
3220 /* Now close our outer block, if we had to make one. */
3221 if (binding_for_block)
3223 add_stmt (gnu_result);
3225 gnu_result = end_stmt_group ();
3231 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3232 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
3233 exception handling. */
3236 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
3238 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
3239 an "if" statement to select the proper exceptions. For "Others", exclude
3240 exceptions where Handled_By_Others is nonzero unless the All_Others flag
3241 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
3242 tree gnu_choice = integer_zero_node;
3243 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
3246 for (gnat_temp = First (Exception_Choices (gnat_node));
3247 gnat_temp; gnat_temp = Next (gnat_temp))
3251 if (Nkind (gnat_temp) == N_Others_Choice)
3253 if (All_Others (gnat_temp))
3254 this_choice = integer_one_node;
3258 (EQ_EXPR, integer_type_node,
3263 (INDIRECT_REF, NULL_TREE,
3264 TREE_VALUE (gnu_except_ptr_stack)),
3265 get_identifier ("not_handled_by_others"), NULL_TREE,
3270 else if (Nkind (gnat_temp) == N_Identifier
3271 || Nkind (gnat_temp) == N_Expanded_Name)
3273 Entity_Id gnat_ex_id = Entity (gnat_temp);
3276 /* Exception may be a renaming. Recover original exception which is
3277 the one elaborated and registered. */
3278 if (Present (Renamed_Object (gnat_ex_id)))
3279 gnat_ex_id = Renamed_Object (gnat_ex_id);
3281 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3285 (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack),
3286 convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
3287 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
3289 /* If this is the distinguished exception "Non_Ada_Error" (and we are
3290 in VMS mode), also allow a non-Ada exception (a VMS condition) t
3292 if (Is_Non_Ada_Error (Entity (gnat_temp)))
3295 = build_component_ref
3296 (build_unary_op (INDIRECT_REF, NULL_TREE,
3297 TREE_VALUE (gnu_except_ptr_stack)),
3298 get_identifier ("lang"), NULL_TREE, false);
3302 (TRUTH_ORIF_EXPR, integer_type_node,
3303 build_binary_op (EQ_EXPR, integer_type_node, gnu_comp,
3304 build_int_cst (TREE_TYPE (gnu_comp), 'V')),
3311 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
3312 gnu_choice, this_choice);
3315 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
3318 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
3319 to a GCC tree, which is returned. This is the variant for ZCX. */
3322 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
3324 tree gnu_etypes_list = NULL_TREE;
3327 tree gnu_current_exc_ptr;
3328 tree gnu_incoming_exc_ptr;
3331 /* We build a TREE_LIST of nodes representing what exception types this
3332 handler can catch, with special cases for others and all others cases.
3334 Each exception type is actually identified by a pointer to the exception
3335 id, or to a dummy object for "others" and "all others". */
3336 for (gnat_temp = First (Exception_Choices (gnat_node));
3337 gnat_temp; gnat_temp = Next (gnat_temp))
3339 if (Nkind (gnat_temp) == N_Others_Choice)
3342 = All_Others (gnat_temp) ? all_others_decl : others_decl;
3345 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3347 else if (Nkind (gnat_temp) == N_Identifier
3348 || Nkind (gnat_temp) == N_Expanded_Name)
3350 Entity_Id gnat_ex_id = Entity (gnat_temp);
3352 /* Exception may be a renaming. Recover original exception which is
3353 the one elaborated and registered. */
3354 if (Present (Renamed_Object (gnat_ex_id)))
3355 gnat_ex_id = Renamed_Object (gnat_ex_id);
3357 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
3358 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
3360 /* The Non_Ada_Error case for VMS exceptions is handled
3361 by the personality routine. */
3366 /* The GCC interface expects NULL to be passed for catch all handlers, so
3367 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
3368 is integer_zero_node. It would not work, however, because GCC's
3369 notion of "catch all" is stronger than our notion of "others". Until
3370 we correctly use the cleanup interface as well, doing that would
3371 prevent the "all others" handlers from being seen, because nothing
3372 can be caught beyond a catch all from GCC's point of view. */
3373 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
3376 start_stmt_group ();
3379 /* Expand a call to the begin_handler hook at the beginning of the handler,
3380 and arrange for a call to the end_handler hook to occur on every possible
3383 The hooks expect a pointer to the low level occurrence. This is required
3384 for our stack management scheme because a raise inside the handler pushes
3385 a new occurrence on top of the stack, which means that this top does not
3386 necessarily match the occurrence this handler was dealing with.
3388 __builtin_eh_pointer references the exception occurrence being
3389 propagated. Upon handler entry, this is the exception for which the
3390 handler is triggered. This might not be the case upon handler exit,
3391 however, as we might have a new occurrence propagated by the handler's
3392 body, and the end_handler hook called as a cleanup in this context.
3394 We use a local variable to retrieve the incoming value at handler entry
3395 time, and reuse it to feed the end_handler hook's argument at exit. */
3398 = build_call_expr (built_in_decls [BUILT_IN_EH_POINTER],
3399 1, integer_zero_node);
3400 gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
3401 ptr_type_node, gnu_current_exc_ptr,
3402 false, false, false, false, NULL,
3405 add_stmt_with_node (build_call_1_expr (begin_handler_decl,
3406 gnu_incoming_exc_ptr),
3408 /* ??? We don't seem to have an End_Label at hand to set the location. */
3409 add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
3411 add_stmt_list (Statements (gnat_node));
3414 return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
3418 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
3421 Compilation_Unit_to_gnu (Node_Id gnat_node)
3423 /* Make the decl for the elaboration procedure. */
3424 bool body_p = (Defining_Entity (Unit (gnat_node)),
3425 Nkind (Unit (gnat_node)) == N_Package_Body
3426 || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
3427 Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
3428 tree gnu_elab_proc_decl
3429 = create_subprog_decl
3430 (create_concat_name (gnat_unit_entity,
3431 body_p ? "elabb" : "elabs"),
3432 NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
3434 struct elab_info *info;
3436 push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
3438 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
3439 allocate_struct_function (gnu_elab_proc_decl, false);
3440 Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
3441 current_function_decl = NULL_TREE;
3443 start_stmt_group ();
3446 /* For a body, first process the spec if there is one. */
3447 if (Nkind (Unit (gnat_node)) == N_Package_Body
3448 || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
3449 && !Acts_As_Spec (gnat_node)))
3451 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
3452 finalize_from_with_types ();
3455 process_inlined_subprograms (gnat_node);
3457 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
3459 elaborate_all_entities (gnat_node);
3461 if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
3462 || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
3463 || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
3467 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
3469 add_stmt (gnat_to_gnu (Unit (gnat_node)));
3471 /* Process any pragmas and actions following the unit. */
3472 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
3473 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
3474 finalize_from_with_types ();
3476 /* Save away what we've made so far and record this potential elaboration
3478 info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
3479 set_current_block_context (gnu_elab_proc_decl);
3481 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
3482 info->next = elab_info_list;
3483 info->elab_proc = gnu_elab_proc_decl;
3484 info->gnat_node = gnat_node;
3485 elab_info_list = info;
3487 /* Generate elaboration code for this unit, if necessary, and say whether
3489 pop_stack (&gnu_elab_proc_stack);
3491 /* Invalidate the global renaming pointers. This is necessary because
3492 stabilization of the renamed entities may create SAVE_EXPRs which
3493 have been tied to a specific elaboration routine just above. */
3494 invalidate_global_renaming_pointers ();
3497 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
3498 as gigi is concerned. This is used to avoid conversions on the LHS. */
3501 unchecked_conversion_nop (Node_Id gnat_node)
3503 Entity_Id from_type, to_type;
3505 /* The conversion must be on the LHS of an assignment or an actual parameter
3506 of a call. Otherwise, even if the conversion was essentially a no-op, it
3507 could de facto ensure type consistency and this should be preserved. */
3508 if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement
3509 && Name (Parent (gnat_node)) == gnat_node)
3510 && !(Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
3511 && Name (Parent (gnat_node)) != gnat_node))
3514 from_type = Etype (Expression (gnat_node));
3516 /* We're interested in artificial conversions generated by the front-end
3517 to make private types explicit, e.g. in Expand_Assign_Array. */
3518 if (!Is_Private_Type (from_type))
3521 from_type = Underlying_Type (from_type);
3522 to_type = Etype (gnat_node);
3524 /* The direct conversion to the underlying type is a no-op. */
3525 if (to_type == from_type)
3528 /* For an array type, the conversion to the PAT is a no-op. */
3529 if (Ekind (from_type) == E_Array_Subtype
3530 && to_type == Packed_Array_Type (from_type))
3536 /* This function is the driver of the GNAT to GCC tree transformation process.
3537 It is the entry point of the tree transformer. GNAT_NODE is the root of
3538 some GNAT tree. Return the root of the corresponding GCC tree. If this
3539 is an expression, return the GCC equivalent of the expression. If this
3540 is a statement, return the statement or add it to the current statement
3541 group, in which case anything returned is to be interpreted as occurring
3542 after anything added. */
3545 gnat_to_gnu (Node_Id gnat_node)
3547 const Node_Kind kind = Nkind (gnat_node);
3548 bool went_into_elab_proc = false;
3549 tree gnu_result = error_mark_node; /* Default to no value. */
3550 tree gnu_result_type = void_type_node;
3551 tree gnu_expr, gnu_lhs, gnu_rhs;
3554 /* Save node number for error message and set location information. */
3555 error_gnat_node = gnat_node;
3556 Sloc_to_locus (Sloc (gnat_node), &input_location);
3558 /* If this node is a statement and we are only annotating types, return an
3559 empty statement list. */
3560 if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call))
3561 return alloc_stmt_list ();
3563 /* If this node is a non-static subexpression and we are only annotating
3564 types, make this into a NULL_EXPR. */
3565 if (type_annotate_only
3566 && IN (kind, N_Subexpr)
3567 && kind != N_Identifier
3568 && !Compile_Time_Known_Value (gnat_node))
3569 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
3570 build_call_raise (CE_Range_Check_Failed, gnat_node,
3571 N_Raise_Constraint_Error));
3573 if ((IN (kind, N_Statement_Other_Than_Procedure_Call)
3574 && kind != N_Null_Statement)
3575 || kind == N_Procedure_Call_Statement
3577 || kind == N_Implicit_Label_Declaration
3578 || kind == N_Handled_Sequence_Of_Statements
3579 || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
3581 /* If this is a statement and we are at top level, it must be part of
3582 the elaboration procedure, so mark us as being in that procedure. */
3583 if (!current_function_decl)
3585 current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
3586 went_into_elab_proc = true;
3589 /* If we are in the elaboration procedure, check if we are violating a
3590 No_Elaboration_Code restriction by having a statement there. Don't
3591 check for a possible No_Elaboration_Code restriction violation on
3592 N_Handled_Sequence_Of_Statements, as we want to signal an error on
3593 every nested real statement instead. This also avoids triggering
3594 spurious errors on dummy (empty) sequences created by the front-end
3595 for package bodies in some cases. */
3596 if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
3597 && kind != N_Handled_Sequence_Of_Statements)
3598 Check_Elaboration_Code_Allowed (gnat_node);
3603 /********************************/
3604 /* Chapter 2: Lexical Elements */
3605 /********************************/
3608 case N_Expanded_Name:
3609 case N_Operator_Symbol:
3610 case N_Defining_Identifier:
3611 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
3614 case N_Integer_Literal:
3618 /* Get the type of the result, looking inside any padding and
3619 justified modular types. Then get the value in that type. */
3620 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3622 if (TREE_CODE (gnu_type) == RECORD_TYPE
3623 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
3624 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3626 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
3628 /* If the result overflows (meaning it doesn't fit in its base type),
3629 abort. We would like to check that the value is within the range
3630 of the subtype, but that causes problems with subtypes whose usage
3631 will raise Constraint_Error and with biased representation, so
3633 gcc_assert (!TREE_OVERFLOW (gnu_result));
3637 case N_Character_Literal:
3638 /* If a Entity is present, it means that this was one of the
3639 literals in a user-defined character type. In that case,
3640 just return the value in the CONST_DECL. Otherwise, use the
3641 character code. In that case, the base type should be an
3642 INTEGER_TYPE, but we won't bother checking for that. */
3643 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3644 if (Present (Entity (gnat_node)))
3645 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
3648 = build_int_cst_type
3649 (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
3652 case N_Real_Literal:
3653 /* If this is of a fixed-point type, the value we want is the
3654 value of the corresponding integer. */
3655 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
3657 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3658 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
3660 gcc_assert (!TREE_OVERFLOW (gnu_result));
3663 /* We should never see a Vax_Float type literal, since the front end
3664 is supposed to transform these using appropriate conversions. */
3665 else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
3670 Ureal ur_realval = Realval (gnat_node);
3672 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3674 /* If the real value is zero, so is the result. Otherwise,
3675 convert it to a machine number if it isn't already. That
3676 forces BASE to 0 or 2 and simplifies the rest of our logic. */
3677 if (UR_Is_Zero (ur_realval))
3678 gnu_result = convert (gnu_result_type, integer_zero_node);
3681 if (!Is_Machine_Number (gnat_node))
3683 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
3684 ur_realval, Round_Even, gnat_node);
3687 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
3689 /* If we have a base of zero, divide by the denominator.
3690 Otherwise, the base must be 2 and we scale the value, which
3691 we know can fit in the mantissa of the type (hence the use
3692 of that type above). */
3693 if (No (Rbase (ur_realval)))
3695 = build_binary_op (RDIV_EXPR,
3696 get_base_type (gnu_result_type),
3698 UI_To_gnu (Denominator (ur_realval),
3702 REAL_VALUE_TYPE tmp;
3704 gcc_assert (Rbase (ur_realval) == 2);
3705 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
3706 - UI_To_Int (Denominator (ur_realval)));
3707 gnu_result = build_real (gnu_result_type, tmp);
3711 /* Now see if we need to negate the result. Do it this way to
3712 properly handle -0. */
3713 if (UR_Is_Negative (Realval (gnat_node)))
3715 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
3721 case N_String_Literal:
3722 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3723 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
3725 String_Id gnat_string = Strval (gnat_node);
3726 int length = String_Length (gnat_string);
3729 if (length >= ALLOCA_THRESHOLD)
3730 string = XNEWVEC (char, length + 1);
3732 string = (char *) alloca (length + 1);
3734 /* Build the string with the characters in the literal. Note
3735 that Ada strings are 1-origin. */
3736 for (i = 0; i < length; i++)
3737 string[i] = Get_String_Char (gnat_string, i + 1);
3739 /* Put a null at the end of the string in case it's in a context
3740 where GCC will want to treat it as a C string. */
3743 gnu_result = build_string (length, string);
3745 /* Strings in GCC don't normally have types, but we want
3746 this to not be converted to the array type. */
3747 TREE_TYPE (gnu_result) = gnu_result_type;
3749 if (length >= ALLOCA_THRESHOLD)
3754 /* Build a list consisting of each character, then make
3756 String_Id gnat_string = Strval (gnat_node);
3757 int length = String_Length (gnat_string);
3759 tree gnu_list = NULL_TREE;
3760 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
3762 for (i = 0; i < length; i++)
3765 = tree_cons (gnu_idx,
3766 build_int_cst (TREE_TYPE (gnu_result_type),
3767 Get_String_Char (gnat_string,
3771 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
3776 = gnat_build_constructor (gnu_result_type, nreverse (gnu_list));
3781 gnu_result = Pragma_to_gnu (gnat_node);
3784 /**************************************/
3785 /* Chapter 3: Declarations and Types */
3786 /**************************************/
3788 case N_Subtype_Declaration:
3789 case N_Full_Type_Declaration:
3790 case N_Incomplete_Type_Declaration:
3791 case N_Private_Type_Declaration:
3792 case N_Private_Extension_Declaration:
3793 case N_Task_Type_Declaration:
3794 process_type (Defining_Entity (gnat_node));
3795 gnu_result = alloc_stmt_list ();
3798 case N_Object_Declaration:
3799 case N_Exception_Declaration:
3800 gnat_temp = Defining_Entity (gnat_node);
3801 gnu_result = alloc_stmt_list ();
3803 /* If we are just annotating types and this object has an unconstrained
3804 or task type, don't elaborate it. */
3805 if (type_annotate_only
3806 && (((Is_Array_Type (Etype (gnat_temp))
3807 || Is_Record_Type (Etype (gnat_temp)))
3808 && !Is_Constrained (Etype (gnat_temp)))
3809 || Is_Concurrent_Type (Etype (gnat_temp))))
3812 if (Present (Expression (gnat_node))
3813 && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
3814 && (!type_annotate_only
3815 || Compile_Time_Known_Value (Expression (gnat_node))))
3817 gnu_expr = gnat_to_gnu (Expression (gnat_node));
3818 if (Do_Range_Check (Expression (gnat_node)))
3820 = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
3822 /* If this object has its elaboration delayed, we must force
3823 evaluation of GNU_EXPR right now and save it for when the object
3825 if (Present (Freeze_Node (gnat_temp)))
3827 if ((Is_Public (gnat_temp) || global_bindings_p ())
3828 && !TREE_CONSTANT (gnu_expr))
3830 = create_var_decl (create_concat_name (gnat_temp, "init"),
3831 NULL_TREE, TREE_TYPE (gnu_expr),
3832 gnu_expr, false, Is_Public (gnat_temp),
3833 false, false, NULL, gnat_temp);
3835 gnu_expr = gnat_save_expr (gnu_expr);
3837 save_gnu_tree (gnat_node, gnu_expr, true);
3841 gnu_expr = NULL_TREE;
3843 if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
3844 gnu_expr = NULL_TREE;
3846 /* If this is a deferred constant with an address clause, we ignore the
3847 full view since the clause is on the partial view and we cannot have
3848 2 different GCC trees for the object. The only bits of the full view
3849 we will use is the initializer, but it will be directly fetched. */
3850 if (Ekind(gnat_temp) == E_Constant
3851 && Present (Address_Clause (gnat_temp))
3852 && Present (Full_View (gnat_temp)))
3853 save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
3855 if (No (Freeze_Node (gnat_temp)))
3856 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
3859 case N_Object_Renaming_Declaration:
3860 gnat_temp = Defining_Entity (gnat_node);
3862 /* Don't do anything if this renaming is handled by the front end or if
3863 we are just annotating types and this object has a composite or task
3864 type, don't elaborate it. We return the result in case it has any
3865 SAVE_EXPRs in it that need to be evaluated here. */
3866 if (!Is_Renaming_Of_Object (gnat_temp)
3867 && ! (type_annotate_only
3868 && (Is_Array_Type (Etype (gnat_temp))
3869 || Is_Record_Type (Etype (gnat_temp))
3870 || Is_Concurrent_Type (Etype (gnat_temp)))))
3872 = gnat_to_gnu_entity (gnat_temp,
3873 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
3875 gnu_result = alloc_stmt_list ();
3878 case N_Implicit_Label_Declaration:
3879 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
3880 gnu_result = alloc_stmt_list ();
3883 case N_Exception_Renaming_Declaration:
3884 case N_Number_Declaration:
3885 case N_Package_Renaming_Declaration:
3886 case N_Subprogram_Renaming_Declaration:
3887 /* These are fully handled in the front end. */
3888 gnu_result = alloc_stmt_list ();
3891 /*************************************/
3892 /* Chapter 4: Names and Expressions */
3893 /*************************************/
3895 case N_Explicit_Dereference:
3896 gnu_result = gnat_to_gnu (Prefix (gnat_node));
3897 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3898 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
3901 case N_Indexed_Component:
3903 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
3907 Node_Id *gnat_expr_array;
3909 gnu_array_object = maybe_implicit_deref (gnu_array_object);
3911 /* Convert vector inputs to their representative array type, to fit
3912 what the code below expects. */
3913 gnu_array_object = maybe_vector_array (gnu_array_object);
3915 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
3917 /* If we got a padded type, remove it too. */
3918 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
3920 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
3923 gnu_result = gnu_array_object;
3925 /* First compute the number of dimensions of the array, then
3926 fill the expression array, the order depending on whether
3927 this is a Convention_Fortran array or not. */
3928 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
3929 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
3930 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
3931 ndim++, gnu_type = TREE_TYPE (gnu_type))
3934 gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
3936 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
3937 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
3939 i--, gnat_temp = Next (gnat_temp))
3940 gnat_expr_array[i] = gnat_temp;
3942 for (i = 0, gnat_temp = First (Expressions (gnat_node));
3944 i++, gnat_temp = Next (gnat_temp))
3945 gnat_expr_array[i] = gnat_temp;
3947 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
3948 i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
3950 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
3951 gnat_temp = gnat_expr_array[i];
3952 gnu_expr = gnat_to_gnu (gnat_temp);
3954 if (Do_Range_Check (gnat_temp))
3957 (gnu_array_object, gnu_expr,
3958 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
3959 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
3962 gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
3963 gnu_result, gnu_expr);
3967 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3972 Node_Id gnat_range_node = Discrete_Range (gnat_node);
3975 gnu_result = gnat_to_gnu (Prefix (gnat_node));
3976 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3978 /* Do any implicit dereferences of the prefix and do any needed
3980 gnu_result = maybe_implicit_deref (gnu_result);
3981 gnu_result = maybe_unconstrained_array (gnu_result);
3982 gnu_type = TREE_TYPE (gnu_result);
3983 if (Do_Range_Check (gnat_range_node))
3985 /* Get the bounds of the slice. */
3987 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
3988 tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
3989 tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
3990 /* Get the permitted bounds. */
3991 tree gnu_base_index_type
3992 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
3993 tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
3994 (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result);
3995 tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR
3996 (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result);
3997 tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
3999 gnu_min_expr = gnat_protect_expr (gnu_min_expr);
4000 gnu_max_expr = gnat_protect_expr (gnu_max_expr);
4002 /* Derive a good type to convert everything to. */
4003 gnu_expr_type = get_base_type (gnu_index_type);
4005 /* Test whether the minimum slice value is too small. */
4006 gnu_expr_l = build_binary_op (LT_EXPR, integer_type_node,
4007 convert (gnu_expr_type,
4009 convert (gnu_expr_type,
4010 gnu_base_min_expr));
4012 /* Test whether the maximum slice value is too large. */
4013 gnu_expr_h = build_binary_op (GT_EXPR, integer_type_node,
4014 convert (gnu_expr_type,
4016 convert (gnu_expr_type,
4017 gnu_base_max_expr));
4019 /* Build a slice index check that returns the low bound,
4020 assuming the slice is not empty. */
4021 gnu_expr = emit_check
4022 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4023 gnu_expr_l, gnu_expr_h),
4024 gnu_min_expr, CE_Index_Check_Failed, gnat_node);
4026 /* Build a conditional expression that does the index checks and
4027 returns the low bound if the slice is not empty (max >= min),
4028 and returns the naked low bound otherwise (max < min), unless
4029 it is non-constant and the high bound is; this prevents VRP
4030 from inferring bogus ranges on the unlikely path. */
4031 gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
4032 build_binary_op (GE_EXPR, gnu_expr_type,
4033 convert (gnu_expr_type,
4035 convert (gnu_expr_type,
4038 TREE_CODE (gnu_min_expr) != INTEGER_CST
4039 && TREE_CODE (gnu_max_expr) == INTEGER_CST
4040 ? gnu_max_expr : gnu_min_expr);
4043 /* Simply return the naked low bound. */
4044 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
4046 /* If this is a slice with non-constant size of an array with constant
4047 size, set the maximum size for the allocation of temporaries. */
4048 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
4049 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
4050 TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
4052 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
4053 gnu_result, gnu_expr);
4057 case N_Selected_Component:
4059 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
4060 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
4061 Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
4064 while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
4065 || IN (Ekind (gnat_pref_type), Access_Kind))
4067 if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
4068 gnat_pref_type = Underlying_Type (gnat_pref_type);
4069 else if (IN (Ekind (gnat_pref_type), Access_Kind))
4070 gnat_pref_type = Designated_Type (gnat_pref_type);
4073 gnu_prefix = maybe_implicit_deref (gnu_prefix);
4075 /* For discriminant references in tagged types always substitute the
4076 corresponding discriminant as the actual selected component. */
4077 if (Is_Tagged_Type (gnat_pref_type))
4078 while (Present (Corresponding_Discriminant (gnat_field)))
4079 gnat_field = Corresponding_Discriminant (gnat_field);
4081 /* For discriminant references of untagged types always substitute the
4082 corresponding stored discriminant. */
4083 else if (Present (Corresponding_Discriminant (gnat_field)))
4084 gnat_field = Original_Record_Component (gnat_field);
4086 /* Handle extracting the real or imaginary part of a complex.
4087 The real part is the first field and the imaginary the last. */
4088 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
4089 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
4090 ? REALPART_EXPR : IMAGPART_EXPR,
4091 NULL_TREE, gnu_prefix);
4094 gnu_field = gnat_to_gnu_field_decl (gnat_field);
4096 /* If there are discriminants, the prefix might be evaluated more
4097 than once, which is a problem if it has side-effects. */
4098 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
4099 ? Designated_Type (Etype
4100 (Prefix (gnat_node)))
4101 : Etype (Prefix (gnat_node))))
4102 gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL);
4105 = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
4106 (Nkind (Parent (gnat_node))
4107 == N_Attribute_Reference)
4108 && lvalue_required_for_attribute_p
4109 (Parent (gnat_node)));
4112 gcc_assert (gnu_result);
4113 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4117 case N_Attribute_Reference:
4119 /* The attribute designator (like an enumeration value). */
4120 int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
4122 /* The Elab_Spec and Elab_Body attributes are special in that
4123 Prefix is a unit, not an object with a GCC equivalent. Similarly
4124 for Elaborated, since that variable isn't otherwise known. */
4125 if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
4126 return (create_subprog_decl
4127 (create_concat_name (Entity (Prefix (gnat_node)),
4128 attribute == Attr_Elab_Body
4129 ? "elabb" : "elabs"),
4130 NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL,
4133 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute);
4138 /* Like 'Access as far as we are concerned. */
4139 gnu_result = gnat_to_gnu (Prefix (gnat_node));
4140 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
4141 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4145 case N_Extension_Aggregate:
4149 /* ??? It is wrong to evaluate the type now, but there doesn't
4150 seem to be any other practical way of doing it. */
4152 gcc_assert (!Expansion_Delayed (gnat_node));
4154 gnu_aggr_type = gnu_result_type
4155 = get_unpadded_type (Etype (gnat_node));
4157 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
4158 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
4160 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
4161 else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
4162 gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
4164 if (Null_Record_Present (gnat_node))
4165 gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
4167 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
4168 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
4170 = assoc_to_constructor (Etype (gnat_node),
4171 First (Component_Associations (gnat_node)),
4173 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
4174 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
4176 Component_Type (Etype (gnat_node)));
4177 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
4180 (COMPLEX_EXPR, gnu_aggr_type,
4181 gnat_to_gnu (Expression (First
4182 (Component_Associations (gnat_node)))),
4183 gnat_to_gnu (Expression
4185 (First (Component_Associations (gnat_node))))));
4189 gnu_result = convert (gnu_result_type, gnu_result);
4194 if (TARGET_VTABLE_USES_DESCRIPTORS
4195 && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
4196 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
4197 gnu_result = null_fdesc_node;
4199 gnu_result = null_pointer_node;
4200 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4203 case N_Type_Conversion:
4204 case N_Qualified_Expression:
4205 /* Get the operand expression. */
4206 gnu_result = gnat_to_gnu (Expression (gnat_node));
4207 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4210 = convert_with_check (Etype (gnat_node), gnu_result,
4211 Do_Overflow_Check (gnat_node),
4212 Do_Range_Check (Expression (gnat_node)),
4213 kind == N_Type_Conversion
4214 && Float_Truncate (gnat_node), gnat_node);
4217 case N_Unchecked_Type_Conversion:
4218 gnu_result = gnat_to_gnu (Expression (gnat_node));
4220 /* Skip further processing if the conversion is deemed a no-op. */
4221 if (unchecked_conversion_nop (gnat_node))
4223 gnu_result_type = TREE_TYPE (gnu_result);
4227 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4229 /* If the result is a pointer type, see if we are improperly
4230 converting to a stricter alignment. */
4231 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
4232 && IN (Ekind (Etype (gnat_node)), Access_Kind))
4234 unsigned int align = known_alignment (gnu_result);
4235 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
4236 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
4238 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
4239 post_error_ne_tree_2
4240 ("?source alignment (^) '< alignment of & (^)",
4241 gnat_node, Designated_Type (Etype (gnat_node)),
4242 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
4245 /* If we are converting a descriptor to a function pointer, first
4246 build the pointer. */
4247 if (TARGET_VTABLE_USES_DESCRIPTORS
4248 && TREE_TYPE (gnu_result) == fdesc_type_node
4249 && POINTER_TYPE_P (gnu_result_type))
4250 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
4252 gnu_result = unchecked_convert (gnu_result_type, gnu_result,
4253 No_Truncation (gnat_node));
4259 tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
4260 Node_Id gnat_range = Right_Opnd (gnat_node);
4261 tree gnu_low, gnu_high;
4263 /* GNAT_RANGE is either an N_Range node or an identifier denoting a
4265 if (Nkind (gnat_range) == N_Range)
4267 gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
4268 gnu_high = gnat_to_gnu (High_Bound (gnat_range));
4270 else if (Nkind (gnat_range) == N_Identifier
4271 || Nkind (gnat_range) == N_Expanded_Name)
4273 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
4275 gnu_low = TYPE_MIN_VALUE (gnu_range_type);
4276 gnu_high = TYPE_MAX_VALUE (gnu_range_type);
4281 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4283 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
4284 ensure that GNU_OBJ is evaluated only once and perform a full range
4286 if (operand_equal_p (gnu_low, gnu_high, 0))
4288 = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
4292 gnu_obj = gnat_protect_expr (gnu_obj);
4293 t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
4295 set_expr_location_from_node (t1, gnat_node);
4296 t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
4298 set_expr_location_from_node (t2, gnat_node);
4300 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
4303 if (kind == N_Not_In)
4304 gnu_result = invert_truthvalue (gnu_result);
4309 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4310 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4311 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4312 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
4314 : (Rounded_Result (gnat_node)
4315 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
4316 gnu_result_type, gnu_lhs, gnu_rhs);
4319 case N_Op_Or: case N_Op_And: case N_Op_Xor:
4320 /* These can either be operations on booleans or on modular types.
4321 Fall through for boolean types since that's the way GNU_CODES is
4323 if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
4324 Modular_Integer_Kind))
4327 = (kind == N_Op_Or ? BIT_IOR_EXPR
4328 : kind == N_Op_And ? BIT_AND_EXPR
4331 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4332 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4333 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4334 gnu_result = build_binary_op (code, gnu_result_type,
4339 /* ... fall through ... */
4341 case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
4342 case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
4343 case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
4344 case N_Op_Mod: case N_Op_Rem:
4345 case N_Op_Rotate_Left:
4346 case N_Op_Rotate_Right:
4347 case N_Op_Shift_Left:
4348 case N_Op_Shift_Right:
4349 case N_Op_Shift_Right_Arithmetic:
4350 case N_And_Then: case N_Or_Else:
4352 enum tree_code code = gnu_codes[kind];
4353 bool ignore_lhs_overflow = false;
4356 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
4357 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
4358 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
4360 /* Pending generic support for efficient vector logical operations in
4361 GCC, convert vectors to their representative array type view and
4363 gnu_lhs = maybe_vector_array (gnu_lhs);
4364 gnu_rhs = maybe_vector_array (gnu_rhs);
4366 /* If this is a comparison operator, convert any references to
4367 an unconstrained array value into a reference to the
4369 if (TREE_CODE_CLASS (code) == tcc_comparison)
4371 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
4372 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
4375 /* If the result type is a private type, its full view may be a
4376 numeric subtype. The representation we need is that of its base
4377 type, given that it is the result of an arithmetic operation. */
4378 else if (Is_Private_Type (Etype (gnat_node)))
4379 gnu_type = gnu_result_type
4380 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
4382 /* If this is a shift whose count is not guaranteed to be correct,
4383 we need to adjust the shift count. */
4384 if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node))
4386 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
4388 = convert (gnu_count_type, TYPE_SIZE (gnu_type));
4390 if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
4391 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
4392 gnu_rhs, gnu_max_shift);
4393 else if (kind == N_Op_Shift_Right_Arithmetic)
4396 (MIN_EXPR, gnu_count_type,
4397 build_binary_op (MINUS_EXPR,
4400 convert (gnu_count_type,
4405 /* For right shifts, the type says what kind of shift to do,
4406 so we may need to choose a different type. In this case,
4407 we have to ignore integer overflow lest it propagates all
4408 the way down and causes a CE to be explicitly raised. */
4409 if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
4411 gnu_type = gnat_unsigned_type (gnu_type);
4412 ignore_lhs_overflow = true;
4414 else if (kind == N_Op_Shift_Right_Arithmetic
4415 && TYPE_UNSIGNED (gnu_type))
4417 gnu_type = gnat_signed_type (gnu_type);
4418 ignore_lhs_overflow = true;
4421 if (gnu_type != gnu_result_type)
4423 tree gnu_old_lhs = gnu_lhs;
4424 gnu_lhs = convert (gnu_type, gnu_lhs);
4425 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
4426 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
4427 gnu_rhs = convert (gnu_type, gnu_rhs);
4430 /* Instead of expanding overflow checks for addition, subtraction
4431 and multiplication itself, the front end will leave this to
4432 the back end when Backend_Overflow_Checks_On_Target is set.
4433 As the GCC back end itself does not know yet how to properly
4434 do overflow checking, do it here. The goal is to push
4435 the expansions further into the back end over time. */
4436 if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
4437 && (kind == N_Op_Add
4438 || kind == N_Op_Subtract
4439 || kind == N_Op_Multiply)
4440 && !TYPE_UNSIGNED (gnu_type)
4441 && !FLOAT_TYPE_P (gnu_type))
4442 gnu_result = build_binary_op_trapv (code, gnu_type,
4443 gnu_lhs, gnu_rhs, gnat_node);
4445 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
4447 /* If this is a logical shift with the shift count not verified,
4448 we must return zero if it is too large. We cannot compensate
4449 above in this case. */
4450 if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
4451 && !Shift_Count_OK (gnat_node))
4455 build_binary_op (GE_EXPR, integer_type_node,
4457 convert (TREE_TYPE (gnu_rhs),
4458 TYPE_SIZE (gnu_type))),
4459 convert (gnu_type, integer_zero_node),
4464 case N_Conditional_Expression:
4466 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
4467 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
4469 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
4471 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4473 = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
4478 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
4479 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4483 /* This case can apply to a boolean or a modular type.
4484 Fall through for a boolean operand since GNU_CODES is set
4485 up to handle this. */
4486 if (Is_Modular_Integer_Type (Etype (gnat_node))
4487 || (Ekind (Etype (gnat_node)) == E_Private_Type
4488 && Is_Modular_Integer_Type (Full_View (Etype (gnat_node)))))
4490 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
4491 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4492 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
4497 /* ... fall through ... */
4499 case N_Op_Minus: case N_Op_Abs:
4500 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
4502 if (Ekind (Etype (gnat_node)) != E_Private_Type)
4503 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4505 gnu_result_type = get_unpadded_type (Base_Type
4506 (Full_View (Etype (gnat_node))));
4508 if (Do_Overflow_Check (gnat_node)
4509 && !TYPE_UNSIGNED (gnu_result_type)
4510 && !FLOAT_TYPE_P (gnu_result_type))
4512 = build_unary_op_trapv (gnu_codes[kind],
4513 gnu_result_type, gnu_expr, gnat_node);
4515 gnu_result = build_unary_op (gnu_codes[kind],
4516 gnu_result_type, gnu_expr);
4523 bool ignore_init_type = false;
4525 gnat_temp = Expression (gnat_node);
4527 /* The Expression operand can either be an N_Identifier or
4528 Expanded_Name, which must represent a type, or a
4529 N_Qualified_Expression, which contains both the object type and an
4530 initial value for the object. */
4531 if (Nkind (gnat_temp) == N_Identifier
4532 || Nkind (gnat_temp) == N_Expanded_Name)
4533 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
4534 else if (Nkind (gnat_temp) == N_Qualified_Expression)
4536 Entity_Id gnat_desig_type
4537 = Designated_Type (Underlying_Type (Etype (gnat_node)));
4539 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
4540 gnu_init = gnat_to_gnu (Expression (gnat_temp));
4542 gnu_init = maybe_unconstrained_array (gnu_init);
4543 if (Do_Range_Check (Expression (gnat_temp)))
4545 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
4547 if (Is_Elementary_Type (gnat_desig_type)
4548 || Is_Constrained (gnat_desig_type))
4550 gnu_type = gnat_to_gnu_type (gnat_desig_type);
4551 gnu_init = convert (gnu_type, gnu_init);
4555 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
4556 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4557 gnu_type = TREE_TYPE (gnu_init);
4559 gnu_init = convert (gnu_type, gnu_init);
4565 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4566 return build_allocator (gnu_type, gnu_init, gnu_result_type,
4567 Procedure_To_Call (gnat_node),
4568 Storage_Pool (gnat_node), gnat_node,
4573 /**************************/
4574 /* Chapter 5: Statements */
4575 /**************************/
4578 gnu_result = build1 (LABEL_EXPR, void_type_node,
4579 gnat_to_gnu (Identifier (gnat_node)));
4582 case N_Null_Statement:
4583 /* When not optimizing, turn null statements from source into gotos to
4584 the next statement that the middle-end knows how to preserve. */
4585 if (!optimize && Comes_From_Source (gnat_node))
4587 tree stmt, label = create_label_decl (NULL_TREE);
4588 start_stmt_group ();
4589 stmt = build1 (GOTO_EXPR, void_type_node, label);
4590 set_expr_location_from_node (stmt, gnat_node);
4592 stmt = build1 (LABEL_EXPR, void_type_node, label);
4593 set_expr_location_from_node (stmt, gnat_node);
4595 gnu_result = end_stmt_group ();
4598 gnu_result = alloc_stmt_list ();
4601 case N_Assignment_Statement:
4602 /* Get the LHS and RHS of the statement and convert any reference to an
4603 unconstrained array into a reference to the underlying array. */
4604 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
4606 /* If the type has a size that overflows, convert this into raise of
4607 Storage_Error: execution shouldn't have gotten here anyway. */
4608 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
4609 && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
4610 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
4611 N_Raise_Storage_Error);
4612 else if (Nkind (Expression (gnat_node)) == N_Function_Call)
4614 = call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs);
4618 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
4620 /* If range check is needed, emit code to generate it. */
4621 if (Do_Range_Check (Expression (gnat_node)))
4622 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
4626 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
4628 /* If the type being assigned is an array type and the two sides
4629 are not completely disjoint, play safe and use memmove. */
4630 if (TREE_CODE (gnu_result) == MODIFY_EXPR
4631 && Is_Array_Type (Etype (Name (gnat_node)))
4632 && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
4634 tree to, from, size, to_ptr, from_ptr, t;
4636 to = TREE_OPERAND (gnu_result, 0);
4637 from = TREE_OPERAND (gnu_result, 1);
4639 size = TYPE_SIZE_UNIT (TREE_TYPE (from));
4640 size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from);
4642 to_ptr = build_fold_addr_expr (to);
4643 from_ptr = build_fold_addr_expr (from);
4645 t = implicit_built_in_decls[BUILT_IN_MEMMOVE];
4646 gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
4651 case N_If_Statement:
4653 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
4655 /* Make the outer COND_EXPR. Avoid non-determinism. */
4656 gnu_result = build3 (COND_EXPR, void_type_node,
4657 gnat_to_gnu (Condition (gnat_node)),
4658 NULL_TREE, NULL_TREE);
4659 COND_EXPR_THEN (gnu_result)
4660 = build_stmt_group (Then_Statements (gnat_node), false);
4661 TREE_SIDE_EFFECTS (gnu_result) = 1;
4662 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
4664 /* Now make a COND_EXPR for each of the "else if" parts. Put each
4665 into the previous "else" part and point to where to put any
4666 outer "else". Also avoid non-determinism. */
4667 if (Present (Elsif_Parts (gnat_node)))
4668 for (gnat_temp = First (Elsif_Parts (gnat_node));
4669 Present (gnat_temp); gnat_temp = Next (gnat_temp))
4671 gnu_expr = build3 (COND_EXPR, void_type_node,
4672 gnat_to_gnu (Condition (gnat_temp)),
4673 NULL_TREE, NULL_TREE);
4674 COND_EXPR_THEN (gnu_expr)
4675 = build_stmt_group (Then_Statements (gnat_temp), false);
4676 TREE_SIDE_EFFECTS (gnu_expr) = 1;
4677 set_expr_location_from_node (gnu_expr, gnat_temp);
4678 *gnu_else_ptr = gnu_expr;
4679 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
4682 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
4686 case N_Case_Statement:
4687 gnu_result = Case_Statement_to_gnu (gnat_node);
4690 case N_Loop_Statement:
4691 gnu_result = Loop_Statement_to_gnu (gnat_node);
4694 case N_Block_Statement:
4695 start_stmt_group ();
4697 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
4698 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
4700 gnu_result = end_stmt_group ();
4702 if (Present (Identifier (gnat_node)))
4703 mark_out_of_scope (Entity (Identifier (gnat_node)));
4706 case N_Exit_Statement:
4708 = build2 (EXIT_STMT, void_type_node,
4709 (Present (Condition (gnat_node))
4710 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
4711 (Present (Name (gnat_node))
4712 ? get_gnu_tree (Entity (Name (gnat_node)))
4713 : TREE_VALUE (gnu_loop_label_stack)));
4716 case N_Return_Statement:
4718 tree gnu_ret_val, gnu_ret_obj;
4720 /* If we have a return label defined, convert this into a branch to
4721 that label. The return proper will be handled elsewhere. */
4722 if (TREE_VALUE (gnu_return_label_stack))
4724 gnu_result = build1 (GOTO_EXPR, void_type_node,
4725 TREE_VALUE (gnu_return_label_stack));
4729 /* If the subprogram is a function, we must return the expression. */
4730 if (Present (Expression (gnat_node)))
4732 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
4733 tree gnu_result_decl = DECL_RESULT (current_function_decl);
4734 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
4736 /* Do not remove the padding from GNU_RET_VAL if the inner type is
4737 self-referential since we want to allocate the fixed size. */
4738 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
4739 && TYPE_IS_PADDING_P
4740 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
4741 && CONTAINS_PLACEHOLDER_P
4742 (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
4743 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
4745 /* If the subprogram returns by direct reference, return a pointer
4746 to the return value. */
4747 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
4748 || By_Ref (gnat_node))
4749 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
4751 /* Otherwise, if it returns an unconstrained array, we have to
4752 allocate a new version of the result and return it. */
4753 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
4755 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
4756 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
4758 TREE_TYPE (gnu_subprog_type),
4759 Procedure_To_Call (gnat_node),
4760 Storage_Pool (gnat_node),
4764 /* If the subprogram returns by invisible reference, dereference
4765 the pointer it is passed using the type of the return value
4766 and build the copy operation manually. This ensures that we
4767 don't copy too much data, for example if the return type is
4768 unconstrained with a maximum size. */
4769 if (TREE_ADDRESSABLE (gnu_subprog_type))
4772 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
4774 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
4775 gnu_ret_obj, gnu_ret_val);
4776 add_stmt_with_node (gnu_result, gnat_node);
4777 gnu_ret_val = NULL_TREE;
4778 gnu_ret_obj = gnu_result_decl;
4781 /* Otherwise, build a regular return. */
4783 gnu_ret_obj = gnu_result_decl;
4787 gnu_ret_val = NULL_TREE;
4788 gnu_ret_obj = NULL_TREE;
4791 gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
4795 case N_Goto_Statement:
4796 gnu_result = build1 (GOTO_EXPR, void_type_node,
4797 gnat_to_gnu (Name (gnat_node)));
4800 /***************************/
4801 /* Chapter 6: Subprograms */
4802 /***************************/
4804 case N_Subprogram_Declaration:
4805 /* Unless there is a freeze node, declare the subprogram. We consider
4806 this a "definition" even though we're not generating code for
4807 the subprogram because we will be making the corresponding GCC
4810 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
4811 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
4813 gnu_result = alloc_stmt_list ();
4816 case N_Abstract_Subprogram_Declaration:
4817 /* This subprogram doesn't exist for code generation purposes, but we
4818 have to elaborate the types of any parameters and result, unless
4819 they are imported types (nothing to generate in this case). */
4821 /* Process the parameter types first. */
4824 = First_Formal_With_Extras
4825 (Defining_Entity (Specification (gnat_node)));
4826 Present (gnat_temp);
4827 gnat_temp = Next_Formal_With_Extras (gnat_temp))
4828 if (Is_Itype (Etype (gnat_temp))
4829 && !From_With_Type (Etype (gnat_temp)))
4830 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
4833 /* Then the result type, set to Standard_Void_Type for procedures. */
4836 Entity_Id gnat_temp_type
4837 = Etype (Defining_Entity (Specification (gnat_node)));
4839 if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
4840 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
4843 gnu_result = alloc_stmt_list ();
4846 case N_Defining_Program_Unit_Name:
4847 /* For a child unit identifier go up a level to get the specification.
4848 We get this when we try to find the spec of a child unit package
4849 that is the compilation unit being compiled. */
4850 gnu_result = gnat_to_gnu (Parent (gnat_node));
4853 case N_Subprogram_Body:
4854 Subprogram_Body_to_gnu (gnat_node);
4855 gnu_result = alloc_stmt_list ();
4858 case N_Function_Call:
4859 case N_Procedure_Call_Statement:
4860 gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
4863 /************************/
4864 /* Chapter 7: Packages */
4865 /************************/
4867 case N_Package_Declaration:
4868 gnu_result = gnat_to_gnu (Specification (gnat_node));
4871 case N_Package_Specification:
4873 start_stmt_group ();
4874 process_decls (Visible_Declarations (gnat_node),
4875 Private_Declarations (gnat_node), Empty, true, true);
4876 gnu_result = end_stmt_group ();
4879 case N_Package_Body:
4881 /* If this is the body of a generic package - do nothing. */
4882 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
4884 gnu_result = alloc_stmt_list ();
4888 start_stmt_group ();
4889 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
4891 if (Present (Handled_Statement_Sequence (gnat_node)))
4892 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
4894 gnu_result = end_stmt_group ();
4897 /********************************/
4898 /* Chapter 8: Visibility Rules */
4899 /********************************/
4901 case N_Use_Package_Clause:
4902 case N_Use_Type_Clause:
4903 /* Nothing to do here - but these may appear in list of declarations. */
4904 gnu_result = alloc_stmt_list ();
4907 /*********************/
4908 /* Chapter 9: Tasks */
4909 /*********************/
4911 case N_Protected_Type_Declaration:
4912 gnu_result = alloc_stmt_list ();
4915 case N_Single_Task_Declaration:
4916 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
4917 gnu_result = alloc_stmt_list ();
4920 /*********************************************************/
4921 /* Chapter 10: Program Structure and Compilation Issues */
4922 /*********************************************************/
4924 case N_Compilation_Unit:
4925 /* This is not called for the main unit on which gigi is invoked. */
4926 Compilation_Unit_to_gnu (gnat_node);
4927 gnu_result = alloc_stmt_list ();
4930 case N_Subprogram_Body_Stub:
4931 case N_Package_Body_Stub:
4932 case N_Protected_Body_Stub:
4933 case N_Task_Body_Stub:
4934 /* Simply process whatever unit is being inserted. */
4935 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
4939 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
4942 /***************************/
4943 /* Chapter 11: Exceptions */
4944 /***************************/
4946 case N_Handled_Sequence_Of_Statements:
4947 /* If there is an At_End procedure attached to this node, and the EH
4948 mechanism is SJLJ, we must have at least a corresponding At_End
4949 handler, unless the No_Exception_Handlers restriction is set. */
4950 gcc_assert (type_annotate_only
4951 || Exception_Mechanism != Setjmp_Longjmp
4952 || No (At_End_Proc (gnat_node))
4953 || Present (Exception_Handlers (gnat_node))
4954 || No_Exception_Handlers_Set ());
4956 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
4959 case N_Exception_Handler:
4960 if (Exception_Mechanism == Setjmp_Longjmp)
4961 gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
4962 else if (Exception_Mechanism == Back_End_Exceptions)
4963 gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
4969 case N_Push_Constraint_Error_Label:
4970 push_exception_label_stack (&gnu_constraint_error_label_stack,
4971 Exception_Label (gnat_node));
4974 case N_Push_Storage_Error_Label:
4975 push_exception_label_stack (&gnu_storage_error_label_stack,
4976 Exception_Label (gnat_node));
4979 case N_Push_Program_Error_Label:
4980 push_exception_label_stack (&gnu_program_error_label_stack,
4981 Exception_Label (gnat_node));
4984 case N_Pop_Constraint_Error_Label:
4985 gnu_constraint_error_label_stack
4986 = TREE_CHAIN (gnu_constraint_error_label_stack);
4989 case N_Pop_Storage_Error_Label:
4990 gnu_storage_error_label_stack
4991 = TREE_CHAIN (gnu_storage_error_label_stack);
4994 case N_Pop_Program_Error_Label:
4995 gnu_program_error_label_stack
4996 = TREE_CHAIN (gnu_program_error_label_stack);
4999 /******************************/
5000 /* Chapter 12: Generic Units */
5001 /******************************/
5003 case N_Generic_Function_Renaming_Declaration:
5004 case N_Generic_Package_Renaming_Declaration:
5005 case N_Generic_Procedure_Renaming_Declaration:
5006 case N_Generic_Package_Declaration:
5007 case N_Generic_Subprogram_Declaration:
5008 case N_Package_Instantiation:
5009 case N_Procedure_Instantiation:
5010 case N_Function_Instantiation:
5011 /* These nodes can appear on a declaration list but there is nothing to
5012 to be done with them. */
5013 gnu_result = alloc_stmt_list ();
5016 /**************************************************/
5017 /* Chapter 13: Representation Clauses and */
5018 /* Implementation-Dependent Features */
5019 /**************************************************/
5021 case N_Attribute_Definition_Clause:
5022 gnu_result = alloc_stmt_list ();
5024 /* The only one we need to deal with is 'Address since, for the others,
5025 the front-end puts the information elsewhere. */
5026 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
5029 /* And we only deal with 'Address if the object has a Freeze node. */
5030 gnat_temp = Entity (Name (gnat_node));
5031 if (No (Freeze_Node (gnat_temp)))
5034 /* Get the value to use as the address and save it as the equivalent
5035 for the object. When it is frozen, gnat_to_gnu_entity will do the
5037 save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true);
5040 case N_Enumeration_Representation_Clause:
5041 case N_Record_Representation_Clause:
5043 /* We do nothing with these. SEM puts the information elsewhere. */
5044 gnu_result = alloc_stmt_list ();
5047 case N_Code_Statement:
5048 if (!type_annotate_only)
5050 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
5051 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
5052 tree gnu_clobbers = NULL_TREE, tail;
5053 bool allows_mem, allows_reg, fake;
5054 int ninputs, noutputs, i;
5055 const char **oconstraints;
5056 const char *constraint;
5059 /* First retrieve the 3 operand lists built by the front-end. */
5060 Setup_Asm_Outputs (gnat_node);
5061 while (Present (gnat_temp = Asm_Output_Variable ()))
5063 tree gnu_value = gnat_to_gnu (gnat_temp);
5064 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
5065 (Asm_Output_Constraint ()));
5067 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
5071 Setup_Asm_Inputs (gnat_node);
5072 while (Present (gnat_temp = Asm_Input_Value ()))
5074 tree gnu_value = gnat_to_gnu (gnat_temp);
5075 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
5076 (Asm_Input_Constraint ()));
5078 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
5082 Clobber_Setup (gnat_node);
5083 while ((clobber = Clobber_Get_Next ()))
5085 = tree_cons (NULL_TREE,
5086 build_string (strlen (clobber) + 1, clobber),
5089 /* Then perform some standard checking and processing on the
5090 operands. In particular, mark them addressable if needed. */
5091 gnu_outputs = nreverse (gnu_outputs);
5092 noutputs = list_length (gnu_outputs);
5093 gnu_inputs = nreverse (gnu_inputs);
5094 ninputs = list_length (gnu_inputs);
5096 = (const char **) alloca (noutputs * sizeof (const char *));
5098 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
5100 tree output = TREE_VALUE (tail);
5102 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
5103 oconstraints[i] = constraint;
5105 if (parse_output_constraint (&constraint, i, ninputs, noutputs,
5106 &allows_mem, &allows_reg, &fake))
5108 /* If the operand is going to end up in memory,
5109 mark it addressable. Note that we don't test
5110 allows_mem like in the input case below; this
5111 is modelled on the C front-end. */
5113 && !gnat_mark_addressable (output))
5114 output = error_mark_node;
5117 output = error_mark_node;
5119 TREE_VALUE (tail) = output;
5122 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
5124 tree input = TREE_VALUE (tail);
5126 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
5128 if (parse_input_constraint (&constraint, i, ninputs, noutputs,
5130 &allows_mem, &allows_reg))
5132 /* If the operand is going to end up in memory,
5133 mark it addressable. */
5134 if (!allows_reg && allows_mem
5135 && !gnat_mark_addressable (input))
5136 input = error_mark_node;
5139 input = error_mark_node;
5141 TREE_VALUE (tail) = input;
5144 gnu_result = build5 (ASM_EXPR, void_type_node,
5145 gnu_template, gnu_outputs,
5146 gnu_inputs, gnu_clobbers, NULL_TREE);
5147 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
5150 gnu_result = alloc_stmt_list ();
5158 case N_Freeze_Entity:
5159 start_stmt_group ();
5160 process_freeze_entity (gnat_node);
5161 process_decls (Actions (gnat_node), Empty, Empty, true, true);
5162 gnu_result = end_stmt_group ();
5165 case N_Itype_Reference:
5166 if (!present_gnu_tree (Itype (gnat_node)))
5167 process_type (Itype (gnat_node));
5169 gnu_result = alloc_stmt_list ();
5172 case N_Free_Statement:
5173 if (!type_annotate_only)
5175 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
5176 tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
5178 tree gnu_actual_obj_type = 0;
5181 /* If this is a thin pointer, we must dereference it to create
5182 a fat pointer, then go back below to a thin pointer. The
5183 reason for this is that we need a fat pointer someplace in
5184 order to properly compute the size. */
5185 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
5186 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
5187 build_unary_op (INDIRECT_REF, NULL_TREE,
5190 /* If this is an unconstrained array, we know the object must
5191 have been allocated with the template in front of the object.
5192 So pass the template address, but get the total size. Do this
5193 by converting to a thin pointer. */
5194 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
5196 = convert (build_pointer_type
5197 (TYPE_OBJECT_RECORD_TYPE
5198 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
5201 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
5203 if (Present (Actual_Designated_Subtype (gnat_node)))
5206 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
5208 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
5210 = build_unc_object_type_from_ptr (gnu_ptr_type,
5211 gnu_actual_obj_type,
5212 get_identifier ("DEALLOC"));
5215 gnu_actual_obj_type = gnu_obj_type;
5217 gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
5219 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
5220 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
5222 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
5223 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
5224 tree gnu_byte_offset
5225 = convert (sizetype,
5226 size_diffop (size_zero_node, gnu_pos));
5227 gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
5229 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
5230 gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
5231 gnu_ptr, gnu_byte_offset);
5235 = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
5236 Procedure_To_Call (gnat_node),
5237 Storage_Pool (gnat_node),
5242 case N_Raise_Constraint_Error:
5243 case N_Raise_Program_Error:
5244 case N_Raise_Storage_Error:
5245 if (type_annotate_only)
5247 gnu_result = alloc_stmt_list ();
5251 gnu_result_type = get_unpadded_type (Etype (gnat_node));
5253 = build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node, kind);
5255 /* If the type is VOID, this is a statement, so we need to
5256 generate the code for the call. Handle a Condition, if there
5258 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
5260 set_expr_location_from_node (gnu_result, gnat_node);
5262 if (Present (Condition (gnat_node)))
5263 gnu_result = build3 (COND_EXPR, void_type_node,
5264 gnat_to_gnu (Condition (gnat_node)),
5265 gnu_result, alloc_stmt_list ());
5268 gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
5271 case N_Validate_Unchecked_Conversion:
5273 Entity_Id gnat_target_type = Target_Type (gnat_node);
5274 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
5275 tree gnu_target_type = gnat_to_gnu_type (gnat_target_type);
5277 /* No need for any warning in this case. */
5278 if (!flag_strict_aliasing)
5281 /* If the result is a pointer type, see if we are either converting
5282 from a non-pointer or from a pointer to a type with a different
5283 alias set and warn if so. If the result is defined in the same
5284 unit as this unchecked conversion, we can allow this because we
5285 can know to make the pointer type behave properly. */
5286 else if (POINTER_TYPE_P (gnu_target_type)
5287 && !In_Same_Source_Unit (gnat_target_type, gnat_node)
5288 && !No_Strict_Aliasing (Underlying_Type (gnat_target_type)))
5290 tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
5291 ? TREE_TYPE (gnu_source_type)
5293 tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
5295 if ((TYPE_DUMMY_P (gnu_target_desig_type)
5296 || get_alias_set (gnu_target_desig_type) != 0)
5297 && (!POINTER_TYPE_P (gnu_source_type)
5298 || (TYPE_DUMMY_P (gnu_source_desig_type)
5299 != TYPE_DUMMY_P (gnu_target_desig_type))
5300 || (TYPE_DUMMY_P (gnu_source_desig_type)
5301 && gnu_source_desig_type != gnu_target_desig_type)
5302 || !alias_sets_conflict_p
5303 (get_alias_set (gnu_source_desig_type),
5304 get_alias_set (gnu_target_desig_type))))
5307 ("?possible aliasing problem for type&",
5308 gnat_node, Target_Type (gnat_node));
5310 ("\\?use -fno-strict-aliasing switch for references",
5313 ("\\?or use `pragma No_Strict_Aliasing (&);`",
5314 gnat_node, Target_Type (gnat_node));
5318 /* But if the result is a fat pointer type, we have no mechanism to
5319 do that, so we unconditionally warn in problematic cases. */
5320 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
5322 tree gnu_source_array_type
5323 = TYPE_IS_FAT_POINTER_P (gnu_source_type)
5324 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
5326 tree gnu_target_array_type
5327 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
5329 if ((TYPE_DUMMY_P (gnu_target_array_type)
5330 || get_alias_set (gnu_target_array_type) != 0)
5331 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
5332 || (TYPE_DUMMY_P (gnu_source_array_type)
5333 != TYPE_DUMMY_P (gnu_target_array_type))
5334 || (TYPE_DUMMY_P (gnu_source_array_type)
5335 && gnu_source_array_type != gnu_target_array_type)
5336 || !alias_sets_conflict_p
5337 (get_alias_set (gnu_source_array_type),
5338 get_alias_set (gnu_target_array_type))))
5341 ("?possible aliasing problem for type&",
5342 gnat_node, Target_Type (gnat_node));
5344 ("\\?use -fno-strict-aliasing switch for references",
5349 gnu_result = alloc_stmt_list ();
5353 /* SCIL nodes require no processing for GCC. Other nodes should only
5354 be present when annotating types. */
5355 gcc_assert (IN (kind, N_SCIL_Node) || type_annotate_only);
5356 gnu_result = alloc_stmt_list ();
5359 /* If we pushed the processing of the elaboration routine, pop it back. */
5360 if (went_into_elab_proc)
5361 current_function_decl = NULL_TREE;
5363 /* Set the location information on the result if it is a real expression.
5364 References can be reused for multiple GNAT nodes and they would get
5365 the location information of their last use. Note that we may have
5366 no result if we tried to build a CALL_EXPR node to a procedure with
5367 no side-effects and optimization is enabled. */
5369 && EXPR_P (gnu_result)
5370 && TREE_CODE (gnu_result) != NOP_EXPR
5371 && !REFERENCE_CLASS_P (gnu_result)
5372 && !EXPR_HAS_LOCATION (gnu_result))
5373 set_expr_location_from_node (gnu_result, gnat_node);
5375 /* If we're supposed to return something of void_type, it means we have
5376 something we're elaborating for effect, so just return. */
5377 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
5380 /* If the result is a constant that overflowed, raise Constraint_Error. */
5381 if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
5383 post_error ("Constraint_Error will be raised at run-time?", gnat_node);
5385 = build1 (NULL_EXPR, gnu_result_type,
5386 build_call_raise (CE_Overflow_Check_Failed, gnat_node,
5387 N_Raise_Constraint_Error));
5390 /* If our result has side-effects and is of an unconstrained type,
5391 make a SAVE_EXPR so that we can be sure it will only be referenced
5392 once. Note we must do this before any conversions. */
5393 if (TREE_SIDE_EFFECTS (gnu_result)
5394 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
5395 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
5396 gnu_result = gnat_stabilize_reference (gnu_result, false, NULL);
5398 /* Now convert the result to the result type, unless we are in one of the
5401 1. If this is the Name of an assignment statement or a parameter of
5402 a procedure call, return the result almost unmodified since the
5403 RHS will have to be converted to our type in that case, unless
5404 the result type has a simpler size. Likewise if there is just
5405 a no-op unchecked conversion in-between. Similarly, don't convert
5406 integral types that are the operands of an unchecked conversion
5407 since we need to ignore those conversions (for 'Valid).
5409 2. If we have a label (which doesn't have any well-defined type), a
5410 field or an error, return the result almost unmodified. Also don't
5411 do the conversion if the result type involves a PLACEHOLDER_EXPR in
5412 its size since those are the cases where the front end may have the
5413 type wrong due to "instantiating" the unconstrained record with
5414 discriminant values. Similarly, if the two types are record types
5415 with the same name don't convert. This will be the case when we are
5416 converting from a packable version of a type to its original type and
5417 we need those conversions to be NOPs in order for assignments into
5418 these types to work properly.
5420 3. If the type is void or if we have no result, return error_mark_node
5421 to show we have no result.
5423 4. Finally, if the type of the result is already correct. */
5425 if (Present (Parent (gnat_node))
5426 && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
5427 && Name (Parent (gnat_node)) == gnat_node)
5428 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
5429 && unchecked_conversion_nop (Parent (gnat_node)))
5430 || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
5431 && Name (Parent (gnat_node)) != gnat_node)
5432 || Nkind (Parent (gnat_node)) == N_Parameter_Association
5433 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
5434 && !AGGREGATE_TYPE_P (gnu_result_type)
5435 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
5436 && !(TYPE_SIZE (gnu_result_type)
5437 && TYPE_SIZE (TREE_TYPE (gnu_result))
5438 && (AGGREGATE_TYPE_P (gnu_result_type)
5439 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
5440 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
5441 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
5443 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
5444 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
5445 && (CONTAINS_PLACEHOLDER_P
5446 (TYPE_SIZE (TREE_TYPE (gnu_result))))))
5447 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
5448 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
5450 /* Remove padding only if the inner object is of self-referential
5451 size: in that case it must be an object of unconstrained type
5452 with a default discriminant and we want to avoid copying too
5454 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
5455 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
5456 (TREE_TYPE (gnu_result))))))
5457 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
5461 else if (TREE_CODE (gnu_result) == LABEL_DECL
5462 || TREE_CODE (gnu_result) == FIELD_DECL
5463 || TREE_CODE (gnu_result) == ERROR_MARK
5464 || (TYPE_SIZE (gnu_result_type)
5465 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
5466 && TREE_CODE (gnu_result) != INDIRECT_REF
5467 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
5468 || ((TYPE_NAME (gnu_result_type)
5469 == TYPE_NAME (TREE_TYPE (gnu_result)))
5470 && TREE_CODE (gnu_result_type) == RECORD_TYPE
5471 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
5473 /* Remove any padding. */
5474 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
5475 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
5479 else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
5480 gnu_result = error_mark_node;
5482 else if (gnu_result_type != TREE_TYPE (gnu_result))
5483 gnu_result = convert (gnu_result_type, gnu_result);
5485 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
5486 while ((TREE_CODE (gnu_result) == NOP_EXPR
5487 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
5488 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
5489 gnu_result = TREE_OPERAND (gnu_result, 0);
5494 /* Subroutine of above to push the exception label stack. GNU_STACK is
5495 a pointer to the stack to update and GNAT_LABEL, if present, is the
5496 label to push onto the stack. */
5499 push_exception_label_stack (tree *gnu_stack, Entity_Id gnat_label)
5501 tree gnu_label = (Present (gnat_label)
5502 ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
5505 *gnu_stack = tree_cons (NULL_TREE, gnu_label, *gnu_stack);
5508 /* Record the current code position in GNAT_NODE. */
5511 record_code_position (Node_Id gnat_node)
5513 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
5515 add_stmt_with_node (stmt_stmt, gnat_node);
5516 save_gnu_tree (gnat_node, stmt_stmt, true);
5519 /* Insert the code for GNAT_NODE at the position saved for that node. */
5522 insert_code_for (Node_Id gnat_node)
5524 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
5525 save_gnu_tree (gnat_node, NULL_TREE, true);
5528 /* Start a new statement group chained to the previous group. */
5531 start_stmt_group (void)
5533 struct stmt_group *group = stmt_group_free_list;
5535 /* First see if we can get one from the free list. */
5537 stmt_group_free_list = group->previous;
5539 group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group));
5541 group->previous = current_stmt_group;
5542 group->stmt_list = group->block = group->cleanups = NULL_TREE;
5543 current_stmt_group = group;
5546 /* Add GNU_STMT to the current statement group. */
5549 add_stmt (tree gnu_stmt)
5551 append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list);
5554 /* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
5557 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
5559 if (Present (gnat_node))
5560 set_expr_location_from_node (gnu_stmt, gnat_node);
5561 add_stmt (gnu_stmt);
5564 /* Add a declaration statement for GNU_DECL to the current statement group.
5565 Get SLOC from Entity_Id. */
5568 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
5570 tree type = TREE_TYPE (gnu_decl);
5571 tree gnu_stmt, gnu_init, t;
5573 /* If this is a variable that Gigi is to ignore, we may have been given
5574 an ERROR_MARK. So test for it. We also might have been given a
5575 reference for a renaming. So only do something for a decl. Also
5576 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
5577 if (!DECL_P (gnu_decl)
5578 || (TREE_CODE (gnu_decl) == TYPE_DECL
5579 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
5582 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
5584 /* If we are global, we don't want to actually output the DECL_EXPR for
5585 this decl since we already have evaluated the expressions in the
5586 sizes and positions as globals and doing it again would be wrong. */
5587 if (global_bindings_p ())
5589 /* Mark everything as used to prevent node sharing with subprograms.
5590 Note that walk_tree knows how to deal with TYPE_DECL, but neither
5591 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
5592 MARK_VISITED (gnu_stmt);
5593 if (TREE_CODE (gnu_decl) == VAR_DECL
5594 || TREE_CODE (gnu_decl) == CONST_DECL)
5596 MARK_VISITED (DECL_SIZE (gnu_decl));
5597 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
5598 MARK_VISITED (DECL_INITIAL (gnu_decl));
5600 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
5601 else if (TREE_CODE (gnu_decl) == TYPE_DECL
5602 && ((TREE_CODE (type) == RECORD_TYPE
5603 && !TYPE_FAT_POINTER_P (type))
5604 || TREE_CODE (type) == UNION_TYPE
5605 || TREE_CODE (type) == QUAL_UNION_TYPE))
5606 MARK_VISITED (TYPE_ADA_SIZE (type));
5609 add_stmt_with_node (gnu_stmt, gnat_entity);
5611 /* If this is a variable and an initializer is attached to it, it must be
5612 valid for the context. Similar to init_const in create_var_decl_1. */
5613 if (TREE_CODE (gnu_decl) == VAR_DECL
5614 && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
5615 && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
5616 || (TREE_STATIC (gnu_decl)
5617 && !initializer_constant_valid_p (gnu_init,
5618 TREE_TYPE (gnu_init)))))
5620 /* If GNU_DECL has a padded type, convert it to the unpadded
5621 type so the assignment is done properly. */
5622 if (TYPE_IS_PADDING_P (type))
5623 t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
5627 gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
5629 DECL_INITIAL (gnu_decl) = NULL_TREE;
5630 if (TREE_READONLY (gnu_decl))
5632 TREE_READONLY (gnu_decl) = 0;
5633 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
5636 add_stmt_with_node (gnu_stmt, gnat_entity);
5640 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
5643 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
5647 if (TREE_VISITED (t))
5650 /* Don't mark a dummy type as visited because we want to mark its sizes
5651 and fields once it's filled in. */
5652 else if (!TYPE_IS_DUMMY_P (t))
5653 TREE_VISITED (t) = 1;
5656 TYPE_SIZES_GIMPLIFIED (t) = 1;
5661 /* Mark nodes rooted at T with TREE_VISITED and types as having their
5662 sized gimplified. We use this to indicate all variable sizes and
5663 positions in global types may not be shared by any subprogram. */
5666 mark_visited (tree t)
5668 walk_tree (&t, mark_visited_r, NULL, NULL);
5671 /* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */
5674 unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
5675 void *data ATTRIBUTE_UNUSED)
5679 if (TREE_CODE (t) == SAVE_EXPR)
5680 TREE_OPERAND (t, 0) = unshare_expr (TREE_OPERAND (t, 0));
5685 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
5686 set its location to that of GNAT_NODE if present. */
5689 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
5691 if (Present (gnat_node))
5692 set_expr_location_from_node (gnu_cleanup, gnat_node);
5693 append_to_statement_list (gnu_cleanup, ¤t_stmt_group->cleanups);
5696 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
5699 set_block_for_group (tree gnu_block)
5701 gcc_assert (!current_stmt_group->block);
5702 current_stmt_group->block = gnu_block;
5705 /* Return code corresponding to the current code group. It is normally
5706 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
5707 BLOCK or cleanups were set. */
5710 end_stmt_group (void)
5712 struct stmt_group *group = current_stmt_group;
5713 tree gnu_retval = group->stmt_list;
5715 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
5716 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
5717 make a BIND_EXPR. Note that we nest in that because the cleanup may
5718 reference variables in the block. */
5719 if (gnu_retval == NULL_TREE)
5720 gnu_retval = alloc_stmt_list ();
5722 if (group->cleanups)
5723 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
5726 if (current_stmt_group->block)
5727 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
5728 gnu_retval, group->block);
5730 /* Remove this group from the stack and add it to the free list. */
5731 current_stmt_group = group->previous;
5732 group->previous = stmt_group_free_list;
5733 stmt_group_free_list = group;
5738 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
5742 add_stmt_list (List_Id gnat_list)
5746 if (Present (gnat_list))
5747 for (gnat_node = First (gnat_list); Present (gnat_node);
5748 gnat_node = Next (gnat_node))
5749 add_stmt (gnat_to_gnu (gnat_node));
5752 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
5753 If BINDING_P is true, push and pop a binding level around the list. */
5756 build_stmt_group (List_Id gnat_list, bool binding_p)
5758 start_stmt_group ();
5762 add_stmt_list (gnat_list);
5766 return end_stmt_group ();
5769 /* Push and pop routines for stacks. We keep a free list around so we
5770 don't waste tree nodes. */
5773 push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value)
5775 tree gnu_node = gnu_stack_free_list;
5779 gnu_stack_free_list = TREE_CHAIN (gnu_node);
5780 TREE_CHAIN (gnu_node) = *gnu_stack_ptr;
5781 TREE_PURPOSE (gnu_node) = gnu_purpose;
5782 TREE_VALUE (gnu_node) = gnu_value;
5785 gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr);
5787 *gnu_stack_ptr = gnu_node;
5791 pop_stack (tree *gnu_stack_ptr)
5793 tree gnu_node = *gnu_stack_ptr;
5795 *gnu_stack_ptr = TREE_CHAIN (gnu_node);
5796 TREE_CHAIN (gnu_node) = gnu_stack_free_list;
5797 gnu_stack_free_list = gnu_node;
5800 /* Generate GIMPLE in place for the expression at *EXPR_P. */
5803 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
5804 gimple_seq *post_p ATTRIBUTE_UNUSED)
5806 tree expr = *expr_p;
5809 if (IS_ADA_STMT (expr))
5810 return gnat_gimplify_stmt (expr_p);
5812 switch (TREE_CODE (expr))
5815 /* If this is for a scalar, just make a VAR_DECL for it. If for
5816 an aggregate, get a null pointer of the appropriate type and
5818 if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
5819 *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
5820 convert (build_pointer_type (TREE_TYPE (expr)),
5821 integer_zero_node));
5824 *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
5825 TREE_NO_WARNING (*expr_p) = 1;
5828 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
5831 case UNCONSTRAINED_ARRAY_REF:
5832 /* We should only do this if we are just elaborating for side-effects,
5833 but we can't know that yet. */
5834 *expr_p = TREE_OPERAND (*expr_p, 0);
5838 op = TREE_OPERAND (expr, 0);
5840 if (TREE_CODE (op) == CONSTRUCTOR)
5842 /* If we are taking the address of a constant CONSTRUCTOR, make sure
5843 it is put into static memory. We know it's going to be read-only
5844 given the semantics we have and it must be in static memory when
5845 the reference is in an elaboration procedure. */
5846 if (TREE_CONSTANT (op))
5848 tree new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
5849 TREE_ADDRESSABLE (new_var) = 1;
5850 gimple_add_tmp_var (new_var);
5852 TREE_READONLY (new_var) = 1;
5853 TREE_STATIC (new_var) = 1;
5854 DECL_INITIAL (new_var) = op;
5856 TREE_OPERAND (expr, 0) = new_var;
5857 recompute_tree_invariant_for_addr_expr (expr);
5860 /* Otherwise explicitly create the local temporary. That's required
5861 if the type is passed by reference. */
5864 tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
5865 TREE_ADDRESSABLE (new_var) = 1;
5866 gimple_add_tmp_var (new_var);
5868 mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
5869 gimplify_and_add (mod, pre_p);
5871 TREE_OPERAND (expr, 0) = new_var;
5872 recompute_tree_invariant_for_addr_expr (expr);
5878 return GS_UNHANDLED;
5881 op = DECL_EXPR_DECL (expr);
5883 /* The expressions for the RM bounds must be gimplified to ensure that
5884 they are properly elaborated. See gimplify_decl_expr. */
5885 if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
5886 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
5887 switch (TREE_CODE (TREE_TYPE (op)))
5894 tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
5896 val = TYPE_RM_MIN_VALUE (type);
5899 gimplify_one_sizepos (&val, pre_p);
5900 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
5901 SET_TYPE_RM_MIN_VALUE (t, val);
5904 val = TYPE_RM_MAX_VALUE (type);
5907 gimplify_one_sizepos (&val, pre_p);
5908 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
5909 SET_TYPE_RM_MAX_VALUE (t, val);
5919 /* ... fall through ... */
5922 return GS_UNHANDLED;
5926 /* Generate GIMPLE in place for the statement at *STMT_P. */
5928 static enum gimplify_status
5929 gnat_gimplify_stmt (tree *stmt_p)
5931 tree stmt = *stmt_p;
5933 switch (TREE_CODE (stmt))
5936 *stmt_p = STMT_STMT_STMT (stmt);
5941 tree gnu_start_label = create_artificial_label (input_location);
5942 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
5945 /* Set to emit the statements of the loop. */
5946 *stmt_p = NULL_TREE;
5948 /* We first emit the start label and then a conditional jump to
5949 the end label if there's a top condition, then the body of the
5950 loop, then a conditional branch to the end label, then the update,
5951 if any, and finally a jump to the start label and the definition
5952 of the end label. */
5953 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
5957 if (LOOP_STMT_TOP_COND (stmt))
5958 append_to_statement_list (build3 (COND_EXPR, void_type_node,
5959 LOOP_STMT_TOP_COND (stmt),
5966 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
5968 if (LOOP_STMT_BOT_COND (stmt))
5969 append_to_statement_list (build3 (COND_EXPR, void_type_node,
5970 LOOP_STMT_BOT_COND (stmt),
5977 if (LOOP_STMT_UPDATE (stmt))
5978 append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p);
5980 t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
5981 SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
5982 append_to_statement_list (t, stmt_p);
5984 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
5991 /* Build a statement to jump to the corresponding end label, then
5992 see if it needs to be conditional. */
5993 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
5994 if (EXIT_STMT_COND (stmt))
5995 *stmt_p = build3 (COND_EXPR, void_type_node,
5996 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
6004 /* Force references to each of the entities in packages withed by GNAT_NODE.
6005 Operate recursively but check that we aren't elaborating something more
6008 This routine is exclusively called in type_annotate mode, to compute DDA
6009 information for types in withed units, for ASIS use. */
6012 elaborate_all_entities (Node_Id gnat_node)
6014 Entity_Id gnat_with_clause, gnat_entity;
6016 /* Process each unit only once. As we trace the context of all relevant
6017 units transitively, including generic bodies, we may encounter the
6018 same generic unit repeatedly. */
6019 if (!present_gnu_tree (gnat_node))
6020 save_gnu_tree (gnat_node, integer_zero_node, true);
6022 /* Save entities in all context units. A body may have an implicit_with
6023 on its own spec, if the context includes a child unit, so don't save
6025 for (gnat_with_clause = First (Context_Items (gnat_node));
6026 Present (gnat_with_clause);
6027 gnat_with_clause = Next (gnat_with_clause))
6028 if (Nkind (gnat_with_clause) == N_With_Clause
6029 && !present_gnu_tree (Library_Unit (gnat_with_clause))
6030 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
6032 elaborate_all_entities (Library_Unit (gnat_with_clause));
6034 if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
6036 for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
6037 Present (gnat_entity);
6038 gnat_entity = Next_Entity (gnat_entity))
6039 if (Is_Public (gnat_entity)
6040 && Convention (gnat_entity) != Convention_Intrinsic
6041 && Ekind (gnat_entity) != E_Package
6042 && Ekind (gnat_entity) != E_Package_Body
6043 && Ekind (gnat_entity) != E_Operator
6044 && !(IN (Ekind (gnat_entity), Type_Kind)
6045 && !Is_Frozen (gnat_entity))
6046 && !((Ekind (gnat_entity) == E_Procedure
6047 || Ekind (gnat_entity) == E_Function)
6048 && Is_Intrinsic_Subprogram (gnat_entity))
6049 && !IN (Ekind (gnat_entity), Named_Kind)
6050 && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
6051 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
6053 else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
6056 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
6058 /* Retrieve compilation unit node of generic body. */
6059 while (Present (gnat_body)
6060 && Nkind (gnat_body) != N_Compilation_Unit)
6061 gnat_body = Parent (gnat_body);
6063 /* If body is available, elaborate its context. */
6064 if (Present (gnat_body))
6065 elaborate_all_entities (gnat_body);
6069 if (Nkind (Unit (gnat_node)) == N_Package_Body)
6070 elaborate_all_entities (Library_Unit (gnat_node));
6073 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
6076 process_freeze_entity (Node_Id gnat_node)
6078 const Entity_Id gnat_entity = Entity (gnat_node);
6079 const Entity_Kind kind = Ekind (gnat_entity);
6080 tree gnu_old, gnu_new;
6082 /* If this is a package, we need to generate code for the package. */
6083 if (kind == E_Package)
6086 (Parent (Corresponding_Body
6087 (Parent (Declaration_Node (gnat_entity)))));
6091 /* Don't do anything for class-wide types as they are always transformed
6092 into their root type. */
6093 if (kind == E_Class_Wide_Type)
6096 /* Check for an old definition. This freeze node might be for an Itype. */
6098 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
6100 /* If this entity has an address representation clause, GNU_OLD is the
6101 address, so discard it here. */
6102 if (Present (Address_Clause (gnat_entity)))
6103 gnu_old = NULL_TREE;
6105 /* Don't do anything for subprograms that may have been elaborated before
6106 their freeze nodes. This can happen, for example, because of an inner
6107 call in an instance body or because of previous compilation of a spec
6108 for inlining purposes. */
6110 && ((TREE_CODE (gnu_old) == FUNCTION_DECL
6111 && (kind == E_Function || kind == E_Procedure))
6112 || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
6113 && kind == E_Subprogram_Type)))
6116 /* If we have a non-dummy type old tree, we have nothing to do, except
6117 aborting if this is the public view of a private type whose full view was
6118 not delayed, as this node was never delayed as it should have been. We
6119 let this happen for concurrent types and their Corresponding_Record_Type,
6120 however, because each might legitimately be elaborated before its own
6121 freeze node, e.g. while processing the other. */
6123 && !(TREE_CODE (gnu_old) == TYPE_DECL
6124 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
6126 gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
6127 && Present (Full_View (gnat_entity))
6128 && No (Freeze_Node (Full_View (gnat_entity))))
6129 || Is_Concurrent_Type (gnat_entity)
6130 || (IN (kind, Record_Kind)
6131 && Is_Concurrent_Record_Type (gnat_entity)));
6135 /* Reset the saved tree, if any, and elaborate the object or type for real.
6136 If there is a full view, elaborate it and use the result. And, if this
6137 is the root type of a class-wide type, reuse it for the latter. */
6140 save_gnu_tree (gnat_entity, NULL_TREE, false);
6141 if (IN (kind, Incomplete_Or_Private_Kind)
6142 && Present (Full_View (gnat_entity))
6143 && present_gnu_tree (Full_View (gnat_entity)))
6144 save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
6145 if (IN (kind, Type_Kind)
6146 && Present (Class_Wide_Type (gnat_entity))
6147 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6148 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
6151 if (IN (kind, Incomplete_Or_Private_Kind)
6152 && Present (Full_View (gnat_entity)))
6154 gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
6156 /* Propagate back-annotations from full view to partial view. */
6157 if (Unknown_Alignment (gnat_entity))
6158 Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
6160 if (Unknown_Esize (gnat_entity))
6161 Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
6163 if (Unknown_RM_Size (gnat_entity))
6164 Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
6166 /* The above call may have defined this entity (the simplest example
6167 of this is when we have a private enumeral type since the bounds
6168 will have the public view). */
6169 if (!present_gnu_tree (gnat_entity))
6170 save_gnu_tree (gnat_entity, gnu_new, false);
6175 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
6176 && present_gnu_tree (Declaration_Node (gnat_entity)))
6177 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
6179 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
6182 if (IN (kind, Type_Kind)
6183 && Present (Class_Wide_Type (gnat_entity))
6184 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
6185 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
6187 /* If we've made any pointers to the old version of this type, we
6188 have to update them. */
6190 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
6191 TREE_TYPE (gnu_new));
6194 /* Process the list of inlined subprograms of GNAT_NODE, which is an
6195 N_Compilation_Unit. */
6198 process_inlined_subprograms (Node_Id gnat_node)
6200 Entity_Id gnat_entity;
6203 /* If we can inline, generate Gimple for all the inlined subprograms.
6204 Define the entity first so we set DECL_EXTERNAL. */
6206 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
6207 Present (gnat_entity);
6208 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
6210 gnat_body = Parent (Declaration_Node (gnat_entity));
6212 if (Nkind (gnat_body) != N_Subprogram_Body)
6214 /* ??? This really should always be Present. */
6215 if (No (Corresponding_Body (gnat_body)))
6219 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
6222 if (Present (gnat_body))
6224 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
6225 add_stmt (gnat_to_gnu (gnat_body));
6230 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
6231 We make two passes, one to elaborate anything other than bodies (but
6232 we declare a function if there was no spec). The second pass
6233 elaborates the bodies.
6235 GNAT_END_LIST gives the element in the list past the end. Normally,
6236 this is Empty, but can be First_Real_Statement for a
6237 Handled_Sequence_Of_Statements.
6239 We make a complete pass through both lists if PASS1P is true, then make
6240 the second pass over both lists if PASS2P is true. The lists usually
6241 correspond to the public and private parts of a package. */
6244 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
6245 Node_Id gnat_end_list, bool pass1p, bool pass2p)
6247 List_Id gnat_decl_array[2];
6251 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
6254 for (i = 0; i <= 1; i++)
6255 if (Present (gnat_decl_array[i]))
6256 for (gnat_decl = First (gnat_decl_array[i]);
6257 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6259 /* For package specs, we recurse inside the declarations,
6260 thus taking the two pass approach inside the boundary. */
6261 if (Nkind (gnat_decl) == N_Package_Declaration
6262 && (Nkind (Specification (gnat_decl)
6263 == N_Package_Specification)))
6264 process_decls (Visible_Declarations (Specification (gnat_decl)),
6265 Private_Declarations (Specification (gnat_decl)),
6266 Empty, true, false);
6268 /* Similarly for any declarations in the actions of a
6270 else if (Nkind (gnat_decl) == N_Freeze_Entity)
6272 process_freeze_entity (gnat_decl);
6273 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
6276 /* Package bodies with freeze nodes get their elaboration deferred
6277 until the freeze node, but the code must be placed in the right
6278 place, so record the code position now. */
6279 else if (Nkind (gnat_decl) == N_Package_Body
6280 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
6281 record_code_position (gnat_decl);
6283 else if (Nkind (gnat_decl) == N_Package_Body_Stub
6284 && Present (Library_Unit (gnat_decl))
6285 && Present (Freeze_Node
6288 (Library_Unit (gnat_decl)))))))
6289 record_code_position
6290 (Proper_Body (Unit (Library_Unit (gnat_decl))));
6292 /* We defer most subprogram bodies to the second pass. */
6293 else if (Nkind (gnat_decl) == N_Subprogram_Body)
6295 if (Acts_As_Spec (gnat_decl))
6297 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
6299 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
6300 && Ekind (gnat_subprog_id) != E_Generic_Function)
6301 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6305 /* For bodies and stubs that act as their own specs, the entity
6306 itself must be elaborated in the first pass, because it may
6307 be used in other declarations. */
6308 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
6310 Node_Id gnat_subprog_id
6311 = Defining_Entity (Specification (gnat_decl));
6313 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
6314 && Ekind (gnat_subprog_id) != E_Generic_Procedure
6315 && Ekind (gnat_subprog_id) != E_Generic_Function)
6316 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
6319 /* Concurrent stubs stand for the corresponding subprogram bodies,
6320 which are deferred like other bodies. */
6321 else if (Nkind (gnat_decl) == N_Task_Body_Stub
6322 || Nkind (gnat_decl) == N_Protected_Body_Stub)
6326 add_stmt (gnat_to_gnu (gnat_decl));
6329 /* Here we elaborate everything we deferred above except for package bodies,
6330 which are elaborated at their freeze nodes. Note that we must also
6331 go inside things (package specs and freeze nodes) the first pass did. */
6333 for (i = 0; i <= 1; i++)
6334 if (Present (gnat_decl_array[i]))
6335 for (gnat_decl = First (gnat_decl_array[i]);
6336 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
6338 if (Nkind (gnat_decl) == N_Subprogram_Body
6339 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
6340 || Nkind (gnat_decl) == N_Task_Body_Stub
6341 || Nkind (gnat_decl) == N_Protected_Body_Stub)
6342 add_stmt (gnat_to_gnu (gnat_decl));
6344 else if (Nkind (gnat_decl) == N_Package_Declaration
6345 && (Nkind (Specification (gnat_decl)
6346 == N_Package_Specification)))
6347 process_decls (Visible_Declarations (Specification (gnat_decl)),
6348 Private_Declarations (Specification (gnat_decl)),
6349 Empty, false, true);
6351 else if (Nkind (gnat_decl) == N_Freeze_Entity)
6352 process_decls (Actions (gnat_decl), Empty, Empty, false, true);
6356 /* Make a unary operation of kind CODE using build_unary_op, but guard
6357 the operation by an overflow check. CODE can be one of NEGATE_EXPR
6358 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
6359 the operation is to be performed in that type. GNAT_NODE is the gnat
6360 node conveying the source location for which the error should be
6364 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
6367 gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
6369 operand = gnat_protect_expr (operand);
6371 return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
6372 operand, TYPE_MIN_VALUE (gnu_type)),
6373 build_unary_op (code, gnu_type, operand),
6374 CE_Overflow_Check_Failed, gnat_node);
6377 /* Make a binary operation of kind CODE using build_binary_op, but guard
6378 the operation by an overflow check. CODE can be one of PLUS_EXPR,
6379 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
6380 Usually the operation is to be performed in that type. GNAT_NODE is
6381 the GNAT node conveying the source location for which the error should
6385 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
6386 tree right, Node_Id gnat_node)
6388 tree lhs = gnat_protect_expr (left);
6389 tree rhs = gnat_protect_expr (right);
6390 tree type_max = TYPE_MAX_VALUE (gnu_type);
6391 tree type_min = TYPE_MIN_VALUE (gnu_type);
6394 tree zero = convert (gnu_type, integer_zero_node);
6399 int precision = TYPE_PRECISION (gnu_type);
6401 gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */
6403 /* Prefer a constant or known-positive rhs to simplify checks. */
6404 if (!TREE_CONSTANT (rhs)
6405 && commutative_tree_code (code)
6406 && (TREE_CONSTANT (lhs) || (!tree_expr_nonnegative_p (rhs)
6407 && tree_expr_nonnegative_p (lhs))))
6414 rhs_lt_zero = tree_expr_nonnegative_p (rhs)
6416 : build_binary_op (LT_EXPR, integer_type_node, rhs, zero);
6418 /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
6420 /* Try a few strategies that may be cheaper than the general
6421 code at the end of the function, if the rhs is not known.
6423 - Call library function for 64-bit multiplication (complex)
6424 - Widen, if input arguments are sufficiently small
6425 - Determine overflow using wrapped result for addition/subtraction. */
6427 if (!TREE_CONSTANT (rhs))
6429 /* Even for add/subtract double size to get another base type. */
6430 int needed_precision = precision * 2;
6432 if (code == MULT_EXPR && precision == 64)
6434 tree int_64 = gnat_type_for_size (64, 0);
6436 return convert (gnu_type, build_call_2_expr (mulv64_decl,
6437 convert (int_64, lhs),
6438 convert (int_64, rhs)));
6441 else if (needed_precision <= BITS_PER_WORD
6442 || (code == MULT_EXPR
6443 && needed_precision <= LONG_LONG_TYPE_SIZE))
6445 tree wide_type = gnat_type_for_size (needed_precision, 0);
6447 tree wide_result = build_binary_op (code, wide_type,
6448 convert (wide_type, lhs),
6449 convert (wide_type, rhs));
6451 tree check = build_binary_op
6452 (TRUTH_ORIF_EXPR, integer_type_node,
6453 build_binary_op (LT_EXPR, integer_type_node, wide_result,
6454 convert (wide_type, type_min)),
6455 build_binary_op (GT_EXPR, integer_type_node, wide_result,
6456 convert (wide_type, type_max)));
6458 tree result = convert (gnu_type, wide_result);
6461 emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
6464 else if (code == PLUS_EXPR || code == MINUS_EXPR)
6466 tree unsigned_type = gnat_type_for_size (precision, 1);
6467 tree wrapped_expr = convert
6468 (gnu_type, build_binary_op (code, unsigned_type,
6469 convert (unsigned_type, lhs),
6470 convert (unsigned_type, rhs)));
6472 tree result = convert
6473 (gnu_type, build_binary_op (code, gnu_type, lhs, rhs));
6475 /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
6476 or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */
6477 tree check = build_binary_op
6478 (TRUTH_XOR_EXPR, integer_type_node, rhs_lt_zero,
6479 build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
6480 integer_type_node, wrapped_expr, lhs));
6483 emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
6490 /* When rhs >= 0, overflow when lhs > type_max - rhs. */
6491 check_pos = build_binary_op (GT_EXPR, integer_type_node, lhs,
6492 build_binary_op (MINUS_EXPR, gnu_type,
6495 /* When rhs < 0, overflow when lhs < type_min - rhs. */
6496 check_neg = build_binary_op (LT_EXPR, integer_type_node, lhs,
6497 build_binary_op (MINUS_EXPR, gnu_type,
6502 /* When rhs >= 0, overflow when lhs < type_min + rhs. */
6503 check_pos = build_binary_op (LT_EXPR, integer_type_node, lhs,
6504 build_binary_op (PLUS_EXPR, gnu_type,
6507 /* When rhs < 0, overflow when lhs > type_max + rhs. */
6508 check_neg = build_binary_op (GT_EXPR, integer_type_node, lhs,
6509 build_binary_op (PLUS_EXPR, gnu_type,
6514 /* The check here is designed to be efficient if the rhs is constant,
6515 but it will work for any rhs by using integer division.
6516 Four different check expressions determine wether X * C overflows,
6519 C > 0 => X > type_max / C || X < type_min / C
6520 C == -1 => X == type_min
6521 C < -1 => X > type_min / C || X < type_max / C */
6523 tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
6524 tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
6526 check_pos = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6527 build_binary_op (NE_EXPR, integer_type_node, zero, rhs),
6528 build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6529 build_binary_op (GT_EXPR, integer_type_node, lhs, tmp1),
6530 build_binary_op (LT_EXPR, integer_type_node, lhs, tmp2)));
6532 check_neg = fold_build3 (COND_EXPR, integer_type_node,
6533 build_binary_op (EQ_EXPR, integer_type_node, rhs,
6534 build_int_cst (gnu_type, -1)),
6535 build_binary_op (EQ_EXPR, integer_type_node, lhs, type_min),
6536 build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6537 build_binary_op (GT_EXPR, integer_type_node, lhs, tmp2),
6538 build_binary_op (LT_EXPR, integer_type_node, lhs, tmp1)));
6545 gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
6547 /* If we can fold the expression to a constant, just return it.
6548 The caller will deal with overflow, no need to generate a check. */
6549 if (TREE_CONSTANT (gnu_expr))
6552 check = fold_build3 (COND_EXPR, integer_type_node,
6553 rhs_lt_zero, check_neg, check_pos);
6555 return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
6558 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
6559 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
6560 which we have to check. GNAT_NODE is the GNAT node conveying the source
6561 location for which the error should be signaled. */
6564 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
6566 tree gnu_range_type = get_unpadded_type (gnat_range_type);
6567 tree gnu_low = TYPE_MIN_VALUE (gnu_range_type);
6568 tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
6569 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
6571 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
6572 This can for example happen when translating 'Val or 'Value. */
6573 if (gnu_compare_type == gnu_range_type)
6576 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
6577 we can't do anything since we might be truncating the bounds. No
6578 check is needed in this case. */
6579 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
6580 && (TYPE_PRECISION (gnu_compare_type)
6581 < TYPE_PRECISION (get_base_type (gnu_range_type))))
6584 /* Checked expressions must be evaluated only once. */
6585 gnu_expr = gnat_protect_expr (gnu_expr);
6587 /* There's no good type to use here, so we might as well use
6588 integer_type_node. Note that the form of the check is
6589 (not (expr >= lo)) or (not (expr <= hi))
6590 the reason for this slightly convoluted form is that NaNs
6591 are not considered to be in range in the float case. */
6593 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6595 (build_binary_op (GE_EXPR, integer_type_node,
6596 convert (gnu_compare_type, gnu_expr),
6597 convert (gnu_compare_type, gnu_low))),
6599 (build_binary_op (LE_EXPR, integer_type_node,
6600 convert (gnu_compare_type, gnu_expr),
6601 convert (gnu_compare_type,
6603 gnu_expr, CE_Range_Check_Failed, gnat_node);
6606 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which
6607 we are about to index, GNU_EXPR is the index expression to be checked,
6608 GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR
6609 has to be checked. Note that for index checking we cannot simply use the
6610 emit_range_check function (although very similar code needs to be generated
6611 in both cases) since for index checking the array type against which we are
6612 checking the indices may be unconstrained and consequently we need to get
6613 the actual index bounds from the array object itself (GNU_ARRAY_OBJECT).
6614 The place where we need to do that is in subprograms having unconstrained
6615 array formal parameters. GNAT_NODE is the GNAT node conveying the source
6616 location for which the error should be signaled. */
6619 emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
6620 tree gnu_high, Node_Id gnat_node)
6622 tree gnu_expr_check;
6624 /* Checked expressions must be evaluated only once. */
6625 gnu_expr = gnat_protect_expr (gnu_expr);
6627 /* Must do this computation in the base type in case the expression's
6628 type is an unsigned subtypes. */
6629 gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
6631 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
6632 the object we are handling. */
6633 gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
6634 gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
6636 /* There's no good type to use here, so we might as well use
6637 integer_type_node. */
6639 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6640 build_binary_op (LT_EXPR, integer_type_node,
6642 convert (TREE_TYPE (gnu_expr_check),
6644 build_binary_op (GT_EXPR, integer_type_node,
6646 convert (TREE_TYPE (gnu_expr_check),
6648 gnu_expr, CE_Index_Check_Failed, gnat_node);
6651 /* GNU_COND contains the condition corresponding to an access, discriminant or
6652 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
6653 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
6654 REASON is the code that says why the exception was raised. GNAT_NODE is
6655 the GNAT node conveying the source location for which the error should be
6659 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
6662 = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
6664 = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
6665 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
6666 convert (TREE_TYPE (gnu_expr), integer_zero_node)),
6669 /* GNU_RESULT has side effects if and only if GNU_EXPR has:
6670 we don't need to evaluate it just for the check. */
6671 TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr);
6676 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
6677 checks if OVERFLOW_P is true and range checks if RANGE_P is true.
6678 GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
6679 float to integer conversion with truncation; otherwise round.
6680 GNAT_NODE is the GNAT node conveying the source location for which the
6681 error should be signaled. */
6684 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
6685 bool rangep, bool truncatep, Node_Id gnat_node)
6687 tree gnu_type = get_unpadded_type (gnat_type);
6688 tree gnu_in_type = TREE_TYPE (gnu_expr);
6689 tree gnu_in_basetype = get_base_type (gnu_in_type);
6690 tree gnu_base_type = get_base_type (gnu_type);
6691 tree gnu_result = gnu_expr;
6693 /* If we are not doing any checks, the output is an integral type, and
6694 the input is not a floating type, just do the conversion. This
6695 shortcut is required to avoid problems with packed array types
6696 and simplifies code in all cases anyway. */
6697 if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
6698 && !FLOAT_TYPE_P (gnu_in_type))
6699 return convert (gnu_type, gnu_expr);
6701 /* First convert the expression to its base type. This
6702 will never generate code, but makes the tests below much simpler.
6703 But don't do this if converting from an integer type to an unconstrained
6704 array type since then we need to get the bounds from the original
6706 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
6707 gnu_result = convert (gnu_in_basetype, gnu_result);
6709 /* If overflow checks are requested, we need to be sure the result will
6710 fit in the output base type. But don't do this if the input
6711 is integer and the output floating-point. */
6713 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
6715 /* Ensure GNU_EXPR only gets evaluated once. */
6716 tree gnu_input = gnat_protect_expr (gnu_result);
6717 tree gnu_cond = integer_zero_node;
6718 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
6719 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
6720 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
6721 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
6723 /* Convert the lower bounds to signed types, so we're sure we're
6724 comparing them properly. Likewise, convert the upper bounds
6725 to unsigned types. */
6726 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
6727 gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
6729 if (INTEGRAL_TYPE_P (gnu_in_basetype)
6730 && !TYPE_UNSIGNED (gnu_in_basetype))
6731 gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
6733 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
6734 gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
6736 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
6737 gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
6739 /* Check each bound separately and only if the result bound
6740 is tighter than the bound on the input type. Note that all the
6741 types are base types, so the bounds must be constant. Also,
6742 the comparison is done in the base type of the input, which
6743 always has the proper signedness. First check for input
6744 integer (which means output integer), output float (which means
6745 both float), or mixed, in which case we always compare.
6746 Note that we have to do the comparison which would *fail* in the
6747 case of an error since if it's an FP comparison and one of the
6748 values is a NaN or Inf, the comparison will fail. */
6749 if (INTEGRAL_TYPE_P (gnu_in_basetype)
6750 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
6751 : (FLOAT_TYPE_P (gnu_base_type)
6752 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
6753 TREE_REAL_CST (gnu_out_lb))
6757 (build_binary_op (GE_EXPR, integer_type_node,
6758 gnu_input, convert (gnu_in_basetype,
6761 if (INTEGRAL_TYPE_P (gnu_in_basetype)
6762 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
6763 : (FLOAT_TYPE_P (gnu_base_type)
6764 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
6765 TREE_REAL_CST (gnu_in_lb))
6768 = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
6770 (build_binary_op (LE_EXPR, integer_type_node,
6772 convert (gnu_in_basetype,
6775 if (!integer_zerop (gnu_cond))
6776 gnu_result = emit_check (gnu_cond, gnu_input,
6777 CE_Overflow_Check_Failed, gnat_node);
6780 /* Now convert to the result base type. If this is a non-truncating
6781 float-to-integer conversion, round. */
6782 if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
6785 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
6786 tree gnu_conv, gnu_zero, gnu_comp, calc_type;
6787 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
6788 const struct real_format *fmt;
6790 /* The following calculations depend on proper rounding to even
6791 of each arithmetic operation. In order to prevent excess
6792 precision from spoiling this property, use the widest hardware
6793 floating-point type if FP_ARITH_MAY_WIDEN is true. */
6795 = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
6797 /* FIXME: Should not have padding in the first place. */
6798 if (TYPE_IS_PADDING_P (calc_type))
6799 calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
6801 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
6802 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
6803 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
6804 REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
6805 half_minus_pred_half);
6806 gnu_pred_half = build_real (calc_type, pred_half);
6808 /* If the input is strictly negative, subtract this value
6809 and otherwise add it from the input. For 0.5, the result
6810 is exactly between 1.0 and the machine number preceding 1.0
6811 (for calc_type). Since the last bit of 1.0 is even, this 0.5
6812 will round to 1.0, while all other number with an absolute
6813 value less than 0.5 round to 0.0. For larger numbers exactly
6814 halfway between integers, rounding will always be correct as
6815 the true mathematical result will be closer to the higher
6816 integer compared to the lower one. So, this constant works
6817 for all floating-point numbers.
6819 The reason to use the same constant with subtract/add instead
6820 of a positive and negative constant is to allow the comparison
6821 to be scheduled in parallel with retrieval of the constant and
6822 conversion of the input to the calc_type (if necessary). */
6824 gnu_zero = convert (gnu_in_basetype, integer_zero_node);
6825 gnu_result = gnat_protect_expr (gnu_result);
6826 gnu_conv = convert (calc_type, gnu_result);
6828 = fold_build2 (GE_EXPR, integer_type_node, gnu_result, gnu_zero);
6830 = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
6831 gnu_subtract_pred_half
6832 = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
6833 gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
6834 gnu_add_pred_half, gnu_subtract_pred_half);
6837 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
6838 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
6839 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
6840 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
6842 gnu_result = convert (gnu_base_type, gnu_result);
6844 /* Finally, do the range check if requested. Note that if the result type
6845 is a modular type, the range check is actually an overflow check. */
6847 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
6848 && TYPE_MODULAR_P (gnu_base_type) && overflowp))
6849 gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
6851 return convert (gnu_type, gnu_result);
6854 /* Return true if TYPE is a smaller packable version of RECORD_TYPE. */
6857 smaller_packable_type_p (tree type, tree record_type)
6861 /* We're not interested in variants here. */
6862 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (record_type))
6865 /* Like a variant, a packable version keeps the original TYPE_NAME. */
6866 if (TYPE_NAME (type) != TYPE_NAME (record_type))
6869 size = TYPE_SIZE (type);
6870 rsize = TYPE_SIZE (record_type);
6872 if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (rsize) == INTEGER_CST))
6875 return tree_int_cst_lt (size, rsize) != 0;
6878 /* Return true if GNU_EXPR can be directly addressed. This is the case
6879 unless it is an expression involving computation or if it involves a
6880 reference to a bitfield or to an object not sufficiently aligned for
6881 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
6882 be directly addressed as an object of this type.
6884 *** Notes on addressability issues in the Ada compiler ***
6886 This predicate is necessary in order to bridge the gap between Gigi
6887 and the middle-end about addressability of GENERIC trees. A tree
6888 is said to be addressable if it can be directly addressed, i.e. if
6889 its address can be taken, is a multiple of the type's alignment on
6890 strict-alignment architectures and returns the first storage unit
6891 assigned to the object represented by the tree.
6893 In the C family of languages, everything is in practice addressable
6894 at the language level, except for bit-fields. This means that these
6895 compilers will take the address of any tree that doesn't represent
6896 a bit-field reference and expect the result to be the first storage
6897 unit assigned to the object. Even in cases where this will result
6898 in unaligned accesses at run time, nothing is supposed to be done
6899 and the program is considered as erroneous instead (see PR c/18287).
6901 The implicit assumptions made in the middle-end are in keeping with
6902 the C viewpoint described above:
6903 - the address of a bit-field reference is supposed to be never
6904 taken; the compiler (generally) will stop on such a construct,
6905 - any other tree is addressable if it is formally addressable,
6906 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
6908 In Ada, the viewpoint is the opposite one: nothing is addressable
6909 at the language level unless explicitly declared so. This means
6910 that the compiler will both make sure that the trees representing
6911 references to addressable ("aliased" in Ada parlance) objects are
6912 addressable and make no real attempts at ensuring that the trees
6913 representing references to non-addressable objects are addressable.
6915 In the first case, Ada is effectively equivalent to C and handing
6916 down the direct result of applying ADDR_EXPR to these trees to the
6917 middle-end works flawlessly. In the second case, Ada cannot afford
6918 to consider the program as erroneous if the address of trees that
6919 are not addressable is requested for technical reasons, unlike C;
6920 as a consequence, the Ada compiler must arrange for either making
6921 sure that this address is not requested in the middle-end or for
6922 compensating by inserting temporaries if it is requested in Gigi.
6924 The first goal can be achieved because the middle-end should not
6925 request the address of non-addressable trees on its own; the only
6926 exception is for the invocation of low-level block operations like
6927 memcpy, for which the addressability requirements are lower since
6928 the type's alignment can be disregarded. In practice, this means
6929 that Gigi must make sure that such operations cannot be applied to
6930 non-BLKmode bit-fields.
6932 The second goal is achieved by means of the addressable_p predicate
6933 and by inserting SAVE_EXPRs around trees deemed non-addressable.
6934 They will be turned during gimplification into proper temporaries
6935 whose address will be used in lieu of that of the original tree. */
6938 addressable_p (tree gnu_expr, tree gnu_type)
6940 /* The size of the real type of the object must not be smaller than
6941 that of the expected type, otherwise an indirect access in the
6942 latter type would be larger than the object. Only records need
6943 to be considered in practice. */
6945 && TREE_CODE (gnu_type) == RECORD_TYPE
6946 && smaller_packable_type_p (TREE_TYPE (gnu_expr), gnu_type))
6949 switch (TREE_CODE (gnu_expr))
6955 /* All DECLs are addressable: if they are in a register, we can force
6959 case UNCONSTRAINED_ARRAY_REF:
6961 /* Taking the address of a dereference yields the original pointer. */
6966 /* Taking the address yields a pointer to the constant pool. */
6970 /* Taking the address of a static constructor yields a pointer to the
6971 tree constant pool. */
6972 return TREE_STATIC (gnu_expr) ? true : false;
6983 /* All rvalues are deemed addressable since taking their address will
6984 force a temporary to be created by the middle-end. */
6988 /* The address of a compound expression is that of its 2nd operand. */
6989 return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
6992 /* We accept &COND_EXPR as soon as both operands are addressable and
6993 expect the outcome to be the address of the selected operand. */
6994 return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
6995 && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
6998 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
6999 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
7000 the field is sufficiently aligned, in case it is subject
7001 to a pragma Component_Alignment. But we don't need to
7002 check the alignment of the containing record, as it is
7003 guaranteed to be not smaller than that of its most
7004 aligned field that is not a bit-field. */
7005 && (!STRICT_ALIGNMENT
7006 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
7007 >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
7008 /* The field of a padding record is always addressable. */
7009 || TYPE_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
7010 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7012 case ARRAY_REF: case ARRAY_RANGE_REF:
7013 case REALPART_EXPR: case IMAGPART_EXPR:
7015 return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
7018 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
7019 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7021 case VIEW_CONVERT_EXPR:
7023 /* This is addressable if we can avoid a copy. */
7024 tree type = TREE_TYPE (gnu_expr);
7025 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
7026 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
7027 && (!STRICT_ALIGNMENT
7028 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7029 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
7030 || ((TYPE_MODE (type) == BLKmode
7031 || TYPE_MODE (inner_type) == BLKmode)
7032 && (!STRICT_ALIGNMENT
7033 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
7034 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
7035 || TYPE_ALIGN_OK (type)
7036 || TYPE_ALIGN_OK (inner_type))))
7037 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
7045 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
7046 a separate Freeze node exists, delay the bulk of the processing. Otherwise
7047 make a GCC type for GNAT_ENTITY and set up the correspondence. */
7050 process_type (Entity_Id gnat_entity)
7053 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
7056 /* If we are to delay elaboration of this type, just do any
7057 elaborations needed for expressions within the declaration and
7058 make a dummy type entry for this node and its Full_View (if
7059 any) in case something points to it. Don't do this if it
7060 has already been done (the only way that can happen is if
7061 the private completion is also delayed). */
7062 if (Present (Freeze_Node (gnat_entity))
7063 || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7064 && Present (Full_View (gnat_entity))
7065 && Freeze_Node (Full_View (gnat_entity))
7066 && !present_gnu_tree (Full_View (gnat_entity))))
7068 elaborate_entity (gnat_entity);
7072 tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
7073 save_gnu_tree (gnat_entity, gnu_decl, false);
7074 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
7075 && Present (Full_View (gnat_entity)))
7076 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
7082 /* If we saved away a dummy type for this node it means that this
7083 made the type that corresponds to the full type of an incomplete
7084 type. Clear that type for now and then update the type in the
7088 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
7089 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
7091 save_gnu_tree (gnat_entity, NULL_TREE, false);
7094 /* Now fully elaborate the type. */
7095 gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
7096 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
7098 /* If we have an old type and we've made pointers to this type,
7099 update those pointers. */
7101 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
7102 TREE_TYPE (gnu_new));
7104 /* If this is a record type corresponding to a task or protected type
7105 that is a completion of an incomplete type, perform a similar update
7106 on the type. ??? Including protected types here is a guess. */
7107 if (IN (Ekind (gnat_entity), Record_Kind)
7108 && Is_Concurrent_Record_Type (gnat_entity)
7109 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
7112 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
7114 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7116 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
7119 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
7120 TREE_TYPE (gnu_new));
7124 /* GNAT_ENTITY is the type of the resulting constructors,
7125 GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
7126 and GNU_TYPE is the GCC type of the corresponding record.
7128 Return a CONSTRUCTOR to build the record. */
7131 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
7133 tree gnu_list, gnu_result;
7135 /* We test for GNU_FIELD being empty in the case where a variant
7136 was the last thing since we don't take things off GNAT_ASSOC in
7137 that case. We check GNAT_ASSOC in case we have a variant, but it
7140 for (gnu_list = NULL_TREE; Present (gnat_assoc);
7141 gnat_assoc = Next (gnat_assoc))
7143 Node_Id gnat_field = First (Choices (gnat_assoc));
7144 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
7145 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
7147 /* The expander is supposed to put a single component selector name
7148 in every record component association. */
7149 gcc_assert (No (Next (gnat_field)));
7151 /* Ignore fields that have Corresponding_Discriminants since we'll
7152 be setting that field in the parent. */
7153 if (Present (Corresponding_Discriminant (Entity (gnat_field)))
7154 && Is_Tagged_Type (Scope (Entity (gnat_field))))
7157 /* Also ignore discriminants of Unchecked_Unions. */
7158 else if (Is_Unchecked_Union (gnat_entity)
7159 && Ekind (Entity (gnat_field)) == E_Discriminant)
7162 /* Before assigning a value in an aggregate make sure range checks
7163 are done if required. Then convert to the type of the field. */
7164 if (Do_Range_Check (Expression (gnat_assoc)))
7165 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
7167 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
7169 /* Add the field and expression to the list. */
7170 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
7173 gnu_result = extract_values (gnu_list, gnu_type);
7175 #ifdef ENABLE_CHECKING
7179 /* Verify every entry in GNU_LIST was used. */
7180 for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
7181 gcc_assert (TREE_ADDRESSABLE (gnu_field));
7188 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
7189 the first element of an array aggregate. It may itself be an aggregate.
7190 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate.
7191 GNAT_COMPONENT_TYPE is the type of the array component; it is needed
7192 for range checking. */
7195 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
7196 Entity_Id gnat_component_type)
7198 tree gnu_expr_list = NULL_TREE;
7199 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
7202 for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
7204 /* If the expression is itself an array aggregate then first build the
7205 innermost constructor if it is part of our array (multi-dimensional
7207 if (Nkind (gnat_expr) == N_Aggregate
7208 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
7209 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
7210 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
7211 TREE_TYPE (gnu_array_type),
7212 gnat_component_type);
7215 gnu_expr = gnat_to_gnu (gnat_expr);
7217 /* Before assigning the element to the array, make sure it is
7219 if (Do_Range_Check (gnat_expr))
7220 gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty);
7224 = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr),
7227 gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
7230 return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
7233 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
7234 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
7235 of the associations that are from RECORD_TYPE. If we see an internal
7236 record, make a recursive call to fill it in as well. */
7239 extract_values (tree values, tree record_type)
7241 tree result = NULL_TREE;
7244 for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
7248 /* _Parent is an internal field, but may have values in the aggregate,
7249 so check for values first. */
7250 if ((tem = purpose_member (field, values)))
7252 value = TREE_VALUE (tem);
7253 TREE_ADDRESSABLE (tem) = 1;
7256 else if (DECL_INTERNAL_P (field))
7258 value = extract_values (values, TREE_TYPE (field));
7259 if (TREE_CODE (value) == CONSTRUCTOR
7260 && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
7264 /* If we have a record subtype, the names will match, but not the
7265 actual FIELD_DECLs. */
7266 for (tem = values; tem; tem = TREE_CHAIN (tem))
7267 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
7269 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
7270 TREE_ADDRESSABLE (tem) = 1;
7276 result = tree_cons (field, value, result);
7279 return gnat_build_constructor (record_type, nreverse (result));
7282 /* EXP is to be treated as an array or record. Handle the cases when it is
7283 an access object and perform the required dereferences. */
7286 maybe_implicit_deref (tree exp)
7288 /* If the type is a pointer, dereference it. */
7289 if (POINTER_TYPE_P (TREE_TYPE (exp))
7290 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp)))
7291 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
7293 /* If we got a padded type, remove it too. */
7294 if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
7295 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
7300 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
7301 location and false if it doesn't. In the former case, set the Gigi global
7302 variable REF_FILENAME to the simple debug file name as given by sinput. */
7305 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
7307 if (Sloc == No_Location)
7310 if (Sloc <= Standard_Location)
7312 *locus = BUILTINS_LOCATION;
7317 Source_File_Index file = Get_Source_File_Index (Sloc);
7318 Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
7319 Column_Number column = Get_Column_Number (Sloc);
7320 struct line_map *map = &line_table->maps[file - 1];
7322 /* Translate the location according to the line-map.h formula. */
7323 *locus = map->start_location
7324 + ((line - map->to_line) << map->column_bits)
7325 + (column & ((1 << map->column_bits) - 1));
7329 = IDENTIFIER_POINTER
7331 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
7336 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
7337 don't do anything if it doesn't correspond to a source location. */
7340 set_expr_location_from_node (tree node, Node_Id gnat_node)
7344 if (!Sloc_to_locus (Sloc (gnat_node), &locus))
7347 SET_EXPR_LOCATION (node, locus);
7350 /* Return a colon-separated list of encodings contained in encoded Ada
7354 extract_encoding (const char *name)
7356 char *encoding = GGC_NEWVEC (char, strlen (name));
7357 get_encoding (name, encoding);
7361 /* Extract the Ada name from an encoded name. */
7364 decode_name (const char *name)
7366 char *decoded = GGC_NEWVEC (char, strlen (name) * 2 + 60);
7367 __gnat_decode (name, decoded, 0);
7371 /* Post an error message. MSG is the error message, properly annotated.
7372 NODE is the node at which to post the error and the node to use for the
7373 "&" substitution. */
7376 post_error (const char *msg, Node_Id node)
7378 String_Template temp;
7381 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7382 fp.Array = msg, fp.Bounds = &temp;
7384 Error_Msg_N (fp, node);
7387 /* Similar, but NODE is the node at which to post the error and ENT
7388 is the node to use for the "&" substitution. */
7391 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
7393 String_Template temp;
7396 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7397 fp.Array = msg, fp.Bounds = &temp;
7399 Error_Msg_NE (fp, node, ent);
7402 /* Similar, but NODE is the node at which to post the error, ENT is the node
7403 to use for the "&" substitution, and N is the number to use for the ^. */
7406 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
7408 String_Template temp;
7411 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
7412 fp.Array = msg, fp.Bounds = &temp;
7413 Error_Msg_Uint_1 = UI_From_Int (n);
7416 Error_Msg_NE (fp, node, ent);
7419 /* Similar to post_error_ne_num, but T is a GCC tree representing the
7420 number to write. If the tree represents a constant that fits within
7421 a host integer, the text inside curly brackets in MSG will be output
7422 (presumably including a '^'). Otherwise that text will not be output
7423 and the text inside square brackets will be output instead. */
7426 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
7428 char *newmsg = XALLOCAVEC (char, strlen (msg) + 1);
7429 String_Template temp = {1, 0};
7431 char start_yes, end_yes, start_no, end_no;
7435 fp.Array = newmsg, fp.Bounds = &temp;
7437 if (host_integerp (t, 1)
7438 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
7441 (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
7445 Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
7446 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
7449 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
7451 for (p = msg, q = newmsg; *p; p++)
7453 if (*p == start_yes)
7454 for (p++; *p != end_yes; p++)
7456 else if (*p == start_no)
7457 for (p++; *p != end_no; p++)
7465 temp.High_Bound = strlen (newmsg);
7467 Error_Msg_NE (fp, node, ent);
7470 /* Similar to post_error_ne_tree, except that NUM is a second
7471 integer to write in the message. */
7474 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
7477 Error_Msg_Uint_2 = UI_From_Int (num);
7478 post_error_ne_tree (msg, node, ent, t);
7481 /* Initialize the table that maps GNAT codes to GCC codes for simple
7482 binary and unary operations. */
7485 init_code_table (void)
7487 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
7488 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
7490 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
7491 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
7492 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
7493 gnu_codes[N_Op_Eq] = EQ_EXPR;
7494 gnu_codes[N_Op_Ne] = NE_EXPR;
7495 gnu_codes[N_Op_Lt] = LT_EXPR;
7496 gnu_codes[N_Op_Le] = LE_EXPR;
7497 gnu_codes[N_Op_Gt] = GT_EXPR;
7498 gnu_codes[N_Op_Ge] = GE_EXPR;
7499 gnu_codes[N_Op_Add] = PLUS_EXPR;
7500 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
7501 gnu_codes[N_Op_Multiply] = MULT_EXPR;
7502 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
7503 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
7504 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
7505 gnu_codes[N_Op_Abs] = ABS_EXPR;
7506 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
7507 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
7508 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
7509 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
7510 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
7511 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
7514 /* Return a label to branch to for the exception type in KIND or NULL_TREE
7518 get_exception_label (char kind)
7520 if (kind == N_Raise_Constraint_Error)
7521 return TREE_VALUE (gnu_constraint_error_label_stack);
7522 else if (kind == N_Raise_Storage_Error)
7523 return TREE_VALUE (gnu_storage_error_label_stack);
7524 else if (kind == N_Raise_Program_Error)
7525 return TREE_VALUE (gnu_program_error_label_stack);
7530 #include "gt-ada-trans.h"