PR c/81544 - attribute noreturn and warn_unused_result on the same function accepted
[official-gcc.git] / gcc / ada / gcc-interface / utils.c
blobddeeb0370aed18cb0974defa211b2b931058286e
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * U T I L S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2017, Free Software Foundation, Inc. *
10 * *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
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 along with GCC; see the file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
20 * *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
23 * *
24 ****************************************************************************/
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "target.h"
30 #include "function.h"
31 #include "tree.h"
32 #include "stringpool.h"
33 #include "cgraph.h"
34 #include "diagnostic.h"
35 #include "alias.h"
36 #include "fold-const.h"
37 #include "stor-layout.h"
38 #include "attribs.h"
39 #include "varasm.h"
40 #include "toplev.h"
41 #include "output.h"
42 #include "debug.h"
43 #include "convert.h"
44 #include "common/common-target.h"
45 #include "langhooks.h"
46 #include "tree-dump.h"
47 #include "tree-inline.h"
49 #include "ada.h"
50 #include "types.h"
51 #include "atree.h"
52 #include "nlists.h"
53 #include "uintp.h"
54 #include "fe.h"
55 #include "sinfo.h"
56 #include "einfo.h"
57 #include "ada-tree.h"
58 #include "gigi.h"
60 /* If nonzero, pretend we are allocating at global level. */
61 int force_global;
63 /* The default alignment of "double" floating-point types, i.e. floating
64 point types whose size is equal to 64 bits, or 0 if this alignment is
65 not specifically capped. */
66 int double_float_alignment;
68 /* The default alignment of "double" or larger scalar types, i.e. scalar
69 types whose size is greater or equal to 64 bits, or 0 if this alignment
70 is not specifically capped. */
71 int double_scalar_alignment;
73 /* True if floating-point arithmetics may use wider intermediate results. */
74 bool fp_arith_may_widen = true;
76 /* Tree nodes for the various types and decls we create. */
77 tree gnat_std_decls[(int) ADT_LAST];
79 /* Functions to call for each of the possible raise reasons. */
80 tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
82 /* Likewise, but with extra info for each of the possible raise reasons. */
83 tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1];
85 /* Forward declarations for handlers of attributes. */
86 static tree handle_const_attribute (tree *, tree, tree, int, bool *);
87 static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *);
88 static tree handle_pure_attribute (tree *, tree, tree, int, bool *);
89 static tree handle_novops_attribute (tree *, tree, tree, int, bool *);
90 static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *);
91 static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *);
92 static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *);
93 static tree handle_noinline_attribute (tree *, tree, tree, int, bool *);
94 static tree handle_noclone_attribute (tree *, tree, tree, int, bool *);
95 static tree handle_leaf_attribute (tree *, tree, tree, int, bool *);
96 static tree handle_always_inline_attribute (tree *, tree, tree, int, bool *);
97 static tree handle_malloc_attribute (tree *, tree, tree, int, bool *);
98 static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *);
99 static tree handle_vector_size_attribute (tree *, tree, tree, int, bool *);
100 static tree handle_vector_type_attribute (tree *, tree, tree, int, bool *);
102 /* Fake handler for attributes we don't properly support, typically because
103 they'd require dragging a lot of the common-c front-end circuitry. */
104 static tree fake_attribute_handler (tree *, tree, tree, int, bool *);
106 /* Table of machine-independent internal attributes for Ada. We support
107 this minimal set of attributes to accommodate the needs of builtins. */
108 const struct attribute_spec gnat_internal_attribute_table[] =
110 /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler,
111 affects_type_identity } */
112 { "const", 0, 0, true, false, false, handle_const_attribute,
113 false, NULL },
114 { "nothrow", 0, 0, true, false, false, handle_nothrow_attribute,
115 false, NULL },
116 { "pure", 0, 0, true, false, false, handle_pure_attribute,
117 false, NULL },
118 { "no vops", 0, 0, true, false, false, handle_novops_attribute,
119 false, NULL },
120 { "nonnull", 0, -1, false, true, true, handle_nonnull_attribute,
121 false, NULL },
122 { "sentinel", 0, 1, false, true, true, handle_sentinel_attribute,
123 false, NULL },
124 { "noreturn", 0, 0, true, false, false, handle_noreturn_attribute,
125 false, NULL },
126 { "noinline", 0, 0, true, false, false, handle_noinline_attribute,
127 false, NULL },
128 { "noclone", 0, 0, true, false, false, handle_noclone_attribute,
129 false, NULL },
130 { "leaf", 0, 0, true, false, false, handle_leaf_attribute,
131 false, NULL },
132 { "always_inline",0, 0, true, false, false, handle_always_inline_attribute,
133 false, NULL },
134 { "malloc", 0, 0, true, false, false, handle_malloc_attribute,
135 false, NULL },
136 { "type generic", 0, 0, false, true, true, handle_type_generic_attribute,
137 false, NULL },
139 { "vector_size", 1, 1, false, true, false, handle_vector_size_attribute,
140 false, NULL },
141 { "vector_type", 0, 0, false, true, false, handle_vector_type_attribute,
142 false, NULL },
143 { "may_alias", 0, 0, false, true, false, NULL, false, NULL },
145 /* ??? format and format_arg are heavy and not supported, which actually
146 prevents support for stdio builtins, which we however declare as part
147 of the common builtins.def contents. */
148 { "format", 3, 3, false, true, true, fake_attribute_handler, false,
149 NULL },
150 { "format_arg", 1, 1, false, true, true, fake_attribute_handler, false,
151 NULL },
153 { NULL, 0, 0, false, false, false, NULL, false, NULL }
156 /* Associates a GNAT tree node to a GCC tree node. It is used in
157 `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
158 of `save_gnu_tree' for more info. */
159 static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
161 #define GET_GNU_TREE(GNAT_ENTITY) \
162 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id]
164 #define SET_GNU_TREE(GNAT_ENTITY,VAL) \
165 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL)
167 #define PRESENT_GNU_TREE(GNAT_ENTITY) \
168 (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
170 /* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */
171 static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table;
173 #define GET_DUMMY_NODE(GNAT_ENTITY) \
174 dummy_node_table[(GNAT_ENTITY) - First_Node_Id]
176 #define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \
177 dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL)
179 #define PRESENT_DUMMY_NODE(GNAT_ENTITY) \
180 (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
182 /* This variable keeps a table for types for each precision so that we only
183 allocate each of them once. Signed and unsigned types are kept separate.
185 Note that these types are only used when fold-const requests something
186 special. Perhaps we should NOT share these types; we'll see how it
187 goes later. */
188 static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
190 /* Likewise for float types, but record these by mode. */
191 static GTY(()) tree float_types[NUM_MACHINE_MODES];
193 /* For each binding contour we allocate a binding_level structure to indicate
194 the binding depth. */
196 struct GTY((chain_next ("%h.chain"))) gnat_binding_level {
197 /* The binding level containing this one (the enclosing binding level). */
198 struct gnat_binding_level *chain;
199 /* The BLOCK node for this level. */
200 tree block;
201 /* If nonzero, the setjmp buffer that needs to be updated for any
202 variable-sized definition within this context. */
203 tree jmpbuf_decl;
206 /* The binding level currently in effect. */
207 static GTY(()) struct gnat_binding_level *current_binding_level;
209 /* A chain of gnat_binding_level structures awaiting reuse. */
210 static GTY((deletable)) struct gnat_binding_level *free_binding_level;
212 /* The context to be used for global declarations. */
213 static GTY(()) tree global_context;
215 /* An array of global declarations. */
216 static GTY(()) vec<tree, va_gc> *global_decls;
218 /* An array of builtin function declarations. */
219 static GTY(()) vec<tree, va_gc> *builtin_decls;
221 /* A chain of unused BLOCK nodes. */
222 static GTY((deletable)) tree free_block_chain;
224 /* A hash table of padded types. It is modelled on the generic type
225 hash table in tree.c, which must thus be used as a reference. */
227 struct GTY((for_user)) pad_type_hash
229 hashval_t hash;
230 tree type;
233 struct pad_type_hasher : ggc_cache_ptr_hash<pad_type_hash>
235 static inline hashval_t hash (pad_type_hash *t) { return t->hash; }
236 static bool equal (pad_type_hash *a, pad_type_hash *b);
238 static int
239 keep_cache_entry (pad_type_hash *&t)
241 return ggc_marked_p (t->type);
245 static GTY ((cache)) hash_table<pad_type_hasher> *pad_type_hash_table;
247 static tree merge_sizes (tree, tree, tree, bool, bool);
248 static tree fold_bit_position (const_tree);
249 static tree compute_related_constant (tree, tree);
250 static tree split_plus (tree, tree *);
251 static tree float_type_for_precision (int, machine_mode);
252 static tree convert_to_fat_pointer (tree, tree);
253 static unsigned int scale_by_factor_of (tree, unsigned int);
254 static bool potential_alignment_gap (tree, tree, tree);
256 /* Linked list used as a queue to defer the initialization of the DECL_CONTEXT
257 of ..._DECL nodes and of the TYPE_CONTEXT of ..._TYPE nodes. */
258 struct deferred_decl_context_node
260 /* The ..._DECL node to work on. */
261 tree decl;
263 /* The corresponding entity's Scope. */
264 Entity_Id gnat_scope;
266 /* The value of force_global when DECL was pushed. */
267 int force_global;
269 /* The list of ..._TYPE nodes to propagate the context to. */
270 vec<tree> types;
272 /* The next queue item. */
273 struct deferred_decl_context_node *next;
276 static struct deferred_decl_context_node *deferred_decl_context_queue = NULL;
278 /* Defer the initialization of DECL's DECL_CONTEXT attribute, scheduling to
279 feed it with the elaboration of GNAT_SCOPE. */
280 static struct deferred_decl_context_node *
281 add_deferred_decl_context (tree decl, Entity_Id gnat_scope, int force_global);
283 /* Defer the initialization of TYPE's TYPE_CONTEXT attribute, scheduling to
284 feed it with the DECL_CONTEXT computed as part of N as soon as it is
285 computed. */
286 static void add_deferred_type_context (struct deferred_decl_context_node *n,
287 tree type);
289 /* Initialize data structures of the utils.c module. */
291 void
292 init_gnat_utils (void)
294 /* Initialize the association of GNAT nodes to GCC trees. */
295 associate_gnat_to_gnu = ggc_cleared_vec_alloc<tree> (max_gnat_nodes);
297 /* Initialize the association of GNAT nodes to GCC trees as dummies. */
298 dummy_node_table = ggc_cleared_vec_alloc<tree> (max_gnat_nodes);
300 /* Initialize the hash table of padded types. */
301 pad_type_hash_table = hash_table<pad_type_hasher>::create_ggc (512);
304 /* Destroy data structures of the utils.c module. */
306 void
307 destroy_gnat_utils (void)
309 /* Destroy the association of GNAT nodes to GCC trees. */
310 ggc_free (associate_gnat_to_gnu);
311 associate_gnat_to_gnu = NULL;
313 /* Destroy the association of GNAT nodes to GCC trees as dummies. */
314 ggc_free (dummy_node_table);
315 dummy_node_table = NULL;
317 /* Destroy the hash table of padded types. */
318 pad_type_hash_table->empty ();
319 pad_type_hash_table = NULL;
322 /* GNAT_ENTITY is a GNAT tree node for an entity. Associate GNU_DECL, a GCC
323 tree node, with GNAT_ENTITY. If GNU_DECL is not a ..._DECL node, abort.
324 If NO_CHECK is true, the latter check is suppressed.
326 If GNU_DECL is zero, reset a previous association. */
328 void
329 save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check)
331 /* Check that GNAT_ENTITY is not already defined and that it is being set
332 to something which is a decl. If that is not the case, this usually
333 means GNAT_ENTITY is defined twice, but occasionally is due to some
334 Gigi problem. */
335 gcc_assert (!(gnu_decl
336 && (PRESENT_GNU_TREE (gnat_entity)
337 || (!no_check && !DECL_P (gnu_decl)))));
339 SET_GNU_TREE (gnat_entity, gnu_decl);
342 /* GNAT_ENTITY is a GNAT tree node for an entity. Return the GCC tree node
343 that was associated with it. If there is no such tree node, abort.
345 In some cases, such as delayed elaboration or expressions that need to
346 be elaborated only once, GNAT_ENTITY is really not an entity. */
348 tree
349 get_gnu_tree (Entity_Id gnat_entity)
351 gcc_assert (PRESENT_GNU_TREE (gnat_entity));
352 return GET_GNU_TREE (gnat_entity);
355 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
357 bool
358 present_gnu_tree (Entity_Id gnat_entity)
360 return PRESENT_GNU_TREE (gnat_entity);
363 /* Make a dummy type corresponding to GNAT_TYPE. */
365 tree
366 make_dummy_type (Entity_Id gnat_type)
368 Entity_Id gnat_equiv = Gigi_Equivalent_Type (Underlying_Type (gnat_type));
369 tree gnu_type, debug_type;
371 /* If there was no equivalent type (can only happen when just annotating
372 types) or underlying type, go back to the original type. */
373 if (No (gnat_equiv))
374 gnat_equiv = gnat_type;
376 /* If it there already a dummy type, use that one. Else make one. */
377 if (PRESENT_DUMMY_NODE (gnat_equiv))
378 return GET_DUMMY_NODE (gnat_equiv);
380 /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make
381 an ENUMERAL_TYPE. */
382 gnu_type = make_node (Is_Record_Type (gnat_equiv)
383 ? tree_code_for_record_type (gnat_equiv)
384 : ENUMERAL_TYPE);
385 TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
386 TYPE_DUMMY_P (gnu_type) = 1;
387 TYPE_STUB_DECL (gnu_type)
388 = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
389 if (Is_By_Reference_Type (gnat_equiv))
390 TYPE_BY_REFERENCE_P (gnu_type) = 1;
392 SET_DUMMY_NODE (gnat_equiv, gnu_type);
394 /* Create a debug type so that debug info consumers only see an unspecified
395 type. */
396 if (Needs_Debug_Info (gnat_type))
398 debug_type = make_node (LANG_TYPE);
399 SET_TYPE_DEBUG_TYPE (gnu_type, debug_type);
401 TYPE_NAME (debug_type) = TYPE_NAME (gnu_type);
402 TYPE_ARTIFICIAL (debug_type) = TYPE_ARTIFICIAL (gnu_type);
405 return gnu_type;
408 /* Return the dummy type that was made for GNAT_TYPE, if any. */
410 tree
411 get_dummy_type (Entity_Id gnat_type)
413 return GET_DUMMY_NODE (gnat_type);
416 /* Build dummy fat and thin pointer types whose designated type is specified
417 by GNAT_DESIG_TYPE/GNU_DESIG_TYPE and attach them to the latter. */
419 void
420 build_dummy_unc_pointer_types (Entity_Id gnat_desig_type, tree gnu_desig_type)
422 tree gnu_template_type, gnu_ptr_template, gnu_array_type, gnu_ptr_array;
423 tree gnu_fat_type, fields, gnu_object_type;
425 gnu_template_type = make_node (RECORD_TYPE);
426 TYPE_NAME (gnu_template_type) = create_concat_name (gnat_desig_type, "XUB");
427 TYPE_DUMMY_P (gnu_template_type) = 1;
428 gnu_ptr_template = build_pointer_type (gnu_template_type);
430 gnu_array_type = make_node (ENUMERAL_TYPE);
431 TYPE_NAME (gnu_array_type) = create_concat_name (gnat_desig_type, "XUA");
432 TYPE_DUMMY_P (gnu_array_type) = 1;
433 gnu_ptr_array = build_pointer_type (gnu_array_type);
435 gnu_fat_type = make_node (RECORD_TYPE);
436 /* Build a stub DECL to trigger the special processing for fat pointer types
437 in gnat_pushdecl. */
438 TYPE_NAME (gnu_fat_type)
439 = create_type_stub_decl (create_concat_name (gnat_desig_type, "XUP"),
440 gnu_fat_type);
441 fields = create_field_decl (get_identifier ("P_ARRAY"), gnu_ptr_array,
442 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
443 DECL_CHAIN (fields)
444 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
445 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
446 finish_fat_pointer_type (gnu_fat_type, fields);
447 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_desig_type);
448 /* Suppress debug info until after the type is completed. */
449 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 1;
451 gnu_object_type = make_node (RECORD_TYPE);
452 TYPE_NAME (gnu_object_type) = create_concat_name (gnat_desig_type, "XUT");
453 TYPE_DUMMY_P (gnu_object_type) = 1;
455 TYPE_POINTER_TO (gnu_desig_type) = gnu_fat_type;
456 TYPE_REFERENCE_TO (gnu_desig_type) = gnu_fat_type;
457 TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type;
460 /* Return true if we are in the global binding level. */
462 bool
463 global_bindings_p (void)
465 return force_global || !current_function_decl;
468 /* Enter a new binding level. */
470 void
471 gnat_pushlevel (void)
473 struct gnat_binding_level *newlevel = NULL;
475 /* Reuse a struct for this binding level, if there is one. */
476 if (free_binding_level)
478 newlevel = free_binding_level;
479 free_binding_level = free_binding_level->chain;
481 else
482 newlevel = ggc_alloc<gnat_binding_level> ();
484 /* Use a free BLOCK, if any; otherwise, allocate one. */
485 if (free_block_chain)
487 newlevel->block = free_block_chain;
488 free_block_chain = BLOCK_CHAIN (free_block_chain);
489 BLOCK_CHAIN (newlevel->block) = NULL_TREE;
491 else
492 newlevel->block = make_node (BLOCK);
494 /* Point the BLOCK we just made to its parent. */
495 if (current_binding_level)
496 BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
498 BLOCK_VARS (newlevel->block) = NULL_TREE;
499 BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
500 TREE_USED (newlevel->block) = 1;
502 /* Add this level to the front of the chain (stack) of active levels. */
503 newlevel->chain = current_binding_level;
504 newlevel->jmpbuf_decl = NULL_TREE;
505 current_binding_level = newlevel;
508 /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
509 and point FNDECL to this BLOCK. */
511 void
512 set_current_block_context (tree fndecl)
514 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
515 DECL_INITIAL (fndecl) = current_binding_level->block;
516 set_block_for_group (current_binding_level->block);
519 /* Set the jmpbuf_decl for the current binding level to DECL. */
521 void
522 set_block_jmpbuf_decl (tree decl)
524 current_binding_level->jmpbuf_decl = decl;
527 /* Get the jmpbuf_decl, if any, for the current binding level. */
529 tree
530 get_block_jmpbuf_decl (void)
532 return current_binding_level->jmpbuf_decl;
535 /* Exit a binding level. Set any BLOCK into the current code group. */
537 void
538 gnat_poplevel (void)
540 struct gnat_binding_level *level = current_binding_level;
541 tree block = level->block;
543 BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
544 BLOCK_SUBBLOCKS (block) = blocks_nreverse (BLOCK_SUBBLOCKS (block));
546 /* If this is a function-level BLOCK don't do anything. Otherwise, if there
547 are no variables free the block and merge its subblocks into those of its
548 parent block. Otherwise, add it to the list of its parent. */
549 if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
551 else if (!BLOCK_VARS (block))
553 BLOCK_SUBBLOCKS (level->chain->block)
554 = block_chainon (BLOCK_SUBBLOCKS (block),
555 BLOCK_SUBBLOCKS (level->chain->block));
556 BLOCK_CHAIN (block) = free_block_chain;
557 free_block_chain = block;
559 else
561 BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block);
562 BLOCK_SUBBLOCKS (level->chain->block) = block;
563 TREE_USED (block) = 1;
564 set_block_for_group (block);
567 /* Free this binding structure. */
568 current_binding_level = level->chain;
569 level->chain = free_binding_level;
570 free_binding_level = level;
573 /* Exit a binding level and discard the associated BLOCK. */
575 void
576 gnat_zaplevel (void)
578 struct gnat_binding_level *level = current_binding_level;
579 tree block = level->block;
581 BLOCK_CHAIN (block) = free_block_chain;
582 free_block_chain = block;
584 /* Free this binding structure. */
585 current_binding_level = level->chain;
586 level->chain = free_binding_level;
587 free_binding_level = level;
590 /* Set the context of TYPE and its parallel types (if any) to CONTEXT. */
592 static void
593 gnat_set_type_context (tree type, tree context)
595 tree decl = TYPE_STUB_DECL (type);
597 TYPE_CONTEXT (type) = context;
599 while (decl && DECL_PARALLEL_TYPE (decl))
601 tree parallel_type = DECL_PARALLEL_TYPE (decl);
603 /* Give a context to the parallel types and their stub decl, if any.
604 Some parallel types seems to be present in multiple parallel type
605 chains, so don't mess with their context if they already have one. */
606 if (!TYPE_CONTEXT (parallel_type))
608 if (TYPE_STUB_DECL (parallel_type))
609 DECL_CONTEXT (TYPE_STUB_DECL (parallel_type)) = context;
610 TYPE_CONTEXT (parallel_type) = context;
613 decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl));
617 /* Return the innermost scope, starting at GNAT_NODE, we are be interested in
618 the debug info, or Empty if there is no such scope. If not NULL, set
619 IS_SUBPROGRAM to whether the returned entity is a subprogram. */
621 Entity_Id
622 get_debug_scope (Node_Id gnat_node, bool *is_subprogram)
624 Entity_Id gnat_entity;
626 if (is_subprogram)
627 *is_subprogram = false;
629 if (Nkind (gnat_node) == N_Defining_Identifier
630 || Nkind (gnat_node) == N_Defining_Operator_Symbol)
631 gnat_entity = Scope (gnat_node);
632 else
633 return Empty;
635 while (Present (gnat_entity))
637 switch (Ekind (gnat_entity))
639 case E_Function:
640 case E_Procedure:
641 if (Present (Protected_Body_Subprogram (gnat_entity)))
642 gnat_entity = Protected_Body_Subprogram (gnat_entity);
644 /* If the scope is a subprogram, then just rely on
645 current_function_decl, so that we don't have to defer
646 anything. This is needed because other places rely on the
647 validity of the DECL_CONTEXT attribute of FUNCTION_DECL nodes. */
648 if (is_subprogram)
649 *is_subprogram = true;
650 return gnat_entity;
652 case E_Record_Type:
653 case E_Record_Subtype:
654 return gnat_entity;
656 default:
657 /* By default, we are not interested in this particular scope: go to
658 the outer one. */
659 break;
662 gnat_entity = Scope (gnat_entity);
665 return Empty;
668 /* If N is NULL, set TYPE's context to CONTEXT. Defer this to the processing
669 of N otherwise. */
671 static void
672 defer_or_set_type_context (tree type, tree context,
673 struct deferred_decl_context_node *n)
675 if (n)
676 add_deferred_type_context (n, type);
677 else
678 gnat_set_type_context (type, context);
681 /* Return global_context, but create it first if need be. */
683 static tree
684 get_global_context (void)
686 if (!global_context)
688 global_context
689 = build_translation_unit_decl (get_identifier (main_input_filename));
690 debug_hooks->register_main_translation_unit (global_context);
693 return global_context;
696 /* Record DECL as belonging to the current lexical scope and use GNAT_NODE
697 for location information and flag propagation. */
699 void
700 gnat_pushdecl (tree decl, Node_Id gnat_node)
702 tree context = NULL_TREE;
703 struct deferred_decl_context_node *deferred_decl_context = NULL;
705 /* If explicitely asked to make DECL global or if it's an imported nested
706 object, short-circuit the regular Scope-based context computation. */
707 if (!((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || force_global == 1))
709 /* Rely on the GNAT scope, or fallback to the current_function_decl if
710 the GNAT scope reached the global scope, if it reached a subprogram
711 or the declaration is a subprogram or a variable (for them we skip
712 intermediate context types because the subprogram body elaboration
713 machinery and the inliner both expect a subprogram context).
715 Falling back to current_function_decl is necessary for implicit
716 subprograms created by gigi, such as the elaboration subprograms. */
717 bool context_is_subprogram = false;
718 const Entity_Id gnat_scope
719 = get_debug_scope (gnat_node, &context_is_subprogram);
721 if (Present (gnat_scope)
722 && !context_is_subprogram
723 && TREE_CODE (decl) != FUNCTION_DECL
724 && TREE_CODE (decl) != VAR_DECL)
725 /* Always assume the scope has not been elaborated, thus defer the
726 context propagation to the time its elaboration will be
727 available. */
728 deferred_decl_context
729 = add_deferred_decl_context (decl, gnat_scope, force_global);
731 /* External declarations (when force_global > 0) may not be in a
732 local context. */
733 else if (current_function_decl && force_global == 0)
734 context = current_function_decl;
737 /* If either we are forced to be in global mode or if both the GNAT scope and
738 the current_function_decl did not help in determining the context, use the
739 global scope. */
740 if (!deferred_decl_context && !context)
741 context = get_global_context ();
743 /* Functions imported in another function are not really nested.
744 For really nested functions mark them initially as needing
745 a static chain for uses of that flag before unnesting;
746 lower_nested_functions will then recompute it. */
747 if (TREE_CODE (decl) == FUNCTION_DECL
748 && !TREE_PUBLIC (decl)
749 && context
750 && (TREE_CODE (context) == FUNCTION_DECL
751 || decl_function_context (context)))
752 DECL_STATIC_CHAIN (decl) = 1;
754 if (!deferred_decl_context)
755 DECL_CONTEXT (decl) = context;
757 TREE_NO_WARNING (decl) = (No (gnat_node) || Warnings_Off (gnat_node));
759 /* Set the location of DECL and emit a declaration for it. */
760 if (Present (gnat_node) && !renaming_from_instantiation_p (gnat_node))
761 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl));
763 add_decl_expr (decl, gnat_node);
765 /* Put the declaration on the list. The list of declarations is in reverse
766 order. The list will be reversed later. Put global declarations in the
767 globals list and local ones in the current block. But skip TYPE_DECLs
768 for UNCONSTRAINED_ARRAY_TYPE in both cases, as they will cause trouble
769 with the debugger and aren't needed anyway. */
770 if (!(TREE_CODE (decl) == TYPE_DECL
771 && TREE_CODE (TREE_TYPE (decl)) == UNCONSTRAINED_ARRAY_TYPE))
773 /* External declarations must go to the binding level they belong to.
774 This will make corresponding imported entities are available in the
775 debugger at the proper time. */
776 if (DECL_EXTERNAL (decl)
777 && TREE_CODE (decl) == FUNCTION_DECL
778 && DECL_BUILT_IN (decl))
779 vec_safe_push (builtin_decls, decl);
780 else if (global_bindings_p ())
781 vec_safe_push (global_decls, decl);
782 else
784 DECL_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
785 BLOCK_VARS (current_binding_level->block) = decl;
789 /* For the declaration of a type, set its name either if it isn't already
790 set or if the previous type name was not derived from a source name.
791 We'd rather have the type named with a real name and all the pointer
792 types to the same object have the same node, except when the names are
793 both derived from source names. */
794 if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl))
796 tree t = TREE_TYPE (decl);
798 /* Array and pointer types aren't tagged types in the C sense so we need
799 to generate a typedef in DWARF for them and make sure it is preserved,
800 unless the type is artificial. */
801 if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)
802 && ((TREE_CODE (t) != ARRAY_TYPE && TREE_CODE (t) != POINTER_TYPE)
803 || DECL_ARTIFICIAL (decl)))
805 /* For array and pointer types, create the DECL_ORIGINAL_TYPE that will
806 generate the typedef in DWARF. Also do that for fat pointer types
807 because, even though they are tagged types in the C sense, they are
808 still XUP types attached to the base array type at this point. */
809 else if (!DECL_ARTIFICIAL (decl)
810 && (TREE_CODE (t) == ARRAY_TYPE
811 || TREE_CODE (t) == POINTER_TYPE
812 || TYPE_IS_FAT_POINTER_P (t)))
814 tree tt = build_variant_type_copy (t);
815 TYPE_NAME (tt) = decl;
816 defer_or_set_type_context (tt,
817 DECL_CONTEXT (decl),
818 deferred_decl_context);
819 TREE_TYPE (decl) = tt;
820 if (TYPE_NAME (t)
821 && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL
822 && DECL_ORIGINAL_TYPE (TYPE_NAME (t)))
823 DECL_ORIGINAL_TYPE (decl) = DECL_ORIGINAL_TYPE (TYPE_NAME (t));
824 else
825 DECL_ORIGINAL_TYPE (decl) = t;
826 /* Array types need to have a name so that they can be related to
827 their GNAT encodings. */
828 if (TREE_CODE (t) == ARRAY_TYPE && !TYPE_NAME (t))
829 TYPE_NAME (t) = DECL_NAME (decl);
830 t = NULL_TREE;
832 else if (TYPE_NAME (t)
833 && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL
834 && DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl))
836 else
837 t = NULL_TREE;
839 /* Propagate the name to all the variants, this is needed for the type
840 qualifiers machinery to work properly (see check_qualified_type).
841 Also propagate the context to them. Note that it will be propagated
842 to all parallel types too thanks to gnat_set_type_context. */
843 if (t)
844 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
845 /* ??? Because of the previous kludge, we can have variants of fat
846 pointer types with different names. */
847 if (!(TYPE_IS_FAT_POINTER_P (t)
848 && TYPE_NAME (t)
849 && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
851 TYPE_NAME (t) = decl;
852 defer_or_set_type_context (t,
853 DECL_CONTEXT (decl),
854 deferred_decl_context);
859 /* Create a record type that contains a SIZE bytes long field of TYPE with a
860 starting bit position so that it is aligned to ALIGN bits, and leaving at
861 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
862 record is guaranteed to get. GNAT_NODE is used for the position of the
863 associated TYPE_DECL. */
865 tree
866 make_aligning_type (tree type, unsigned int align, tree size,
867 unsigned int base_align, int room, Node_Id gnat_node)
869 /* We will be crafting a record type with one field at a position set to be
870 the next multiple of ALIGN past record'address + room bytes. We use a
871 record placeholder to express record'address. */
872 tree record_type = make_node (RECORD_TYPE);
873 tree record = build0 (PLACEHOLDER_EXPR, record_type);
875 tree record_addr_st
876 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
878 /* The diagram below summarizes the shape of what we manipulate:
880 <--------- pos ---------->
881 { +------------+-------------+-----------------+
882 record =>{ |############| ... | field (type) |
883 { +------------+-------------+-----------------+
884 |<-- room -->|<- voffset ->|<---- size ----->|
887 record_addr vblock_addr
889 Every length is in sizetype bytes there, except "pos" which has to be
890 set as a bit position in the GCC tree for the record. */
891 tree room_st = size_int (room);
892 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
893 tree voffset_st, pos, field;
895 tree name = TYPE_IDENTIFIER (type);
897 name = concat_name (name, "ALIGN");
898 TYPE_NAME (record_type) = name;
900 /* Compute VOFFSET and then POS. The next byte position multiple of some
901 alignment after some address is obtained by "and"ing the alignment minus
902 1 with the two's complement of the address. */
903 voffset_st = size_binop (BIT_AND_EXPR,
904 fold_build1 (NEGATE_EXPR, sizetype, vblock_addr_st),
905 size_int ((align / BITS_PER_UNIT) - 1));
907 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
908 pos = size_binop (MULT_EXPR,
909 convert (bitsizetype,
910 size_binop (PLUS_EXPR, room_st, voffset_st)),
911 bitsize_unit_node);
913 /* Craft the GCC record representation. We exceptionally do everything
914 manually here because 1) our generic circuitry is not quite ready to
915 handle the complex position/size expressions we are setting up, 2) we
916 have a strong simplifying factor at hand: we know the maximum possible
917 value of voffset, and 3) we have to set/reset at least the sizes in
918 accordance with this maximum value anyway, as we need them to convey
919 what should be "alloc"ated for this type.
921 Use -1 as the 'addressable' indication for the field to prevent the
922 creation of a bitfield. We don't need one, it would have damaging
923 consequences on the alignment computation, and create_field_decl would
924 make one without this special argument, for instance because of the
925 complex position expression. */
926 field = create_field_decl (get_identifier ("F"), type, record_type, size,
927 pos, 1, -1);
928 TYPE_FIELDS (record_type) = field;
930 SET_TYPE_ALIGN (record_type, base_align);
931 TYPE_USER_ALIGN (record_type) = 1;
933 TYPE_SIZE (record_type)
934 = size_binop (PLUS_EXPR,
935 size_binop (MULT_EXPR, convert (bitsizetype, size),
936 bitsize_unit_node),
937 bitsize_int (align + room * BITS_PER_UNIT));
938 TYPE_SIZE_UNIT (record_type)
939 = size_binop (PLUS_EXPR, size,
940 size_int (room + align / BITS_PER_UNIT));
942 SET_TYPE_MODE (record_type, BLKmode);
943 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
945 /* Declare it now since it will never be declared otherwise. This is
946 necessary to ensure that its subtrees are properly marked. */
947 create_type_decl (name, record_type, true, false, gnat_node);
949 return record_type;
952 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
953 as the field type of a packed record if IN_RECORD is true, or as the
954 component type of a packed array if IN_RECORD is false. See if we can
955 rewrite it either as a type that has non-BLKmode, which we can pack
956 tighter in the packed record case, or as a smaller type with at most
957 MAX_ALIGN alignment if the value is non-zero. If so, return the new
958 type; if not, return the original type. */
960 tree
961 make_packable_type (tree type, bool in_record, unsigned int max_align)
963 unsigned HOST_WIDE_INT size = tree_to_uhwi (TYPE_SIZE (type));
964 unsigned HOST_WIDE_INT new_size;
965 unsigned int align = TYPE_ALIGN (type);
966 unsigned int new_align;
968 /* No point in doing anything if the size is zero. */
969 if (size == 0)
970 return type;
972 tree new_type = make_node (TREE_CODE (type));
974 /* Copy the name and flags from the old type to that of the new.
975 Note that we rely on the pointer equality created here for
976 TYPE_NAME to look through conversions in various places. */
977 TYPE_NAME (new_type) = TYPE_NAME (type);
978 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
979 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
980 TYPE_REVERSE_STORAGE_ORDER (new_type) = TYPE_REVERSE_STORAGE_ORDER (type);
981 if (TREE_CODE (type) == RECORD_TYPE)
982 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
984 /* If we are in a record and have a small size, set the alignment to
985 try for an integral mode. Otherwise set it to try for a smaller
986 type with BLKmode. */
987 if (in_record && size <= MAX_FIXED_MODE_SIZE)
989 new_size = ceil_pow2 (size);
990 new_align = MIN (new_size, BIGGEST_ALIGNMENT);
991 SET_TYPE_ALIGN (new_type, new_align);
993 else
995 /* Do not try to shrink the size if the RM size is not constant. */
996 if (TYPE_CONTAINS_TEMPLATE_P (type)
997 || !tree_fits_uhwi_p (TYPE_ADA_SIZE (type)))
998 return type;
1000 /* Round the RM size up to a unit boundary to get the minimal size
1001 for a BLKmode record. Give up if it's already the size and we
1002 don't need to lower the alignment. */
1003 new_size = tree_to_uhwi (TYPE_ADA_SIZE (type));
1004 new_size = (new_size + BITS_PER_UNIT - 1) & -BITS_PER_UNIT;
1005 if (new_size == size && (max_align == 0 || align <= max_align))
1006 return type;
1008 new_align = MIN (new_size & -new_size, BIGGEST_ALIGNMENT);
1009 if (max_align > 0 && new_align > max_align)
1010 new_align = max_align;
1011 SET_TYPE_ALIGN (new_type, MIN (align, new_align));
1014 TYPE_USER_ALIGN (new_type) = 1;
1016 /* Now copy the fields, keeping the position and size as we don't want
1017 to change the layout by propagating the packedness downwards. */
1018 tree new_field_list = NULL_TREE;
1019 for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
1021 tree new_field_type = TREE_TYPE (field);
1022 tree new_field, new_size;
1024 if (RECORD_OR_UNION_TYPE_P (new_field_type)
1025 && !TYPE_FAT_POINTER_P (new_field_type)
1026 && tree_fits_uhwi_p (TYPE_SIZE (new_field_type)))
1027 new_field_type = make_packable_type (new_field_type, true, max_align);
1029 /* However, for the last field in a not already packed record type
1030 that is of an aggregate type, we need to use the RM size in the
1031 packable version of the record type, see finish_record_type. */
1032 if (!DECL_CHAIN (field)
1033 && !TYPE_PACKED (type)
1034 && RECORD_OR_UNION_TYPE_P (new_field_type)
1035 && !TYPE_FAT_POINTER_P (new_field_type)
1036 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
1037 && TYPE_ADA_SIZE (new_field_type))
1038 new_size = TYPE_ADA_SIZE (new_field_type);
1039 else
1040 new_size = DECL_SIZE (field);
1042 new_field
1043 = create_field_decl (DECL_NAME (field), new_field_type, new_type,
1044 new_size, bit_position (field),
1045 TYPE_PACKED (type),
1046 !DECL_NONADDRESSABLE_P (field));
1048 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (field);
1049 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
1050 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
1051 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (field);
1053 DECL_CHAIN (new_field) = new_field_list;
1054 new_field_list = new_field;
1057 finish_record_type (new_type, nreverse (new_field_list), 2, false);
1058 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
1059 if (TYPE_STUB_DECL (type))
1060 SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
1061 DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)));
1063 /* If this is a padding record, we never want to make the size smaller
1064 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
1065 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
1067 TYPE_SIZE (new_type) = TYPE_SIZE (type);
1068 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
1069 new_size = size;
1071 else
1073 TYPE_SIZE (new_type) = bitsize_int (new_size);
1074 TYPE_SIZE_UNIT (new_type) = size_int (new_size / BITS_PER_UNIT);
1077 if (!TYPE_CONTAINS_TEMPLATE_P (type))
1078 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
1080 compute_record_mode (new_type);
1082 /* Try harder to get a packable type if necessary, for example
1083 in case the record itself contains a BLKmode field. */
1084 if (in_record && TYPE_MODE (new_type) == BLKmode)
1085 SET_TYPE_MODE (new_type,
1086 mode_for_size_tree (TYPE_SIZE (new_type),
1087 MODE_INT, 1).else_blk ());
1089 /* If neither mode nor size nor alignment shrunk, return the old type. */
1090 if (TYPE_MODE (new_type) == BLKmode && new_size >= size && max_align == 0)
1091 return type;
1093 return new_type;
1096 /* Return true if TYPE has an unsigned representation. This needs to be used
1097 when the representation of types whose precision is not equal to their size
1098 is manipulated based on the RM size. */
1100 static inline bool
1101 type_unsigned_for_rm (tree type)
1103 /* This is the common case. */
1104 if (TYPE_UNSIGNED (type))
1105 return true;
1107 /* See the E_Signed_Integer_Subtype case of gnat_to_gnu_entity. */
1108 if (TREE_CODE (TYPE_MIN_VALUE (type)) == INTEGER_CST
1109 && tree_int_cst_sgn (TYPE_MIN_VALUE (type)) >= 0)
1110 return true;
1112 return false;
1115 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
1116 If TYPE is the best type, return it. Otherwise, make a new type. We
1117 only support new integral and pointer types. FOR_BIASED is true if
1118 we are making a biased type. */
1120 tree
1121 make_type_from_size (tree type, tree size_tree, bool for_biased)
1123 unsigned HOST_WIDE_INT size;
1124 bool biased_p;
1125 tree new_type;
1127 /* If size indicates an error, just return TYPE to avoid propagating
1128 the error. Likewise if it's too large to represent. */
1129 if (!size_tree || !tree_fits_uhwi_p (size_tree))
1130 return type;
1132 size = tree_to_uhwi (size_tree);
1134 switch (TREE_CODE (type))
1136 case INTEGER_TYPE:
1137 case ENUMERAL_TYPE:
1138 case BOOLEAN_TYPE:
1139 biased_p = (TREE_CODE (type) == INTEGER_TYPE
1140 && TYPE_BIASED_REPRESENTATION_P (type));
1142 /* Integer types with precision 0 are forbidden. */
1143 if (size == 0)
1144 size = 1;
1146 /* Only do something if the type isn't a packed array type and doesn't
1147 already have the proper size and the size isn't too large. */
1148 if (TYPE_IS_PACKED_ARRAY_TYPE_P (type)
1149 || (TYPE_PRECISION (type) == size && biased_p == for_biased)
1150 || size > LONG_LONG_TYPE_SIZE)
1151 break;
1153 biased_p |= for_biased;
1155 /* The type should be an unsigned type if the original type is unsigned
1156 or if the lower bound is constant and non-negative or if the type is
1157 biased, see E_Signed_Integer_Subtype case of gnat_to_gnu_entity. */
1158 if (type_unsigned_for_rm (type) || biased_p)
1159 new_type = make_unsigned_type (size);
1160 else
1161 new_type = make_signed_type (size);
1162 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
1163 SET_TYPE_RM_MIN_VALUE (new_type, TYPE_MIN_VALUE (type));
1164 SET_TYPE_RM_MAX_VALUE (new_type, TYPE_MAX_VALUE (type));
1165 /* Copy the name to show that it's essentially the same type and
1166 not a subrange type. */
1167 TYPE_NAME (new_type) = TYPE_NAME (type);
1168 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
1169 SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
1170 return new_type;
1172 case RECORD_TYPE:
1173 /* Do something if this is a fat pointer, in which case we
1174 may need to return the thin pointer. */
1175 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
1177 scalar_int_mode p_mode;
1178 if (!int_mode_for_size (size, 0).exists (&p_mode)
1179 || !targetm.valid_pointer_mode (p_mode))
1180 p_mode = ptr_mode;
1181 return
1182 build_pointer_type_for_mode
1183 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
1184 p_mode, 0);
1186 break;
1188 case POINTER_TYPE:
1189 /* Only do something if this is a thin pointer, in which case we
1190 may need to return the fat pointer. */
1191 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
1192 return
1193 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
1194 break;
1196 default:
1197 break;
1200 return type;
1203 /* Return true iff the padded types are equivalent. */
1205 bool
1206 pad_type_hasher::equal (pad_type_hash *t1, pad_type_hash *t2)
1208 tree type1, type2;
1210 if (t1->hash != t2->hash)
1211 return 0;
1213 type1 = t1->type;
1214 type2 = t2->type;
1216 /* We consider that the padded types are equivalent if they pad the same type
1217 and have the same size, alignment, RM size and storage order. Taking the
1218 mode into account is redundant since it is determined by the others. */
1219 return
1220 TREE_TYPE (TYPE_FIELDS (type1)) == TREE_TYPE (TYPE_FIELDS (type2))
1221 && TYPE_SIZE (type1) == TYPE_SIZE (type2)
1222 && TYPE_ALIGN (type1) == TYPE_ALIGN (type2)
1223 && TYPE_ADA_SIZE (type1) == TYPE_ADA_SIZE (type2)
1224 && TYPE_REVERSE_STORAGE_ORDER (type1) == TYPE_REVERSE_STORAGE_ORDER (type2);
1227 /* Look up the padded TYPE in the hash table and return its canonical version
1228 if it exists; otherwise, insert it into the hash table. */
1230 static tree
1231 lookup_and_insert_pad_type (tree type)
1233 hashval_t hashcode;
1234 struct pad_type_hash in, *h;
1236 hashcode
1237 = iterative_hash_object (TYPE_HASH (TREE_TYPE (TYPE_FIELDS (type))), 0);
1238 hashcode = iterative_hash_expr (TYPE_SIZE (type), hashcode);
1239 hashcode = iterative_hash_hashval_t (TYPE_ALIGN (type), hashcode);
1240 hashcode = iterative_hash_expr (TYPE_ADA_SIZE (type), hashcode);
1242 in.hash = hashcode;
1243 in.type = type;
1244 h = pad_type_hash_table->find_with_hash (&in, hashcode);
1245 if (h)
1246 return h->type;
1248 h = ggc_alloc<pad_type_hash> ();
1249 h->hash = hashcode;
1250 h->type = type;
1251 *pad_type_hash_table->find_slot_with_hash (h, hashcode, INSERT) = h;
1252 return NULL_TREE;
1255 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
1256 if needed. We have already verified that SIZE and ALIGN are large enough.
1257 GNAT_ENTITY is used to name the resulting record and to issue a warning.
1258 IS_COMPONENT_TYPE is true if this is being done for the component type of
1259 an array. IS_USER_TYPE is true if the original type needs to be completed.
1260 DEFINITION is true if this type is being defined. SET_RM_SIZE is true if
1261 the RM size of the resulting type is to be set to SIZE too; in this case,
1262 the padded type is canonicalized before being returned. */
1264 tree
1265 maybe_pad_type (tree type, tree size, unsigned int align,
1266 Entity_Id gnat_entity, bool is_component_type,
1267 bool is_user_type, bool definition, bool set_rm_size)
1269 tree orig_size = TYPE_SIZE (type);
1270 unsigned int orig_align = TYPE_ALIGN (type);
1271 tree record, field;
1273 /* If TYPE is a padded type, see if it agrees with any size and alignment
1274 we were given. If so, return the original type. Otherwise, strip
1275 off the padding, since we will either be returning the inner type
1276 or repadding it. If no size or alignment is specified, use that of
1277 the original padded type. */
1278 if (TYPE_IS_PADDING_P (type))
1280 if ((!size
1281 || operand_equal_p (round_up (size, orig_align), orig_size, 0))
1282 && (align == 0 || align == orig_align))
1283 return type;
1285 if (!size)
1286 size = orig_size;
1287 if (align == 0)
1288 align = orig_align;
1290 type = TREE_TYPE (TYPE_FIELDS (type));
1291 orig_size = TYPE_SIZE (type);
1292 orig_align = TYPE_ALIGN (type);
1295 /* If the size is either not being changed or is being made smaller (which
1296 is not done here and is only valid for bitfields anyway), show the size
1297 isn't changing. Likewise, clear the alignment if it isn't being
1298 changed. Then return if we aren't doing anything. */
1299 if (size
1300 && (operand_equal_p (size, orig_size, 0)
1301 || (TREE_CODE (orig_size) == INTEGER_CST
1302 && tree_int_cst_lt (size, orig_size))))
1303 size = NULL_TREE;
1305 if (align == orig_align)
1306 align = 0;
1308 if (align == 0 && !size)
1309 return type;
1311 /* If requested, complete the original type and give it a name. */
1312 if (is_user_type)
1313 create_type_decl (get_entity_name (gnat_entity), type,
1314 !Comes_From_Source (gnat_entity),
1315 !(TYPE_NAME (type)
1316 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
1317 && DECL_IGNORED_P (TYPE_NAME (type))),
1318 gnat_entity);
1320 /* We used to modify the record in place in some cases, but that could
1321 generate incorrect debugging information. So make a new record
1322 type and name. */
1323 record = make_node (RECORD_TYPE);
1324 TYPE_PADDING_P (record) = 1;
1326 /* ??? Padding types around packed array implementation types will be
1327 considered as root types in the array descriptor language hook (see
1328 gnat_get_array_descr_info). Give them the original packed array type
1329 name so that the one coming from sources appears in the debugging
1330 information. */
1331 if (TYPE_IMPL_PACKED_ARRAY_P (type)
1332 && TYPE_ORIGINAL_PACKED_ARRAY (type)
1333 && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1334 TYPE_NAME (record) = TYPE_NAME (TYPE_ORIGINAL_PACKED_ARRAY (type));
1335 else if (Present (gnat_entity))
1336 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
1338 SET_TYPE_ALIGN (record, align ? align : orig_align);
1339 TYPE_SIZE (record) = size ? size : orig_size;
1340 TYPE_SIZE_UNIT (record)
1341 = convert (sizetype,
1342 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
1343 bitsize_unit_node));
1345 /* If we are changing the alignment and the input type is a record with
1346 BLKmode and a small constant size, try to make a form that has an
1347 integral mode. This might allow the padding record to also have an
1348 integral mode, which will be much more efficient. There is no point
1349 in doing so if a size is specified unless it is also a small constant
1350 size and it is incorrect to do so if we cannot guarantee that the mode
1351 will be naturally aligned since the field must always be addressable.
1353 ??? This might not always be a win when done for a stand-alone object:
1354 since the nominal and the effective type of the object will now have
1355 different modes, a VIEW_CONVERT_EXPR will be required for converting
1356 between them and it might be hard to overcome afterwards, including
1357 at the RTL level when the stand-alone object is accessed as a whole. */
1358 if (align != 0
1359 && RECORD_OR_UNION_TYPE_P (type)
1360 && TYPE_MODE (type) == BLKmode
1361 && !TYPE_BY_REFERENCE_P (type)
1362 && TREE_CODE (orig_size) == INTEGER_CST
1363 && !TREE_OVERFLOW (orig_size)
1364 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
1365 && (!size
1366 || (TREE_CODE (size) == INTEGER_CST
1367 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
1369 tree packable_type = make_packable_type (type, true);
1370 if (TYPE_MODE (packable_type) != BLKmode
1371 && align >= TYPE_ALIGN (packable_type))
1372 type = packable_type;
1375 /* Now create the field with the original size. */
1376 field = create_field_decl (get_identifier ("F"), type, record, orig_size,
1377 bitsize_zero_node, 0, 1);
1378 DECL_INTERNAL_P (field) = 1;
1380 /* We will output additional debug info manually below. */
1381 finish_record_type (record, field, 1, false);
1383 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1384 SET_TYPE_DEBUG_TYPE (record, type);
1386 /* Set the RM size if requested. */
1387 if (set_rm_size)
1389 tree canonical_pad_type;
1391 SET_TYPE_ADA_SIZE (record, size ? size : orig_size);
1393 /* If the padded type is complete and has constant size, we canonicalize
1394 it by means of the hash table. This is consistent with the language
1395 semantics and ensures that gigi and the middle-end have a common view
1396 of these padded types. */
1397 if (TREE_CONSTANT (TYPE_SIZE (record))
1398 && (canonical_pad_type = lookup_and_insert_pad_type (record)))
1400 record = canonical_pad_type;
1401 goto built;
1405 /* Unless debugging information isn't being written for the input type,
1406 write a record that shows what we are a subtype of and also make a
1407 variable that indicates our size, if still variable. */
1408 if (TREE_CODE (orig_size) != INTEGER_CST
1409 && TYPE_NAME (record)
1410 && TYPE_NAME (type)
1411 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
1412 && DECL_IGNORED_P (TYPE_NAME (type))))
1414 tree name = TYPE_IDENTIFIER (record);
1415 tree size_unit = TYPE_SIZE_UNIT (record);
1417 /* A variable that holds the size is required even with no encoding since
1418 it will be referenced by debugging information attributes. At global
1419 level, we need a single variable across all translation units. */
1420 if (size
1421 && TREE_CODE (size) != INTEGER_CST
1422 && (definition || global_bindings_p ()))
1424 /* Whether or not gnat_entity comes from source, this XVZ variable is
1425 is a compilation artifact. */
1426 size_unit
1427 = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
1428 size_unit, true, global_bindings_p (),
1429 !definition && global_bindings_p (), false,
1430 false, true, true, NULL, gnat_entity);
1431 TYPE_SIZE_UNIT (record) = size_unit;
1434 /* There is no need to show what we are a subtype of when outputting as
1435 few encodings as possible: regular debugging infomation makes this
1436 redundant. */
1437 if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
1439 tree marker = make_node (RECORD_TYPE);
1440 tree orig_name = TYPE_IDENTIFIER (type);
1442 TYPE_NAME (marker) = concat_name (name, "XVS");
1443 finish_record_type (marker,
1444 create_field_decl (orig_name,
1445 build_reference_type (type),
1446 marker, NULL_TREE, NULL_TREE,
1447 0, 0),
1448 0, true);
1449 TYPE_SIZE_UNIT (marker) = size_unit;
1451 add_parallel_type (record, marker);
1455 built:
1456 /* If a simple size was explicitly given, maybe issue a warning. */
1457 if (!size
1458 || TREE_CODE (size) == COND_EXPR
1459 || TREE_CODE (size) == MAX_EXPR
1460 || No (gnat_entity))
1461 return record;
1463 /* But don't do it if we are just annotating types and the type is tagged or
1464 concurrent, since these types aren't fully laid out in this mode. */
1465 if (type_annotate_only)
1467 Entity_Id gnat_type
1468 = is_component_type
1469 ? Component_Type (gnat_entity) : Etype (gnat_entity);
1471 if (Is_Tagged_Type (gnat_type) || Is_Concurrent_Type (gnat_type))
1472 return record;
1475 /* Take the original size as the maximum size of the input if there was an
1476 unconstrained record involved and round it up to the specified alignment,
1477 if one was specified, but only for aggregate types. */
1478 if (CONTAINS_PLACEHOLDER_P (orig_size))
1479 orig_size = max_size (orig_size, true);
1481 if (align && AGGREGATE_TYPE_P (type))
1482 orig_size = round_up (orig_size, align);
1484 if (!operand_equal_p (size, orig_size, 0)
1485 && !(TREE_CODE (size) == INTEGER_CST
1486 && TREE_CODE (orig_size) == INTEGER_CST
1487 && (TREE_OVERFLOW (size)
1488 || TREE_OVERFLOW (orig_size)
1489 || tree_int_cst_lt (size, orig_size))))
1491 Node_Id gnat_error_node = Empty;
1493 /* For a packed array, post the message on the original array type. */
1494 if (Is_Packed_Array_Impl_Type (gnat_entity))
1495 gnat_entity = Original_Array_Type (gnat_entity);
1497 if ((Ekind (gnat_entity) == E_Component
1498 || Ekind (gnat_entity) == E_Discriminant)
1499 && Present (Component_Clause (gnat_entity)))
1500 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
1501 else if (Present (Size_Clause (gnat_entity)))
1502 gnat_error_node = Expression (Size_Clause (gnat_entity));
1504 /* Generate message only for entities that come from source, since
1505 if we have an entity created by expansion, the message will be
1506 generated for some other corresponding source entity. */
1507 if (Comes_From_Source (gnat_entity))
1509 if (Present (gnat_error_node))
1510 post_error_ne_tree ("{^ }bits of & unused?",
1511 gnat_error_node, gnat_entity,
1512 size_diffop (size, orig_size));
1513 else if (is_component_type)
1514 post_error_ne_tree ("component of& padded{ by ^ bits}?",
1515 gnat_entity, gnat_entity,
1516 size_diffop (size, orig_size));
1520 return record;
1523 /* Return a copy of the padded TYPE but with reverse storage order. */
1525 tree
1526 set_reverse_storage_order_on_pad_type (tree type)
1528 tree field, canonical_pad_type;
1530 if (flag_checking)
1532 /* If the inner type is not scalar then the function does nothing. */
1533 tree inner_type = TREE_TYPE (TYPE_FIELDS (type));
1534 gcc_assert (!AGGREGATE_TYPE_P (inner_type)
1535 && !VECTOR_TYPE_P (inner_type));
1538 /* This is required for the canonicalization. */
1539 gcc_assert (TREE_CONSTANT (TYPE_SIZE (type)));
1541 field = copy_node (TYPE_FIELDS (type));
1542 type = copy_type (type);
1543 DECL_CONTEXT (field) = type;
1544 TYPE_FIELDS (type) = field;
1545 TYPE_REVERSE_STORAGE_ORDER (type) = 1;
1546 canonical_pad_type = lookup_and_insert_pad_type (type);
1547 return canonical_pad_type ? canonical_pad_type : type;
1550 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
1551 If this is a multi-dimensional array type, do this recursively.
1553 OP may be
1554 - ALIAS_SET_COPY: the new set is made a copy of the old one.
1555 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
1556 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
1558 void
1559 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
1561 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
1562 of a one-dimensional array, since the padding has the same alias set
1563 as the field type, but if it's a multi-dimensional array, we need to
1564 see the inner types. */
1565 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
1566 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
1567 || TYPE_PADDING_P (gnu_old_type)))
1568 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
1570 /* Unconstrained array types are deemed incomplete and would thus be given
1571 alias set 0. Retrieve the underlying array type. */
1572 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
1573 gnu_old_type
1574 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
1575 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
1576 gnu_new_type
1577 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
1579 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
1580 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
1581 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
1582 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
1584 switch (op)
1586 case ALIAS_SET_COPY:
1587 /* The alias set shouldn't be copied between array types with different
1588 aliasing settings because this can break the aliasing relationship
1589 between the array type and its element type. */
1590 if (flag_checking || flag_strict_aliasing)
1591 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
1592 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
1593 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
1594 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
1596 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
1597 break;
1599 case ALIAS_SET_SUBSET:
1600 case ALIAS_SET_SUPERSET:
1602 alias_set_type old_set = get_alias_set (gnu_old_type);
1603 alias_set_type new_set = get_alias_set (gnu_new_type);
1605 /* Do nothing if the alias sets conflict. This ensures that we
1606 never call record_alias_subset several times for the same pair
1607 or at all for alias set 0. */
1608 if (!alias_sets_conflict_p (old_set, new_set))
1610 if (op == ALIAS_SET_SUBSET)
1611 record_alias_subset (old_set, new_set);
1612 else
1613 record_alias_subset (new_set, old_set);
1616 break;
1618 default:
1619 gcc_unreachable ();
1622 record_component_aliases (gnu_new_type);
1625 /* Record TYPE as a builtin type for Ada. NAME is the name of the type.
1626 ARTIFICIAL_P is true if the type was generated by the compiler. */
1628 void
1629 record_builtin_type (const char *name, tree type, bool artificial_p)
1631 tree type_decl = build_decl (input_location,
1632 TYPE_DECL, get_identifier (name), type);
1633 DECL_ARTIFICIAL (type_decl) = artificial_p;
1634 TYPE_ARTIFICIAL (type) = artificial_p;
1635 gnat_pushdecl (type_decl, Empty);
1637 if (debug_hooks->type_decl)
1638 debug_hooks->type_decl (type_decl, false);
1641 /* Finish constructing the character type CHAR_TYPE.
1643 In Ada character types are enumeration types and, as a consequence, are
1644 represented in the front-end by integral types holding the positions of
1645 the enumeration values as defined by the language, which means that the
1646 integral types are unsigned.
1648 Unfortunately the signedness of 'char' in C is implementation-defined
1649 and GCC even has the option -fsigned-char to toggle it at run time.
1650 Since GNAT's philosophy is to be compatible with C by default, to wit
1651 Interfaces.C.char is defined as a mere copy of Character, we may need
1652 to declare character types as signed types in GENERIC and generate the
1653 necessary adjustments to make them behave as unsigned types.
1655 The overall strategy is as follows: if 'char' is unsigned, do nothing;
1656 if 'char' is signed, translate character types of CHAR_TYPE_SIZE and
1657 character subtypes with RM_Size = Esize = CHAR_TYPE_SIZE into signed
1658 types. The idea is to ensure that the bit pattern contained in the
1659 Esize'd objects is not changed, even though the numerical value will
1660 be interpreted differently depending on the signedness. */
1662 void
1663 finish_character_type (tree char_type)
1665 if (TYPE_UNSIGNED (char_type))
1666 return;
1668 /* Make a copy of a generic unsigned version since we'll modify it. */
1669 tree unsigned_char_type
1670 = (char_type == char_type_node
1671 ? unsigned_char_type_node
1672 : copy_type (gnat_unsigned_type_for (char_type)));
1674 /* Create an unsigned version of the type and set it as debug type. */
1675 TYPE_NAME (unsigned_char_type) = TYPE_NAME (char_type);
1676 TYPE_STRING_FLAG (unsigned_char_type) = TYPE_STRING_FLAG (char_type);
1677 TYPE_ARTIFICIAL (unsigned_char_type) = TYPE_ARTIFICIAL (char_type);
1678 SET_TYPE_DEBUG_TYPE (char_type, unsigned_char_type);
1680 /* If this is a subtype, make the debug type a subtype of the debug type
1681 of the base type and convert literal RM bounds to unsigned. */
1682 if (TREE_TYPE (char_type))
1684 tree base_unsigned_char_type = TYPE_DEBUG_TYPE (TREE_TYPE (char_type));
1685 tree min_value = TYPE_RM_MIN_VALUE (char_type);
1686 tree max_value = TYPE_RM_MAX_VALUE (char_type);
1688 if (TREE_CODE (min_value) == INTEGER_CST)
1689 min_value = fold_convert (base_unsigned_char_type, min_value);
1690 if (TREE_CODE (max_value) == INTEGER_CST)
1691 max_value = fold_convert (base_unsigned_char_type, max_value);
1693 TREE_TYPE (unsigned_char_type) = base_unsigned_char_type;
1694 SET_TYPE_RM_MIN_VALUE (unsigned_char_type, min_value);
1695 SET_TYPE_RM_MAX_VALUE (unsigned_char_type, max_value);
1698 /* Adjust the RM bounds of the original type to unsigned; that's especially
1699 important for types since they are implicit in this case. */
1700 SET_TYPE_RM_MIN_VALUE (char_type, TYPE_MIN_VALUE (unsigned_char_type));
1701 SET_TYPE_RM_MAX_VALUE (char_type, TYPE_MAX_VALUE (unsigned_char_type));
1704 /* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
1705 finish constructing the record type as a fat pointer type. */
1707 void
1708 finish_fat_pointer_type (tree record_type, tree field_list)
1710 /* Make sure we can put it into a register. */
1711 if (STRICT_ALIGNMENT)
1712 SET_TYPE_ALIGN (record_type, MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE));
1714 /* Show what it really is. */
1715 TYPE_FAT_POINTER_P (record_type) = 1;
1717 /* Do not emit debug info for it since the types of its fields may still be
1718 incomplete at this point. */
1719 finish_record_type (record_type, field_list, 0, false);
1721 /* Force type_contains_placeholder_p to return true on it. Although the
1722 PLACEHOLDER_EXPRs are referenced only indirectly, this isn't a pointer
1723 type but the representation of the unconstrained array. */
1724 TYPE_CONTAINS_PLACEHOLDER_INTERNAL (record_type) = 2;
1727 /* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
1728 finish constructing the record or union type. If REP_LEVEL is zero, this
1729 record has no representation clause and so will be entirely laid out here.
1730 If REP_LEVEL is one, this record has a representation clause and has been
1731 laid out already; only set the sizes and alignment. If REP_LEVEL is two,
1732 this record is derived from a parent record and thus inherits its layout;
1733 only make a pass on the fields to finalize them. DEBUG_INFO_P is true if
1734 additional debug info needs to be output for this type. */
1736 void
1737 finish_record_type (tree record_type, tree field_list, int rep_level,
1738 bool debug_info_p)
1740 enum tree_code code = TREE_CODE (record_type);
1741 tree name = TYPE_IDENTIFIER (record_type);
1742 tree ada_size = bitsize_zero_node;
1743 tree size = bitsize_zero_node;
1744 bool had_size = TYPE_SIZE (record_type) != 0;
1745 bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0;
1746 bool had_align = TYPE_ALIGN (record_type) != 0;
1747 tree field;
1749 TYPE_FIELDS (record_type) = field_list;
1751 /* Always attach the TYPE_STUB_DECL for a record type. It is required to
1752 generate debug info and have a parallel type. */
1753 TYPE_STUB_DECL (record_type) = create_type_stub_decl (name, record_type);
1755 /* Globally initialize the record first. If this is a rep'ed record,
1756 that just means some initializations; otherwise, layout the record. */
1757 if (rep_level > 0)
1759 SET_TYPE_ALIGN (record_type, MAX (BITS_PER_UNIT,
1760 TYPE_ALIGN (record_type)));
1762 if (!had_size_unit)
1763 TYPE_SIZE_UNIT (record_type) = size_zero_node;
1765 if (!had_size)
1766 TYPE_SIZE (record_type) = bitsize_zero_node;
1768 /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
1769 out just like a UNION_TYPE, since the size will be fixed. */
1770 else if (code == QUAL_UNION_TYPE)
1771 code = UNION_TYPE;
1773 else
1775 /* Ensure there isn't a size already set. There can be in an error
1776 case where there is a rep clause but all fields have errors and
1777 no longer have a position. */
1778 TYPE_SIZE (record_type) = 0;
1780 /* Ensure we use the traditional GCC layout for bitfields when we need
1781 to pack the record type or have a representation clause. The other
1782 possible layout (Microsoft C compiler), if available, would prevent
1783 efficient packing in almost all cases. */
1784 #ifdef TARGET_MS_BITFIELD_LAYOUT
1785 if (TARGET_MS_BITFIELD_LAYOUT && TYPE_PACKED (record_type))
1786 decl_attributes (&record_type,
1787 tree_cons (get_identifier ("gcc_struct"),
1788 NULL_TREE, NULL_TREE),
1789 ATTR_FLAG_TYPE_IN_PLACE);
1790 #endif
1792 layout_type (record_type);
1795 /* At this point, the position and size of each field is known. It was
1796 either set before entry by a rep clause, or by laying out the type above.
1798 We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs)
1799 to compute the Ada size; the GCC size and alignment (for rep'ed records
1800 that are not padding types); and the mode (for rep'ed records). We also
1801 clear the DECL_BIT_FIELD indication for the cases we know have not been
1802 handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */
1804 if (code == QUAL_UNION_TYPE)
1805 field_list = nreverse (field_list);
1807 for (field = field_list; field; field = DECL_CHAIN (field))
1809 tree type = TREE_TYPE (field);
1810 tree pos = bit_position (field);
1811 tree this_size = DECL_SIZE (field);
1812 tree this_ada_size;
1814 if (RECORD_OR_UNION_TYPE_P (type)
1815 && !TYPE_FAT_POINTER_P (type)
1816 && !TYPE_CONTAINS_TEMPLATE_P (type)
1817 && TYPE_ADA_SIZE (type))
1818 this_ada_size = TYPE_ADA_SIZE (type);
1819 else
1820 this_ada_size = this_size;
1822 /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */
1823 if (DECL_BIT_FIELD (field)
1824 && operand_equal_p (this_size, TYPE_SIZE (type), 0))
1826 unsigned int align = TYPE_ALIGN (type);
1828 /* In the general case, type alignment is required. */
1829 if (value_factor_p (pos, align))
1831 /* The enclosing record type must be sufficiently aligned.
1832 Otherwise, if no alignment was specified for it and it
1833 has been laid out already, bump its alignment to the
1834 desired one if this is compatible with its size and
1835 maximum alignment, if any. */
1836 if (TYPE_ALIGN (record_type) >= align)
1838 SET_DECL_ALIGN (field, MAX (DECL_ALIGN (field), align));
1839 DECL_BIT_FIELD (field) = 0;
1841 else if (!had_align
1842 && rep_level == 0
1843 && value_factor_p (TYPE_SIZE (record_type), align)
1844 && (!TYPE_MAX_ALIGN (record_type)
1845 || TYPE_MAX_ALIGN (record_type) >= align))
1847 SET_TYPE_ALIGN (record_type, align);
1848 SET_DECL_ALIGN (field, MAX (DECL_ALIGN (field), align));
1849 DECL_BIT_FIELD (field) = 0;
1853 /* In the non-strict alignment case, only byte alignment is. */
1854 if (!STRICT_ALIGNMENT
1855 && DECL_BIT_FIELD (field)
1856 && value_factor_p (pos, BITS_PER_UNIT))
1857 DECL_BIT_FIELD (field) = 0;
1860 /* If we still have DECL_BIT_FIELD set at this point, we know that the
1861 field is technically not addressable. Except that it can actually
1862 be addressed if it is BLKmode and happens to be properly aligned. */
1863 if (DECL_BIT_FIELD (field)
1864 && !(DECL_MODE (field) == BLKmode
1865 && value_factor_p (pos, BITS_PER_UNIT)))
1866 DECL_NONADDRESSABLE_P (field) = 1;
1868 /* A type must be as aligned as its most aligned field that is not
1869 a bit-field. But this is already enforced by layout_type. */
1870 if (rep_level > 0 && !DECL_BIT_FIELD (field))
1871 SET_TYPE_ALIGN (record_type,
1872 MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field)));
1874 switch (code)
1876 case UNION_TYPE:
1877 ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size);
1878 size = size_binop (MAX_EXPR, size, this_size);
1879 break;
1881 case QUAL_UNION_TYPE:
1882 ada_size
1883 = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
1884 this_ada_size, ada_size);
1885 size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
1886 this_size, size);
1887 break;
1889 case RECORD_TYPE:
1890 /* Since we know here that all fields are sorted in order of
1891 increasing bit position, the size of the record is one
1892 higher than the ending bit of the last field processed
1893 unless we have a rep clause, since in that case we might
1894 have a field outside a QUAL_UNION_TYPE that has a higher ending
1895 position. So use a MAX in that case. Also, if this field is a
1896 QUAL_UNION_TYPE, we need to take into account the previous size in
1897 the case of empty variants. */
1898 ada_size
1899 = merge_sizes (ada_size, pos, this_ada_size,
1900 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
1901 size
1902 = merge_sizes (size, pos, this_size,
1903 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
1904 break;
1906 default:
1907 gcc_unreachable ();
1911 if (code == QUAL_UNION_TYPE)
1912 nreverse (field_list);
1914 if (rep_level < 2)
1916 /* If this is a padding record, we never want to make the size smaller
1917 than what was specified in it, if any. */
1918 if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
1919 size = TYPE_SIZE (record_type);
1921 /* Now set any of the values we've just computed that apply. */
1922 if (!TYPE_FAT_POINTER_P (record_type)
1923 && !TYPE_CONTAINS_TEMPLATE_P (record_type))
1924 SET_TYPE_ADA_SIZE (record_type, ada_size);
1926 if (rep_level > 0)
1928 tree size_unit = had_size_unit
1929 ? TYPE_SIZE_UNIT (record_type)
1930 : convert (sizetype,
1931 size_binop (CEIL_DIV_EXPR, size,
1932 bitsize_unit_node));
1933 unsigned int align = TYPE_ALIGN (record_type);
1935 TYPE_SIZE (record_type) = variable_size (round_up (size, align));
1936 TYPE_SIZE_UNIT (record_type)
1937 = variable_size (round_up (size_unit, align / BITS_PER_UNIT));
1939 compute_record_mode (record_type);
1943 /* Reset the TYPE_MAX_ALIGN field since it's private to gigi. */
1944 TYPE_MAX_ALIGN (record_type) = 0;
1946 if (debug_info_p)
1947 rest_of_record_type_compilation (record_type);
1950 /* Append PARALLEL_TYPE on the chain of parallel types of TYPE. If
1951 PARRALEL_TYPE has no context and its computation is not deferred yet, also
1952 propagate TYPE's context to PARALLEL_TYPE's or defer its propagation to the
1953 moment TYPE will get a context. */
1955 void
1956 add_parallel_type (tree type, tree parallel_type)
1958 tree decl = TYPE_STUB_DECL (type);
1960 while (DECL_PARALLEL_TYPE (decl))
1961 decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl));
1963 SET_DECL_PARALLEL_TYPE (decl, parallel_type);
1965 /* If PARALLEL_TYPE already has a context, we are done. */
1966 if (TYPE_CONTEXT (parallel_type))
1967 return;
1969 /* Otherwise, try to get one from TYPE's context. If so, simply propagate
1970 it to PARALLEL_TYPE. */
1971 if (TYPE_CONTEXT (type))
1972 gnat_set_type_context (parallel_type, TYPE_CONTEXT (type));
1974 /* Otherwise TYPE has not context yet. We know it will have one thanks to
1975 gnat_pushdecl and then its context will be propagated to PARALLEL_TYPE,
1976 so we have nothing to do in this case. */
1979 /* Return true if TYPE has a parallel type. */
1981 static bool
1982 has_parallel_type (tree type)
1984 tree decl = TYPE_STUB_DECL (type);
1986 return DECL_PARALLEL_TYPE (decl) != NULL_TREE;
1989 /* Wrap up compilation of RECORD_TYPE, i.e. output additional debug info
1990 associated with it. It need not be invoked directly in most cases as
1991 finish_record_type takes care of doing so. */
1993 void
1994 rest_of_record_type_compilation (tree record_type)
1996 bool var_size = false;
1997 tree field;
1999 /* If this is a padded type, the bulk of the debug info has already been
2000 generated for the field's type. */
2001 if (TYPE_IS_PADDING_P (record_type))
2002 return;
2004 /* If the type already has a parallel type (XVS type), then we're done. */
2005 if (has_parallel_type (record_type))
2006 return;
2008 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
2010 /* We need to make an XVE/XVU record if any field has variable size,
2011 whether or not the record does. For example, if we have a union,
2012 it may be that all fields, rounded up to the alignment, have the
2013 same size, in which case we'll use that size. But the debug
2014 output routines (except Dwarf2) won't be able to output the fields,
2015 so we need to make the special record. */
2016 if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST
2017 /* If a field has a non-constant qualifier, the record will have
2018 variable size too. */
2019 || (TREE_CODE (record_type) == QUAL_UNION_TYPE
2020 && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST))
2022 var_size = true;
2023 break;
2027 /* If this record type is of variable size, make a parallel record type that
2028 will tell the debugger how the former is laid out (see exp_dbug.ads). */
2029 if (var_size && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
2031 tree new_record_type
2032 = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
2033 ? UNION_TYPE : TREE_CODE (record_type));
2034 tree orig_name = TYPE_IDENTIFIER (record_type), new_name;
2035 tree last_pos = bitsize_zero_node;
2036 tree old_field, prev_old_field = NULL_TREE;
2038 new_name
2039 = concat_name (orig_name, TREE_CODE (record_type) == QUAL_UNION_TYPE
2040 ? "XVU" : "XVE");
2041 TYPE_NAME (new_record_type) = new_name;
2042 SET_TYPE_ALIGN (new_record_type, BIGGEST_ALIGNMENT);
2043 TYPE_STUB_DECL (new_record_type)
2044 = create_type_stub_decl (new_name, new_record_type);
2045 DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
2046 = DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
2047 gnat_pushdecl (TYPE_STUB_DECL (new_record_type), Empty);
2048 TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
2049 TYPE_SIZE_UNIT (new_record_type)
2050 = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT);
2052 /* Now scan all the fields, replacing each field with a new field
2053 corresponding to the new encoding. */
2054 for (old_field = TYPE_FIELDS (record_type); old_field;
2055 old_field = DECL_CHAIN (old_field))
2057 tree field_type = TREE_TYPE (old_field);
2058 tree field_name = DECL_NAME (old_field);
2059 tree curpos = fold_bit_position (old_field);
2060 tree pos, new_field;
2061 bool var = false;
2062 unsigned int align = 0;
2064 /* See how the position was modified from the last position.
2066 There are two basic cases we support: a value was added
2067 to the last position or the last position was rounded to
2068 a boundary and they something was added. Check for the
2069 first case first. If not, see if there is any evidence
2070 of rounding. If so, round the last position and retry.
2072 If this is a union, the position can be taken as zero. */
2073 if (TREE_CODE (new_record_type) == UNION_TYPE)
2074 pos = bitsize_zero_node;
2075 else
2076 pos = compute_related_constant (curpos, last_pos);
2078 if (!pos
2079 && TREE_CODE (curpos) == MULT_EXPR
2080 && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1)))
2082 tree offset = TREE_OPERAND (curpos, 0);
2083 align = tree_to_uhwi (TREE_OPERAND (curpos, 1));
2084 align = scale_by_factor_of (offset, align);
2085 last_pos = round_up (last_pos, align);
2086 pos = compute_related_constant (curpos, last_pos);
2088 else if (!pos
2089 && TREE_CODE (curpos) == PLUS_EXPR
2090 && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1))
2091 && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR
2092 && tree_fits_uhwi_p
2093 (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1)))
2095 tree offset = TREE_OPERAND (TREE_OPERAND (curpos, 0), 0);
2096 unsigned HOST_WIDE_INT addend
2097 = tree_to_uhwi (TREE_OPERAND (curpos, 1));
2098 align
2099 = tree_to_uhwi (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1));
2100 align = scale_by_factor_of (offset, align);
2101 align = MIN (align, addend & -addend);
2102 last_pos = round_up (last_pos, align);
2103 pos = compute_related_constant (curpos, last_pos);
2105 else if (potential_alignment_gap (prev_old_field, old_field, pos))
2107 align = TYPE_ALIGN (field_type);
2108 last_pos = round_up (last_pos, align);
2109 pos = compute_related_constant (curpos, last_pos);
2112 /* If we can't compute a position, set it to zero.
2114 ??? We really should abort here, but it's too much work
2115 to get this correct for all cases. */
2116 if (!pos)
2117 pos = bitsize_zero_node;
2119 /* See if this type is variable-sized and make a pointer type
2120 and indicate the indirection if so. Beware that the debug
2121 back-end may adjust the position computed above according
2122 to the alignment of the field type, i.e. the pointer type
2123 in this case, if we don't preventively counter that. */
2124 if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
2126 field_type = build_pointer_type (field_type);
2127 if (align != 0 && TYPE_ALIGN (field_type) > align)
2129 field_type = copy_type (field_type);
2130 SET_TYPE_ALIGN (field_type, align);
2132 var = true;
2135 /* Make a new field name, if necessary. */
2136 if (var || align != 0)
2138 char suffix[16];
2140 if (align != 0)
2141 sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
2142 align / BITS_PER_UNIT);
2143 else
2144 strcpy (suffix, "XVL");
2146 field_name = concat_name (field_name, suffix);
2149 new_field
2150 = create_field_decl (field_name, field_type, new_record_type,
2151 DECL_SIZE (old_field), pos, 0, 0);
2152 DECL_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
2153 TYPE_FIELDS (new_record_type) = new_field;
2155 /* If old_field is a QUAL_UNION_TYPE, take its size as being
2156 zero. The only time it's not the last field of the record
2157 is when there are other components at fixed positions after
2158 it (meaning there was a rep clause for every field) and we
2159 want to be able to encode them. */
2160 last_pos = size_binop (PLUS_EXPR, curpos,
2161 (TREE_CODE (TREE_TYPE (old_field))
2162 == QUAL_UNION_TYPE)
2163 ? bitsize_zero_node
2164 : DECL_SIZE (old_field));
2165 prev_old_field = old_field;
2168 TYPE_FIELDS (new_record_type) = nreverse (TYPE_FIELDS (new_record_type));
2170 add_parallel_type (record_type, new_record_type);
2174 /* Utility function of above to merge LAST_SIZE, the previous size of a record
2175 with FIRST_BIT and SIZE that describe a field. SPECIAL is true if this
2176 represents a QUAL_UNION_TYPE in which case we must look for COND_EXPRs and
2177 replace a value of zero with the old size. If HAS_REP is true, we take the
2178 MAX of the end position of this field with LAST_SIZE. In all other cases,
2179 we use FIRST_BIT plus SIZE. Return an expression for the size. */
2181 static tree
2182 merge_sizes (tree last_size, tree first_bit, tree size, bool special,
2183 bool has_rep)
2185 tree type = TREE_TYPE (last_size);
2186 tree new_size;
2188 if (!special || TREE_CODE (size) != COND_EXPR)
2190 new_size = size_binop (PLUS_EXPR, first_bit, size);
2191 if (has_rep)
2192 new_size = size_binop (MAX_EXPR, last_size, new_size);
2195 else
2196 new_size = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
2197 integer_zerop (TREE_OPERAND (size, 1))
2198 ? last_size : merge_sizes (last_size, first_bit,
2199 TREE_OPERAND (size, 1),
2200 1, has_rep),
2201 integer_zerop (TREE_OPERAND (size, 2))
2202 ? last_size : merge_sizes (last_size, first_bit,
2203 TREE_OPERAND (size, 2),
2204 1, has_rep));
2206 /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
2207 when fed through substitute_in_expr) into thinking that a constant
2208 size is not constant. */
2209 while (TREE_CODE (new_size) == NON_LVALUE_EXPR)
2210 new_size = TREE_OPERAND (new_size, 0);
2212 return new_size;
2215 /* Return the bit position of FIELD, in bits from the start of the record,
2216 and fold it as much as possible. This is a tree of type bitsizetype. */
2218 static tree
2219 fold_bit_position (const_tree field)
2221 tree offset = DECL_FIELD_OFFSET (field);
2222 if (TREE_CODE (offset) == MULT_EXPR || TREE_CODE (offset) == PLUS_EXPR)
2223 offset = size_binop (TREE_CODE (offset),
2224 fold_convert (bitsizetype, TREE_OPERAND (offset, 0)),
2225 fold_convert (bitsizetype, TREE_OPERAND (offset, 1)));
2226 else
2227 offset = fold_convert (bitsizetype, offset);
2228 return size_binop (PLUS_EXPR, DECL_FIELD_BIT_OFFSET (field),
2229 size_binop (MULT_EXPR, offset, bitsize_unit_node));
2232 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
2233 related by the addition of a constant. Return that constant if so. */
2235 static tree
2236 compute_related_constant (tree op0, tree op1)
2238 tree factor, op0_var, op1_var, op0_cst, op1_cst, result;
2240 if (TREE_CODE (op0) == MULT_EXPR
2241 && TREE_CODE (op1) == MULT_EXPR
2242 && TREE_CODE (TREE_OPERAND (op0, 1)) == INTEGER_CST
2243 && TREE_OPERAND (op1, 1) == TREE_OPERAND (op0, 1))
2245 factor = TREE_OPERAND (op0, 1);
2246 op0 = TREE_OPERAND (op0, 0);
2247 op1 = TREE_OPERAND (op1, 0);
2249 else
2250 factor = NULL_TREE;
2252 op0_cst = split_plus (op0, &op0_var);
2253 op1_cst = split_plus (op1, &op1_var);
2254 result = size_binop (MINUS_EXPR, op0_cst, op1_cst);
2256 if (operand_equal_p (op0_var, op1_var, 0))
2257 return factor ? size_binop (MULT_EXPR, factor, result) : result;
2259 return NULL_TREE;
2262 /* Utility function of above to split a tree OP which may be a sum, into a
2263 constant part, which is returned, and a variable part, which is stored
2264 in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of
2265 bitsizetype. */
2267 static tree
2268 split_plus (tree in, tree *pvar)
2270 /* Strip conversions in order to ease the tree traversal and maximize the
2271 potential for constant or plus/minus discovery. We need to be careful
2272 to always return and set *pvar to bitsizetype trees, but it's worth
2273 the effort. */
2274 in = remove_conversions (in, false);
2276 *pvar = convert (bitsizetype, in);
2278 if (TREE_CODE (in) == INTEGER_CST)
2280 *pvar = bitsize_zero_node;
2281 return convert (bitsizetype, in);
2283 else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
2285 tree lhs_var, rhs_var;
2286 tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
2287 tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
2289 if (lhs_var == TREE_OPERAND (in, 0)
2290 && rhs_var == TREE_OPERAND (in, 1))
2291 return bitsize_zero_node;
2293 *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
2294 return size_binop (TREE_CODE (in), lhs_con, rhs_con);
2296 else
2297 return bitsize_zero_node;
2300 /* Return a copy of TYPE but safe to modify in any way. */
2302 tree
2303 copy_type (tree type)
2305 tree new_type = copy_node (type);
2307 /* Unshare the language-specific data. */
2308 if (TYPE_LANG_SPECIFIC (type))
2310 TYPE_LANG_SPECIFIC (new_type) = NULL;
2311 SET_TYPE_LANG_SPECIFIC (new_type, GET_TYPE_LANG_SPECIFIC (type));
2314 /* And the contents of the language-specific slot if needed. */
2315 if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE)
2316 && TYPE_RM_VALUES (type))
2318 TYPE_RM_VALUES (new_type) = NULL_TREE;
2319 SET_TYPE_RM_SIZE (new_type, TYPE_RM_SIZE (type));
2320 SET_TYPE_RM_MIN_VALUE (new_type, TYPE_RM_MIN_VALUE (type));
2321 SET_TYPE_RM_MAX_VALUE (new_type, TYPE_RM_MAX_VALUE (type));
2324 /* copy_node clears this field instead of copying it, because it is
2325 aliased with TREE_CHAIN. */
2326 TYPE_STUB_DECL (new_type) = TYPE_STUB_DECL (type);
2328 TYPE_POINTER_TO (new_type) = NULL_TREE;
2329 TYPE_REFERENCE_TO (new_type) = NULL_TREE;
2330 TYPE_MAIN_VARIANT (new_type) = new_type;
2331 TYPE_NEXT_VARIANT (new_type) = NULL_TREE;
2332 TYPE_CANONICAL (new_type) = new_type;
2334 return new_type;
2337 /* Return a subtype of sizetype with range MIN to MAX and whose
2338 TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position
2339 of the associated TYPE_DECL. */
2341 tree
2342 create_index_type (tree min, tree max, tree index, Node_Id gnat_node)
2344 /* First build a type for the desired range. */
2345 tree type = build_nonshared_range_type (sizetype, min, max);
2347 /* Then set the index type. */
2348 SET_TYPE_INDEX_TYPE (type, index);
2349 create_type_decl (NULL_TREE, type, true, false, gnat_node);
2351 return type;
2354 /* Return a subtype of TYPE with range MIN to MAX. If TYPE is NULL,
2355 sizetype is used. */
2357 tree
2358 create_range_type (tree type, tree min, tree max)
2360 tree range_type;
2362 if (!type)
2363 type = sizetype;
2365 /* First build a type with the base range. */
2366 range_type = build_nonshared_range_type (type, TYPE_MIN_VALUE (type),
2367 TYPE_MAX_VALUE (type));
2369 /* Then set the actual range. */
2370 SET_TYPE_RM_MIN_VALUE (range_type, min);
2371 SET_TYPE_RM_MAX_VALUE (range_type, max);
2373 return range_type;
2376 /* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of TYPE.
2377 NAME gives the name of the type to be used in the declaration. */
2379 tree
2380 create_type_stub_decl (tree name, tree type)
2382 tree type_decl = build_decl (input_location, TYPE_DECL, name, type);
2383 DECL_ARTIFICIAL (type_decl) = 1;
2384 TYPE_ARTIFICIAL (type) = 1;
2385 return type_decl;
2388 /* Return a TYPE_DECL node for TYPE. NAME gives the name of the type to be
2389 used in the declaration. ARTIFICIAL_P is true if the declaration was
2390 generated by the compiler. DEBUG_INFO_P is true if we need to write
2391 debug information about this type. GNAT_NODE is used for the position
2392 of the decl. */
2394 tree
2395 create_type_decl (tree name, tree type, bool artificial_p, bool debug_info_p,
2396 Node_Id gnat_node)
2398 enum tree_code code = TREE_CODE (type);
2399 bool is_named
2400 = TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL;
2401 tree type_decl;
2403 /* Only the builtin TYPE_STUB_DECL should be used for dummy types. */
2404 gcc_assert (!TYPE_IS_DUMMY_P (type));
2406 /* If the type hasn't been named yet, we're naming it; preserve an existing
2407 TYPE_STUB_DECL that has been attached to it for some purpose. */
2408 if (!is_named && TYPE_STUB_DECL (type))
2410 type_decl = TYPE_STUB_DECL (type);
2411 DECL_NAME (type_decl) = name;
2413 else
2414 type_decl = build_decl (input_location, TYPE_DECL, name, type);
2416 DECL_ARTIFICIAL (type_decl) = artificial_p;
2417 TYPE_ARTIFICIAL (type) = artificial_p;
2419 /* Add this decl to the current binding level. */
2420 gnat_pushdecl (type_decl, gnat_node);
2422 /* If we're naming the type, equate the TYPE_STUB_DECL to the name. This
2423 causes the name to be also viewed as a "tag" by the debug back-end, with
2424 the advantage that no DW_TAG_typedef is emitted for artificial "tagged"
2425 types in DWARF.
2427 Note that if "type" is used as a DECL_ORIGINAL_TYPE, it may be referenced
2428 from multiple contexts, and "type_decl" references a copy of it: in such a
2429 case, do not mess TYPE_STUB_DECL: we do not want to re-use the TYPE_DECL
2430 with the mechanism above. */
2431 if (!is_named && type != DECL_ORIGINAL_TYPE (type_decl))
2432 TYPE_STUB_DECL (type) = type_decl;
2434 /* Do not generate debug info for UNCONSTRAINED_ARRAY_TYPE that the
2435 back-end doesn't support, and for others if we don't need to. */
2436 if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p)
2437 DECL_IGNORED_P (type_decl) = 1;
2439 return type_decl;
2442 /* Return a VAR_DECL or CONST_DECL node.
2444 NAME gives the name of the variable. ASM_NAME is its assembler name
2445 (if provided). TYPE is its data type (a GCC ..._TYPE node). INIT is
2446 the GCC tree for an optional initial expression; NULL_TREE if none.
2448 CONST_FLAG is true if this variable is constant, in which case we might
2449 return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false.
2451 PUBLIC_FLAG is true if this is for a reference to a public entity or for a
2452 definition to be made visible outside of the current compilation unit, for
2453 instance variable definitions in a package specification.
2455 EXTERN_FLAG is true when processing an external variable declaration (as
2456 opposed to a definition: no storage is to be allocated for the variable).
2458 STATIC_FLAG is only relevant when not at top level and indicates whether
2459 to always allocate storage to the variable.
2461 VOLATILE_FLAG is true if this variable is declared as volatile.
2463 ARTIFICIAL_P is true if the variable was generated by the compiler.
2465 DEBUG_INFO_P is true if we need to write debug information for it.
2467 ATTR_LIST is the list of attributes to be attached to the variable.
2469 GNAT_NODE is used for the position of the decl. */
2471 tree
2472 create_var_decl (tree name, tree asm_name, tree type, tree init,
2473 bool const_flag, bool public_flag, bool extern_flag,
2474 bool static_flag, bool volatile_flag, bool artificial_p,
2475 bool debug_info_p, struct attrib *attr_list,
2476 Node_Id gnat_node, bool const_decl_allowed_p)
2478 /* Whether the object has static storage duration, either explicitly or by
2479 virtue of being declared at the global level. */
2480 const bool static_storage = static_flag || global_bindings_p ();
2482 /* Whether the initializer is constant: for an external object or an object
2483 with static storage duration, we check that the initializer is a valid
2484 constant expression for initializing a static variable; otherwise, we
2485 only check that it is constant. */
2486 const bool init_const
2487 = (init
2488 && gnat_types_compatible_p (type, TREE_TYPE (init))
2489 && (extern_flag || static_storage
2490 ? initializer_constant_valid_p (init, TREE_TYPE (init))
2491 != NULL_TREE
2492 : TREE_CONSTANT (init)));
2494 /* Whether we will make TREE_CONSTANT the DECL we produce here, in which
2495 case the initializer may be used in lieu of the DECL node (as done in
2496 Identifier_to_gnu). This is useful to prevent the need of elaboration
2497 code when an identifier for which such a DECL is made is in turn used
2498 as an initializer. We used to rely on CONST_DECL vs VAR_DECL for this,
2499 but extra constraints apply to this choice (see below) and they are not
2500 relevant to the distinction we wish to make. */
2501 const bool constant_p = const_flag && init_const;
2503 /* The actual DECL node. CONST_DECL was initially intended for enumerals
2504 and may be used for scalars in general but not for aggregates. */
2505 tree var_decl
2506 = build_decl (input_location,
2507 (constant_p
2508 && const_decl_allowed_p
2509 && !AGGREGATE_TYPE_P (type) ? CONST_DECL : VAR_DECL),
2510 name, type);
2512 /* Detect constants created by the front-end to hold 'reference to function
2513 calls for stabilization purposes. This is needed for renaming. */
2514 if (const_flag && init && POINTER_TYPE_P (type))
2516 tree inner = init;
2517 if (TREE_CODE (inner) == COMPOUND_EXPR)
2518 inner = TREE_OPERAND (inner, 1);
2519 inner = remove_conversions (inner, true);
2520 if (TREE_CODE (inner) == ADDR_EXPR
2521 && ((TREE_CODE (TREE_OPERAND (inner, 0)) == CALL_EXPR
2522 && !call_is_atomic_load (TREE_OPERAND (inner, 0)))
2523 || (TREE_CODE (TREE_OPERAND (inner, 0)) == VAR_DECL
2524 && DECL_RETURN_VALUE_P (TREE_OPERAND (inner, 0)))))
2525 DECL_RETURN_VALUE_P (var_decl) = 1;
2528 /* If this is external, throw away any initializations (they will be done
2529 elsewhere) unless this is a constant for which we would like to remain
2530 able to get the initializer. If we are defining a global here, leave a
2531 constant initialization and save any variable elaborations for the
2532 elaboration routine. If we are just annotating types, throw away the
2533 initialization if it isn't a constant. */
2534 if ((extern_flag && !constant_p)
2535 || (type_annotate_only && init && !TREE_CONSTANT (init)))
2536 init = NULL_TREE;
2538 /* At the global level, a non-constant initializer generates elaboration
2539 statements. Check that such statements are allowed, that is to say,
2540 not violating a No_Elaboration_Code restriction. */
2541 if (init && !init_const && global_bindings_p ())
2542 Check_Elaboration_Code_Allowed (gnat_node);
2544 /* Attach the initializer, if any. */
2545 DECL_INITIAL (var_decl) = init;
2547 /* Directly set some flags. */
2548 DECL_ARTIFICIAL (var_decl) = artificial_p;
2549 DECL_EXTERNAL (var_decl) = extern_flag;
2551 TREE_CONSTANT (var_decl) = constant_p;
2552 TREE_READONLY (var_decl) = const_flag;
2554 /* The object is public if it is external or if it is declared public
2555 and has static storage duration. */
2556 TREE_PUBLIC (var_decl) = extern_flag || (public_flag && static_storage);
2558 /* We need to allocate static storage for an object with static storage
2559 duration if it isn't external. */
2560 TREE_STATIC (var_decl) = !extern_flag && static_storage;
2562 TREE_SIDE_EFFECTS (var_decl)
2563 = TREE_THIS_VOLATILE (var_decl)
2564 = TYPE_VOLATILE (type) | volatile_flag;
2566 if (TREE_SIDE_EFFECTS (var_decl))
2567 TREE_ADDRESSABLE (var_decl) = 1;
2569 /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
2570 try to fiddle with DECL_COMMON. However, on platforms that don't
2571 support global BSS sections, uninitialized global variables would
2572 go in DATA instead, thus increasing the size of the executable. */
2573 if (!flag_no_common
2574 && TREE_CODE (var_decl) == VAR_DECL
2575 && TREE_PUBLIC (var_decl)
2576 && !have_global_bss_p ())
2577 DECL_COMMON (var_decl) = 1;
2579 /* Do not emit debug info for a CONST_DECL if optimization isn't enabled,
2580 since we will create an associated variable. Likewise for an external
2581 constant whose initializer is not absolute, because this would mean a
2582 global relocation in a read-only section which runs afoul of the PE-COFF
2583 run-time relocation mechanism. */
2584 if (!debug_info_p
2585 || (TREE_CODE (var_decl) == CONST_DECL && !optimize)
2586 || (extern_flag
2587 && constant_p
2588 && init
2589 && initializer_constant_valid_p (init, TREE_TYPE (init))
2590 != null_pointer_node))
2591 DECL_IGNORED_P (var_decl) = 1;
2593 /* ??? Some attributes cannot be applied to CONST_DECLs. */
2594 if (TREE_CODE (var_decl) == VAR_DECL)
2595 process_attributes (&var_decl, &attr_list, true, gnat_node);
2597 /* Add this decl to the current binding level. */
2598 gnat_pushdecl (var_decl, gnat_node);
2600 if (TREE_CODE (var_decl) == VAR_DECL && asm_name)
2602 /* Let the target mangle the name if this isn't a verbatim asm. */
2603 if (*IDENTIFIER_POINTER (asm_name) != '*')
2604 asm_name = targetm.mangle_decl_assembler_name (var_decl, asm_name);
2606 SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
2609 return var_decl;
2612 /* Return true if TYPE, an aggregate type, contains (or is) an array. */
2614 static bool
2615 aggregate_type_contains_array_p (tree type)
2617 switch (TREE_CODE (type))
2619 case RECORD_TYPE:
2620 case UNION_TYPE:
2621 case QUAL_UNION_TYPE:
2623 tree field;
2624 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
2625 if (AGGREGATE_TYPE_P (TREE_TYPE (field))
2626 && aggregate_type_contains_array_p (TREE_TYPE (field)))
2627 return true;
2628 return false;
2631 case ARRAY_TYPE:
2632 return true;
2634 default:
2635 gcc_unreachable ();
2639 /* Return a FIELD_DECL node. NAME is the field's name, TYPE is its type and
2640 RECORD_TYPE is the type of the enclosing record. If SIZE is nonzero, it
2641 is the specified size of the field. If POS is nonzero, it is the bit
2642 position. PACKED is 1 if the enclosing record is packed, -1 if it has
2643 Component_Alignment of Storage_Unit. If ADDRESSABLE is nonzero, it
2644 means we are allowed to take the address of the field; if it is negative,
2645 we should not make a bitfield, which is used by make_aligning_type. */
2647 tree
2648 create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
2649 int packed, int addressable)
2651 tree field_decl = build_decl (input_location, FIELD_DECL, name, type);
2653 DECL_CONTEXT (field_decl) = record_type;
2654 TREE_READONLY (field_decl) = TYPE_READONLY (type);
2656 /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
2657 byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
2658 Likewise for an aggregate without specified position that contains an
2659 array, because in this case slices of variable length of this array
2660 must be handled by GCC and variable-sized objects need to be aligned
2661 to at least a byte boundary. */
2662 if (packed && (TYPE_MODE (type) == BLKmode
2663 || (!pos
2664 && AGGREGATE_TYPE_P (type)
2665 && aggregate_type_contains_array_p (type))))
2666 SET_DECL_ALIGN (field_decl, BITS_PER_UNIT);
2668 /* If a size is specified, use it. Otherwise, if the record type is packed
2669 compute a size to use, which may differ from the object's natural size.
2670 We always set a size in this case to trigger the checks for bitfield
2671 creation below, which is typically required when no position has been
2672 specified. */
2673 if (size)
2674 size = convert (bitsizetype, size);
2675 else if (packed == 1)
2677 size = rm_size (type);
2678 if (TYPE_MODE (type) == BLKmode)
2679 size = round_up (size, BITS_PER_UNIT);
2682 /* If we may, according to ADDRESSABLE, make a bitfield if a size is
2683 specified for two reasons: first if the size differs from the natural
2684 size. Second, if the alignment is insufficient. There are a number of
2685 ways the latter can be true.
2687 We never make a bitfield if the type of the field has a nonconstant size,
2688 because no such entity requiring bitfield operations should reach here.
2690 We do *preventively* make a bitfield when there might be the need for it
2691 but we don't have all the necessary information to decide, as is the case
2692 of a field with no specified position in a packed record.
2694 We also don't look at STRICT_ALIGNMENT here, and rely on later processing
2695 in layout_decl or finish_record_type to clear the bit_field indication if
2696 it is in fact not needed. */
2697 if (addressable >= 0
2698 && size
2699 && TREE_CODE (size) == INTEGER_CST
2700 && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST
2701 && (!tree_int_cst_equal (size, TYPE_SIZE (type))
2702 || (pos && !value_factor_p (pos, TYPE_ALIGN (type)))
2703 || packed
2704 || (TYPE_ALIGN (record_type) != 0
2705 && TYPE_ALIGN (record_type) < TYPE_ALIGN (type))))
2707 DECL_BIT_FIELD (field_decl) = 1;
2708 DECL_SIZE (field_decl) = size;
2709 if (!packed && !pos)
2711 if (TYPE_ALIGN (record_type) != 0
2712 && TYPE_ALIGN (record_type) < TYPE_ALIGN (type))
2713 SET_DECL_ALIGN (field_decl, TYPE_ALIGN (record_type));
2714 else
2715 SET_DECL_ALIGN (field_decl, TYPE_ALIGN (type));
2719 DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
2721 /* Bump the alignment if need be, either for bitfield/packing purposes or
2722 to satisfy the type requirements if no such consideration applies. When
2723 we get the alignment from the type, indicate if this is from an explicit
2724 user request, which prevents stor-layout from lowering it later on. */
2726 unsigned int bit_align
2727 = (DECL_BIT_FIELD (field_decl) ? 1
2728 : packed && TYPE_MODE (type) != BLKmode ? BITS_PER_UNIT : 0);
2730 if (bit_align > DECL_ALIGN (field_decl))
2731 SET_DECL_ALIGN (field_decl, bit_align);
2732 else if (!bit_align && TYPE_ALIGN (type) > DECL_ALIGN (field_decl))
2734 SET_DECL_ALIGN (field_decl, TYPE_ALIGN (type));
2735 DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (type);
2739 if (pos)
2741 /* We need to pass in the alignment the DECL is known to have.
2742 This is the lowest-order bit set in POS, but no more than
2743 the alignment of the record, if one is specified. Note
2744 that an alignment of 0 is taken as infinite. */
2745 unsigned int known_align;
2747 if (tree_fits_uhwi_p (pos))
2748 known_align = tree_to_uhwi (pos) & - tree_to_uhwi (pos);
2749 else
2750 known_align = BITS_PER_UNIT;
2752 if (TYPE_ALIGN (record_type)
2753 && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
2754 known_align = TYPE_ALIGN (record_type);
2756 layout_decl (field_decl, known_align);
2757 SET_DECL_OFFSET_ALIGN (field_decl,
2758 tree_fits_uhwi_p (pos) ? BIGGEST_ALIGNMENT
2759 : BITS_PER_UNIT);
2760 pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
2761 &DECL_FIELD_BIT_OFFSET (field_decl),
2762 DECL_OFFSET_ALIGN (field_decl), pos);
2765 /* In addition to what our caller says, claim the field is addressable if we
2766 know that its type is not suitable.
2768 The field may also be "technically" nonaddressable, meaning that even if
2769 we attempt to take the field's address we will actually get the address
2770 of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD
2771 value we have at this point is not accurate enough, so we don't account
2772 for this here and let finish_record_type decide. */
2773 if (!addressable && !type_for_nonaliased_component_p (type))
2774 addressable = 1;
2776 DECL_NONADDRESSABLE_P (field_decl) = !addressable;
2778 return field_decl;
2781 /* Return a PARM_DECL node with NAME and TYPE. */
2783 tree
2784 create_param_decl (tree name, tree type)
2786 tree param_decl = build_decl (input_location, PARM_DECL, name, type);
2788 /* Honor TARGET_PROMOTE_PROTOTYPES like the C compiler, as not doing so
2789 can lead to various ABI violations. */
2790 if (targetm.calls.promote_prototypes (NULL_TREE)
2791 && INTEGRAL_TYPE_P (type)
2792 && TYPE_PRECISION (type) < TYPE_PRECISION (integer_type_node))
2794 /* We have to be careful about biased types here. Make a subtype
2795 of integer_type_node with the proper biasing. */
2796 if (TREE_CODE (type) == INTEGER_TYPE
2797 && TYPE_BIASED_REPRESENTATION_P (type))
2799 tree subtype
2800 = make_unsigned_type (TYPE_PRECISION (integer_type_node));
2801 TREE_TYPE (subtype) = integer_type_node;
2802 TYPE_BIASED_REPRESENTATION_P (subtype) = 1;
2803 SET_TYPE_RM_MIN_VALUE (subtype, TYPE_MIN_VALUE (type));
2804 SET_TYPE_RM_MAX_VALUE (subtype, TYPE_MAX_VALUE (type));
2805 type = subtype;
2807 else
2808 type = integer_type_node;
2811 DECL_ARG_TYPE (param_decl) = type;
2812 return param_decl;
2815 /* Process the attributes in ATTR_LIST for NODE, which is either a DECL or
2816 a TYPE. If IN_PLACE is true, the tree pointed to by NODE should not be
2817 changed. GNAT_NODE is used for the position of error messages. */
2819 void
2820 process_attributes (tree *node, struct attrib **attr_list, bool in_place,
2821 Node_Id gnat_node)
2823 struct attrib *attr;
2825 for (attr = *attr_list; attr; attr = attr->next)
2826 switch (attr->type)
2828 case ATTR_MACHINE_ATTRIBUTE:
2829 Sloc_to_locus (Sloc (gnat_node), &input_location);
2830 decl_attributes (node, tree_cons (attr->name, attr->args, NULL_TREE),
2831 in_place ? ATTR_FLAG_TYPE_IN_PLACE : 0);
2832 break;
2834 case ATTR_LINK_ALIAS:
2835 if (!DECL_EXTERNAL (*node))
2837 TREE_STATIC (*node) = 1;
2838 assemble_alias (*node, attr->name);
2840 break;
2842 case ATTR_WEAK_EXTERNAL:
2843 if (SUPPORTS_WEAK)
2844 declare_weak (*node);
2845 else
2846 post_error ("?weak declarations not supported on this target",
2847 attr->error_point);
2848 break;
2850 case ATTR_LINK_SECTION:
2851 if (targetm_common.have_named_sections)
2853 set_decl_section_name (*node, IDENTIFIER_POINTER (attr->name));
2854 DECL_COMMON (*node) = 0;
2856 else
2857 post_error ("?section attributes are not supported for this target",
2858 attr->error_point);
2859 break;
2861 case ATTR_LINK_CONSTRUCTOR:
2862 DECL_STATIC_CONSTRUCTOR (*node) = 1;
2863 TREE_USED (*node) = 1;
2864 break;
2866 case ATTR_LINK_DESTRUCTOR:
2867 DECL_STATIC_DESTRUCTOR (*node) = 1;
2868 TREE_USED (*node) = 1;
2869 break;
2871 case ATTR_THREAD_LOCAL_STORAGE:
2872 set_decl_tls_model (*node, decl_default_tls_model (*node));
2873 DECL_COMMON (*node) = 0;
2874 break;
2877 *attr_list = NULL;
2880 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
2881 a power of 2. */
2883 bool
2884 value_factor_p (tree value, HOST_WIDE_INT factor)
2886 if (tree_fits_uhwi_p (value))
2887 return tree_to_uhwi (value) % factor == 0;
2889 if (TREE_CODE (value) == MULT_EXPR)
2890 return (value_factor_p (TREE_OPERAND (value, 0), factor)
2891 || value_factor_p (TREE_OPERAND (value, 1), factor));
2893 return false;
2896 /* Return whether GNAT_NODE is a defining identifier for a renaming that comes
2897 from the parameter association for the instantiation of a generic. We do
2898 not want to emit source location for them: the code generated for their
2899 initialization is likely to disturb debugging. */
2901 bool
2902 renaming_from_instantiation_p (Node_Id gnat_node)
2904 if (Nkind (gnat_node) != N_Defining_Identifier
2905 || !Is_Object (gnat_node)
2906 || Comes_From_Source (gnat_node)
2907 || !Present (Renamed_Object (gnat_node)))
2908 return false;
2910 /* Get the object declaration of the renamed object, if any and if the
2911 renamed object is a mere identifier. */
2912 gnat_node = Renamed_Object (gnat_node);
2913 if (Nkind (gnat_node) != N_Identifier)
2914 return false;
2916 gnat_node = Entity (gnat_node);
2917 if (!Present (Parent (gnat_node)))
2918 return false;
2920 gnat_node = Parent (gnat_node);
2921 return
2922 (Present (gnat_node)
2923 && Nkind (gnat_node) == N_Object_Declaration
2924 && Present (Corresponding_Generic_Association (gnat_node)));
2927 /* Defer the initialization of DECL's DECL_CONTEXT attribute, scheduling to
2928 feed it with the elaboration of GNAT_SCOPE. */
2930 static struct deferred_decl_context_node *
2931 add_deferred_decl_context (tree decl, Entity_Id gnat_scope, int force_global)
2933 struct deferred_decl_context_node *new_node;
2935 new_node
2936 = (struct deferred_decl_context_node * ) xmalloc (sizeof (*new_node));
2937 new_node->decl = decl;
2938 new_node->gnat_scope = gnat_scope;
2939 new_node->force_global = force_global;
2940 new_node->types.create (1);
2941 new_node->next = deferred_decl_context_queue;
2942 deferred_decl_context_queue = new_node;
2943 return new_node;
2946 /* Defer the initialization of TYPE's TYPE_CONTEXT attribute, scheduling to
2947 feed it with the DECL_CONTEXT computed as part of N as soon as it is
2948 computed. */
2950 static void
2951 add_deferred_type_context (struct deferred_decl_context_node *n, tree type)
2953 n->types.safe_push (type);
2956 /* Get the GENERIC node corresponding to GNAT_SCOPE, if available. Return
2957 NULL_TREE if it is not available. */
2959 static tree
2960 compute_deferred_decl_context (Entity_Id gnat_scope)
2962 tree context;
2964 if (present_gnu_tree (gnat_scope))
2965 context = get_gnu_tree (gnat_scope);
2966 else
2967 return NULL_TREE;
2969 if (TREE_CODE (context) == TYPE_DECL)
2971 const tree context_type = TREE_TYPE (context);
2973 /* Skip dummy types: only the final ones can appear in the context
2974 chain. */
2975 if (TYPE_DUMMY_P (context_type))
2976 return NULL_TREE;
2978 /* ..._TYPE nodes are more useful than TYPE_DECL nodes in the context
2979 chain. */
2980 else
2981 context = context_type;
2984 return context;
2987 /* Try to process all deferred nodes in the queue. Keep in the queue the ones
2988 that cannot be processed yet, remove the other ones. If FORCE is true,
2989 force the processing for all nodes, use the global context when nodes don't
2990 have a GNU translation. */
2992 void
2993 process_deferred_decl_context (bool force)
2995 struct deferred_decl_context_node **it = &deferred_decl_context_queue;
2996 struct deferred_decl_context_node *node;
2998 while (*it)
3000 bool processed = false;
3001 tree context = NULL_TREE;
3002 Entity_Id gnat_scope;
3004 node = *it;
3006 /* If FORCE, get the innermost elaborated scope. Otherwise, just try to
3007 get the first scope. */
3008 gnat_scope = node->gnat_scope;
3009 while (Present (gnat_scope))
3011 context = compute_deferred_decl_context (gnat_scope);
3012 if (!force || context)
3013 break;
3014 gnat_scope = get_debug_scope (gnat_scope, NULL);
3017 /* Imported declarations must not be in a local context (i.e. not inside
3018 a function). */
3019 if (context && node->force_global > 0)
3021 tree ctx = context;
3023 while (ctx)
3025 gcc_assert (TREE_CODE (ctx) != FUNCTION_DECL);
3026 ctx = DECL_P (ctx) ? DECL_CONTEXT (ctx) : TYPE_CONTEXT (ctx);
3030 /* If FORCE, we want to get rid of all nodes in the queue: in case there
3031 was no elaborated scope, use the global context. */
3032 if (force && !context)
3033 context = get_global_context ();
3035 if (context)
3037 tree t;
3038 int i;
3040 DECL_CONTEXT (node->decl) = context;
3042 /* Propagate it to the TYPE_CONTEXT attributes of the requested
3043 ..._TYPE nodes. */
3044 FOR_EACH_VEC_ELT (node->types, i, t)
3046 gnat_set_type_context (t, context);
3048 processed = true;
3051 /* If this node has been successfuly processed, remove it from the
3052 queue. Then move to the next node. */
3053 if (processed)
3055 *it = node->next;
3056 node->types.release ();
3057 free (node);
3059 else
3060 it = &node->next;
3064 /* Return VALUE scaled by the biggest power-of-2 factor of EXPR. */
3066 static unsigned int
3067 scale_by_factor_of (tree expr, unsigned int value)
3069 unsigned HOST_WIDE_INT addend = 0;
3070 unsigned HOST_WIDE_INT factor = 1;
3072 /* Peel conversions around EXPR and try to extract bodies from function
3073 calls: it is possible to get the scale factor from size functions. */
3074 expr = remove_conversions (expr, true);
3075 if (TREE_CODE (expr) == CALL_EXPR)
3076 expr = maybe_inline_call_in_expr (expr);
3078 /* Sometimes we get PLUS_EXPR (BIT_AND_EXPR (..., X), Y), where Y is a
3079 multiple of the scale factor we are looking for. */
3080 if (TREE_CODE (expr) == PLUS_EXPR
3081 && TREE_CODE (TREE_OPERAND (expr, 1)) == INTEGER_CST
3082 && tree_fits_uhwi_p (TREE_OPERAND (expr, 1)))
3084 addend = TREE_INT_CST_LOW (TREE_OPERAND (expr, 1));
3085 expr = TREE_OPERAND (expr, 0);
3088 /* An expression which is a bitwise AND with a mask has a power-of-2 factor
3089 corresponding to the number of trailing zeros of the mask. */
3090 if (TREE_CODE (expr) == BIT_AND_EXPR
3091 && TREE_CODE (TREE_OPERAND (expr, 1)) == INTEGER_CST)
3093 unsigned HOST_WIDE_INT mask = TREE_INT_CST_LOW (TREE_OPERAND (expr, 1));
3094 unsigned int i = 0;
3096 while ((mask & 1) == 0 && i < HOST_BITS_PER_WIDE_INT)
3098 mask >>= 1;
3099 factor *= 2;
3100 i++;
3104 /* If the addend is not a multiple of the factor we found, give up. In
3105 theory we could find a smaller common factor but it's useless for our
3106 needs. This situation arises when dealing with a field F1 with no
3107 alignment requirement but that is following a field F2 with such
3108 requirements. As long as we have F2's offset, we don't need alignment
3109 information to compute F1's. */
3110 if (addend % factor != 0)
3111 factor = 1;
3113 return factor * value;
3116 /* Given two consecutive field decls PREV_FIELD and CURR_FIELD, return true
3117 unless we can prove these 2 fields are laid out in such a way that no gap
3118 exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET
3119 is the distance in bits between the end of PREV_FIELD and the starting
3120 position of CURR_FIELD. It is ignored if null. */
3122 static bool
3123 potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
3125 /* If this is the first field of the record, there cannot be any gap */
3126 if (!prev_field)
3127 return false;
3129 /* If the previous field is a union type, then return false: The only
3130 time when such a field is not the last field of the record is when
3131 there are other components at fixed positions after it (meaning there
3132 was a rep clause for every field), in which case we don't want the
3133 alignment constraint to override them. */
3134 if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
3135 return false;
3137 /* If the distance between the end of prev_field and the beginning of
3138 curr_field is constant, then there is a gap if the value of this
3139 constant is not null. */
3140 if (offset && tree_fits_uhwi_p (offset))
3141 return !integer_zerop (offset);
3143 /* If the size and position of the previous field are constant,
3144 then check the sum of this size and position. There will be a gap
3145 iff it is not multiple of the current field alignment. */
3146 if (tree_fits_uhwi_p (DECL_SIZE (prev_field))
3147 && tree_fits_uhwi_p (bit_position (prev_field)))
3148 return ((tree_to_uhwi (bit_position (prev_field))
3149 + tree_to_uhwi (DECL_SIZE (prev_field)))
3150 % DECL_ALIGN (curr_field) != 0);
3152 /* If both the position and size of the previous field are multiples
3153 of the current field alignment, there cannot be any gap. */
3154 if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
3155 && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
3156 return false;
3158 /* Fallback, return that there may be a potential gap */
3159 return true;
3162 /* Return a LABEL_DECL with NAME. GNAT_NODE is used for the position of
3163 the decl. */
3165 tree
3166 create_label_decl (tree name, Node_Id gnat_node)
3168 tree label_decl
3169 = build_decl (input_location, LABEL_DECL, name, void_type_node);
3171 SET_DECL_MODE (label_decl, VOIDmode);
3173 /* Add this decl to the current binding level. */
3174 gnat_pushdecl (label_decl, gnat_node);
3176 return label_decl;
3179 /* Return a FUNCTION_DECL node. NAME is the name of the subprogram, ASM_NAME
3180 its assembler name, TYPE its type (a FUNCTION_TYPE node), PARAM_DECL_LIST
3181 the list of its parameters (a list of PARM_DECL nodes chained through the
3182 DECL_CHAIN field).
3184 INLINE_STATUS describes the inline flags to be set on the FUNCTION_DECL.
3186 PUBLIC_FLAG is true if this is for a reference to a public entity or for a
3187 definition to be made visible outside of the current compilation unit.
3189 EXTERN_FLAG is true when processing an external subprogram declaration.
3191 ARTIFICIAL_P is true if the subprogram was generated by the compiler.
3193 DEBUG_INFO_P is true if we need to write debug information for it.
3195 DEFINITION is true if the subprogram is to be considered as a definition.
3197 ATTR_LIST is the list of attributes to be attached to the subprogram.
3199 GNAT_NODE is used for the position of the decl. */
3201 tree
3202 create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
3203 enum inline_status_t inline_status, bool public_flag,
3204 bool extern_flag, bool artificial_p, bool debug_info_p,
3205 bool definition, struct attrib *attr_list,
3206 Node_Id gnat_node)
3208 tree subprog_decl = build_decl (input_location, FUNCTION_DECL, name, type);
3209 DECL_ARGUMENTS (subprog_decl) = param_decl_list;
3211 DECL_ARTIFICIAL (subprog_decl) = artificial_p;
3212 DECL_EXTERNAL (subprog_decl) = extern_flag;
3213 TREE_PUBLIC (subprog_decl) = public_flag;
3215 if (!debug_info_p)
3216 DECL_IGNORED_P (subprog_decl) = 1;
3217 if (definition)
3218 DECL_FUNCTION_IS_DEF (subprog_decl) = 1;
3220 switch (inline_status)
3222 case is_suppressed:
3223 DECL_UNINLINABLE (subprog_decl) = 1;
3224 break;
3226 case is_disabled:
3227 break;
3229 case is_required:
3230 if (Back_End_Inlining)
3232 decl_attributes (&subprog_decl,
3233 tree_cons (get_identifier ("always_inline"),
3234 NULL_TREE, NULL_TREE),
3235 ATTR_FLAG_TYPE_IN_PLACE);
3237 /* Inline_Always guarantees that every direct call is inlined and
3238 that there is no indirect reference to the subprogram, so the
3239 instance in the original package (as well as its clones in the
3240 client packages created for inter-unit inlining) can be made
3241 private, which causes the out-of-line body to be eliminated. */
3242 TREE_PUBLIC (subprog_decl) = 0;
3245 /* ... fall through ... */
3247 case is_enabled:
3248 DECL_DECLARED_INLINE_P (subprog_decl) = 1;
3249 DECL_NO_INLINE_WARNING_P (subprog_decl) = artificial_p;
3250 break;
3252 default:
3253 gcc_unreachable ();
3256 process_attributes (&subprog_decl, &attr_list, true, gnat_node);
3258 /* Once everything is processed, finish the subprogram declaration. */
3259 finish_subprog_decl (subprog_decl, asm_name, type);
3261 /* Add this decl to the current binding level. */
3262 gnat_pushdecl (subprog_decl, gnat_node);
3264 /* Output the assembler code and/or RTL for the declaration. */
3265 rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
3267 return subprog_decl;
3270 /* Given a subprogram declaration DECL, its assembler name and its type,
3271 finish constructing the subprogram declaration from ASM_NAME and TYPE. */
3273 void
3274 finish_subprog_decl (tree decl, tree asm_name, tree type)
3276 tree result_decl
3277 = build_decl (DECL_SOURCE_LOCATION (decl), RESULT_DECL, NULL_TREE,
3278 TREE_TYPE (type));
3280 DECL_ARTIFICIAL (result_decl) = 1;
3281 DECL_IGNORED_P (result_decl) = 1;
3282 DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (type);
3283 DECL_RESULT (decl) = result_decl;
3285 TREE_READONLY (decl) = TYPE_READONLY (type);
3286 TREE_SIDE_EFFECTS (decl) = TREE_THIS_VOLATILE (decl) = TYPE_VOLATILE (type);
3288 if (asm_name)
3290 /* Let the target mangle the name if this isn't a verbatim asm. */
3291 if (*IDENTIFIER_POINTER (asm_name) != '*')
3292 asm_name = targetm.mangle_decl_assembler_name (decl, asm_name);
3294 SET_DECL_ASSEMBLER_NAME (decl, asm_name);
3296 /* The expand_main_function circuitry expects "main_identifier_node" to
3297 designate the DECL_NAME of the 'main' entry point, in turn expected
3298 to be declared as the "main" function literally by default. Ada
3299 program entry points are typically declared with a different name
3300 within the binder generated file, exported as 'main' to satisfy the
3301 system expectations. Force main_identifier_node in this case. */
3302 if (asm_name == main_identifier_node)
3303 DECL_NAME (decl) = main_identifier_node;
3307 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
3308 body. This routine needs to be invoked before processing the declarations
3309 appearing in the subprogram. */
3311 void
3312 begin_subprog_body (tree subprog_decl)
3314 tree param_decl;
3316 announce_function (subprog_decl);
3318 /* This function is being defined. */
3319 TREE_STATIC (subprog_decl) = 1;
3321 /* The failure of this assertion will likely come from a wrong context for
3322 the subprogram body, e.g. another procedure for a procedure declared at
3323 library level. */
3324 gcc_assert (current_function_decl == decl_function_context (subprog_decl));
3326 current_function_decl = subprog_decl;
3328 /* Enter a new binding level and show that all the parameters belong to
3329 this function. */
3330 gnat_pushlevel ();
3332 for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
3333 param_decl = DECL_CHAIN (param_decl))
3334 DECL_CONTEXT (param_decl) = subprog_decl;
3336 make_decl_rtl (subprog_decl);
3339 /* Finish translating the current subprogram and set its BODY. */
3341 void
3342 end_subprog_body (tree body)
3344 tree fndecl = current_function_decl;
3346 /* Attach the BLOCK for this level to the function and pop the level. */
3347 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
3348 DECL_INITIAL (fndecl) = current_binding_level->block;
3349 gnat_poplevel ();
3351 /* Mark the RESULT_DECL as being in this subprogram. */
3352 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
3354 /* The body should be a BIND_EXPR whose BLOCK is the top-level one. */
3355 if (TREE_CODE (body) == BIND_EXPR)
3357 BLOCK_SUPERCONTEXT (BIND_EXPR_BLOCK (body)) = fndecl;
3358 DECL_INITIAL (fndecl) = BIND_EXPR_BLOCK (body);
3361 DECL_SAVED_TREE (fndecl) = body;
3363 current_function_decl = decl_function_context (fndecl);
3366 /* Wrap up compilation of SUBPROG_DECL, a subprogram body. */
3368 void
3369 rest_of_subprog_body_compilation (tree subprog_decl)
3371 /* We cannot track the location of errors past this point. */
3372 error_gnat_node = Empty;
3374 /* If we're only annotating types, don't actually compile this function. */
3375 if (type_annotate_only)
3376 return;
3378 /* Dump functions before gimplification. */
3379 dump_function (TDI_original, subprog_decl);
3381 if (!decl_function_context (subprog_decl))
3382 cgraph_node::finalize_function (subprog_decl, false);
3383 else
3384 /* Register this function with cgraph just far enough to get it
3385 added to our parent's nested function list. */
3386 (void) cgraph_node::get_create (subprog_decl);
3389 tree
3390 gnat_builtin_function (tree decl)
3392 gnat_pushdecl (decl, Empty);
3393 return decl;
3396 /* Return an integer type with the number of bits of precision given by
3397 PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
3398 it is a signed type. */
3400 tree
3401 gnat_type_for_size (unsigned precision, int unsignedp)
3403 tree t;
3404 char type_name[20];
3406 if (precision <= 2 * MAX_BITS_PER_WORD
3407 && signed_and_unsigned_types[precision][unsignedp])
3408 return signed_and_unsigned_types[precision][unsignedp];
3410 if (unsignedp)
3411 t = make_unsigned_type (precision);
3412 else
3413 t = make_signed_type (precision);
3414 TYPE_ARTIFICIAL (t) = 1;
3416 if (precision <= 2 * MAX_BITS_PER_WORD)
3417 signed_and_unsigned_types[precision][unsignedp] = t;
3419 if (!TYPE_NAME (t))
3421 sprintf (type_name, "%sSIGNED_%u", unsignedp ? "UN" : "", precision);
3422 TYPE_NAME (t) = get_identifier (type_name);
3425 return t;
3428 /* Likewise for floating-point types. */
3430 static tree
3431 float_type_for_precision (int precision, machine_mode mode)
3433 tree t;
3434 char type_name[20];
3436 if (float_types[(int) mode])
3437 return float_types[(int) mode];
3439 float_types[(int) mode] = t = make_node (REAL_TYPE);
3440 TYPE_PRECISION (t) = precision;
3441 layout_type (t);
3443 gcc_assert (TYPE_MODE (t) == mode);
3444 if (!TYPE_NAME (t))
3446 sprintf (type_name, "FLOAT_%d", precision);
3447 TYPE_NAME (t) = get_identifier (type_name);
3450 return t;
3453 /* Return a data type that has machine mode MODE. UNSIGNEDP selects
3454 an unsigned type; otherwise a signed type is returned. */
3456 tree
3457 gnat_type_for_mode (machine_mode mode, int unsignedp)
3459 if (mode == BLKmode)
3460 return NULL_TREE;
3462 if (mode == VOIDmode)
3463 return void_type_node;
3465 if (COMPLEX_MODE_P (mode))
3466 return NULL_TREE;
3468 scalar_float_mode float_mode;
3469 if (is_a <scalar_float_mode> (mode, &float_mode))
3470 return float_type_for_precision (GET_MODE_PRECISION (float_mode),
3471 float_mode);
3473 scalar_int_mode int_mode;
3474 if (is_a <scalar_int_mode> (mode, &int_mode))
3475 return gnat_type_for_size (GET_MODE_BITSIZE (int_mode), unsignedp);
3477 if (VECTOR_MODE_P (mode))
3479 machine_mode inner_mode = GET_MODE_INNER (mode);
3480 tree inner_type = gnat_type_for_mode (inner_mode, unsignedp);
3481 if (inner_type)
3482 return build_vector_type_for_mode (inner_type, mode);
3485 return NULL_TREE;
3488 /* Return the signed or unsigned version of TYPE_NODE, a scalar type, the
3489 signedness being specified by UNSIGNEDP. */
3491 tree
3492 gnat_signed_or_unsigned_type_for (int unsignedp, tree type_node)
3494 if (type_node == char_type_node)
3495 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
3497 tree type = gnat_type_for_size (TYPE_PRECISION (type_node), unsignedp);
3499 if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
3501 type = copy_type (type);
3502 TREE_TYPE (type) = type_node;
3504 else if (TREE_TYPE (type_node)
3505 && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
3506 && TYPE_MODULAR_P (TREE_TYPE (type_node)))
3508 type = copy_type (type);
3509 TREE_TYPE (type) = TREE_TYPE (type_node);
3512 return type;
3515 /* Return 1 if the types T1 and T2 are compatible, i.e. if they can be
3516 transparently converted to each other. */
3519 gnat_types_compatible_p (tree t1, tree t2)
3521 enum tree_code code;
3523 /* This is the default criterion. */
3524 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
3525 return 1;
3527 /* We only check structural equivalence here. */
3528 if ((code = TREE_CODE (t1)) != TREE_CODE (t2))
3529 return 0;
3531 /* Vector types are also compatible if they have the same number of subparts
3532 and the same form of (scalar) element type. */
3533 if (code == VECTOR_TYPE
3534 && TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2)
3535 && TREE_CODE (TREE_TYPE (t1)) == TREE_CODE (TREE_TYPE (t2))
3536 && TYPE_PRECISION (TREE_TYPE (t1)) == TYPE_PRECISION (TREE_TYPE (t2)))
3537 return 1;
3539 /* Array types are also compatible if they are constrained and have the same
3540 domain(s), the same component type and the same scalar storage order. */
3541 if (code == ARRAY_TYPE
3542 && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2)
3543 || (TYPE_DOMAIN (t1)
3544 && TYPE_DOMAIN (t2)
3545 && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)),
3546 TYPE_MIN_VALUE (TYPE_DOMAIN (t2)))
3547 && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)),
3548 TYPE_MAX_VALUE (TYPE_DOMAIN (t2)))))
3549 && (TREE_TYPE (t1) == TREE_TYPE (t2)
3550 || (TREE_CODE (TREE_TYPE (t1)) == ARRAY_TYPE
3551 && gnat_types_compatible_p (TREE_TYPE (t1), TREE_TYPE (t2))))
3552 && TYPE_REVERSE_STORAGE_ORDER (t1) == TYPE_REVERSE_STORAGE_ORDER (t2))
3553 return 1;
3555 return 0;
3558 /* Return true if EXPR is a useless type conversion. */
3560 bool
3561 gnat_useless_type_conversion (tree expr)
3563 if (CONVERT_EXPR_P (expr)
3564 || TREE_CODE (expr) == VIEW_CONVERT_EXPR
3565 || TREE_CODE (expr) == NON_LVALUE_EXPR)
3566 return gnat_types_compatible_p (TREE_TYPE (expr),
3567 TREE_TYPE (TREE_OPERAND (expr, 0)));
3569 return false;
3572 /* Return true if T, a FUNCTION_TYPE, has the specified list of flags. */
3574 bool
3575 fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p,
3576 bool return_by_direct_ref_p, bool return_by_invisi_ref_p)
3578 return TYPE_CI_CO_LIST (t) == cico_list
3579 && TYPE_RETURN_UNCONSTRAINED_P (t) == return_unconstrained_p
3580 && TYPE_RETURN_BY_DIRECT_REF_P (t) == return_by_direct_ref_p
3581 && TREE_ADDRESSABLE (t) == return_by_invisi_ref_p;
3584 /* EXP is an expression for the size of an object. If this size contains
3585 discriminant references, replace them with the maximum (if MAX_P) or
3586 minimum (if !MAX_P) possible value of the discriminant. */
3588 tree
3589 max_size (tree exp, bool max_p)
3591 enum tree_code code = TREE_CODE (exp);
3592 tree type = TREE_TYPE (exp);
3593 tree op0, op1, op2;
3595 switch (TREE_CODE_CLASS (code))
3597 case tcc_declaration:
3598 case tcc_constant:
3599 return exp;
3601 case tcc_exceptional:
3602 gcc_assert (code == SSA_NAME);
3603 return exp;
3605 case tcc_vl_exp:
3606 if (code == CALL_EXPR)
3608 tree t, *argarray;
3609 int n, i;
3611 t = maybe_inline_call_in_expr (exp);
3612 if (t)
3613 return max_size (t, max_p);
3615 n = call_expr_nargs (exp);
3616 gcc_assert (n > 0);
3617 argarray = XALLOCAVEC (tree, n);
3618 for (i = 0; i < n; i++)
3619 argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p);
3620 return build_call_array (type, CALL_EXPR_FN (exp), n, argarray);
3622 break;
3624 case tcc_reference:
3625 /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
3626 modify. Otherwise, we treat it like a variable. */
3627 if (CONTAINS_PLACEHOLDER_P (exp))
3629 tree val_type = TREE_TYPE (TREE_OPERAND (exp, 1));
3630 tree val = (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
3631 return
3632 convert (type,
3633 max_size (convert (get_base_type (val_type), val), true));
3636 return exp;
3638 case tcc_comparison:
3639 return build_int_cst (type, max_p ? 1 : 0);
3641 case tcc_unary:
3642 if (code == NON_LVALUE_EXPR)
3643 return max_size (TREE_OPERAND (exp, 0), max_p);
3645 op0 = max_size (TREE_OPERAND (exp, 0),
3646 code == NEGATE_EXPR ? !max_p : max_p);
3648 if (op0 == TREE_OPERAND (exp, 0))
3649 return exp;
3651 return fold_build1 (code, type, op0);
3653 case tcc_binary:
3655 tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
3656 tree rhs = max_size (TREE_OPERAND (exp, 1),
3657 code == MINUS_EXPR ? !max_p : max_p);
3659 /* Special-case wanting the maximum value of a MIN_EXPR.
3660 In that case, if one side overflows, return the other. */
3661 if (max_p && code == MIN_EXPR)
3663 if (TREE_CODE (rhs) == INTEGER_CST && TREE_OVERFLOW (rhs))
3664 return lhs;
3666 if (TREE_CODE (lhs) == INTEGER_CST && TREE_OVERFLOW (lhs))
3667 return rhs;
3670 /* Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
3671 overflowing and the RHS a variable. */
3672 if ((code == MINUS_EXPR || code == PLUS_EXPR)
3673 && TREE_CODE (lhs) == INTEGER_CST
3674 && TREE_OVERFLOW (lhs)
3675 && TREE_CODE (rhs) != INTEGER_CST)
3676 return lhs;
3678 /* If we are going to subtract a "negative" value in an unsigned type,
3679 do the operation as an addition of the negated value, in order to
3680 avoid creating a spurious overflow below. */
3681 if (code == MINUS_EXPR
3682 && TYPE_UNSIGNED (type)
3683 && TREE_CODE (rhs) == INTEGER_CST
3684 && !TREE_OVERFLOW (rhs)
3685 && tree_int_cst_sign_bit (rhs) != 0)
3687 rhs = fold_build1 (NEGATE_EXPR, type, rhs);
3688 code = PLUS_EXPR;
3691 if (lhs == TREE_OPERAND (exp, 0) && rhs == TREE_OPERAND (exp, 1))
3692 return exp;
3694 /* We need to detect overflows so we call size_binop here. */
3695 return size_binop (code, lhs, rhs);
3698 case tcc_expression:
3699 switch (TREE_CODE_LENGTH (code))
3701 case 1:
3702 if (code == SAVE_EXPR)
3703 return exp;
3705 op0 = max_size (TREE_OPERAND (exp, 0),
3706 code == TRUTH_NOT_EXPR ? !max_p : max_p);
3708 if (op0 == TREE_OPERAND (exp, 0))
3709 return exp;
3711 return fold_build1 (code, type, op0);
3713 case 2:
3714 if (code == COMPOUND_EXPR)
3715 return max_size (TREE_OPERAND (exp, 1), max_p);
3717 op0 = max_size (TREE_OPERAND (exp, 0), max_p);
3718 op1 = max_size (TREE_OPERAND (exp, 1), max_p);
3720 if (op0 == TREE_OPERAND (exp, 0) && op1 == TREE_OPERAND (exp, 1))
3721 return exp;
3723 return fold_build2 (code, type, op0, op1);
3725 case 3:
3726 if (code == COND_EXPR)
3728 op1 = TREE_OPERAND (exp, 1);
3729 op2 = TREE_OPERAND (exp, 2);
3731 if (!op1 || !op2)
3732 return exp;
3734 return
3735 fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
3736 max_size (op1, max_p), max_size (op2, max_p));
3738 break;
3740 default:
3741 break;
3744 /* Other tree classes cannot happen. */
3745 default:
3746 break;
3749 gcc_unreachable ();
3752 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
3753 EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
3754 Return a constructor for the template. */
3756 tree
3757 build_template (tree template_type, tree array_type, tree expr)
3759 vec<constructor_elt, va_gc> *template_elts = NULL;
3760 tree bound_list = NULL_TREE;
3761 tree field;
3763 while (TREE_CODE (array_type) == RECORD_TYPE
3764 && (TYPE_PADDING_P (array_type)
3765 || TYPE_JUSTIFIED_MODULAR_P (array_type)))
3766 array_type = TREE_TYPE (TYPE_FIELDS (array_type));
3768 if (TREE_CODE (array_type) == ARRAY_TYPE
3769 || (TREE_CODE (array_type) == INTEGER_TYPE
3770 && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
3771 bound_list = TYPE_ACTUAL_BOUNDS (array_type);
3773 /* First make the list for a CONSTRUCTOR for the template. Go down the
3774 field list of the template instead of the type chain because this
3775 array might be an Ada array of arrays and we can't tell where the
3776 nested arrays stop being the underlying object. */
3778 for (field = TYPE_FIELDS (template_type); field;
3779 (bound_list
3780 ? (bound_list = TREE_CHAIN (bound_list))
3781 : (array_type = TREE_TYPE (array_type))),
3782 field = DECL_CHAIN (DECL_CHAIN (field)))
3784 tree bounds, min, max;
3786 /* If we have a bound list, get the bounds from there. Likewise
3787 for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
3788 DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
3789 This will give us a maximum range. */
3790 if (bound_list)
3791 bounds = TREE_VALUE (bound_list);
3792 else if (TREE_CODE (array_type) == ARRAY_TYPE)
3793 bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
3794 else if (expr && TREE_CODE (expr) == PARM_DECL
3795 && DECL_BY_COMPONENT_PTR_P (expr))
3796 bounds = TREE_TYPE (field);
3797 else
3798 gcc_unreachable ();
3800 min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds));
3801 max = convert (TREE_TYPE (DECL_CHAIN (field)), TYPE_MAX_VALUE (bounds));
3803 /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
3804 substitute it from OBJECT. */
3805 min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr);
3806 max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr);
3808 CONSTRUCTOR_APPEND_ELT (template_elts, field, min);
3809 CONSTRUCTOR_APPEND_ELT (template_elts, DECL_CHAIN (field), max);
3812 return gnat_build_constructor (template_type, template_elts);
3815 /* Return true if TYPE is suitable for the element type of a vector. */
3817 static bool
3818 type_for_vector_element_p (tree type)
3820 machine_mode mode;
3822 if (!INTEGRAL_TYPE_P (type)
3823 && !SCALAR_FLOAT_TYPE_P (type)
3824 && !FIXED_POINT_TYPE_P (type))
3825 return false;
3827 mode = TYPE_MODE (type);
3828 if (GET_MODE_CLASS (mode) != MODE_INT
3829 && !SCALAR_FLOAT_MODE_P (mode)
3830 && !ALL_SCALAR_FIXED_POINT_MODE_P (mode))
3831 return false;
3833 return true;
3836 /* Return a vector type given the SIZE and the INNER_TYPE, or NULL_TREE if
3837 this is not possible. If ATTRIBUTE is non-zero, we are processing the
3838 attribute declaration and want to issue error messages on failure. */
3840 static tree
3841 build_vector_type_for_size (tree inner_type, tree size, tree attribute)
3843 unsigned HOST_WIDE_INT size_int, inner_size_int;
3844 int nunits;
3846 /* Silently punt on variable sizes. We can't make vector types for them,
3847 need to ignore them on front-end generated subtypes of unconstrained
3848 base types, and this attribute is for binding implementors, not end
3849 users, so we should never get there from legitimate explicit uses. */
3850 if (!tree_fits_uhwi_p (size))
3851 return NULL_TREE;
3852 size_int = tree_to_uhwi (size);
3854 if (!type_for_vector_element_p (inner_type))
3856 if (attribute)
3857 error ("invalid element type for attribute %qs",
3858 IDENTIFIER_POINTER (attribute));
3859 return NULL_TREE;
3861 inner_size_int = tree_to_uhwi (TYPE_SIZE_UNIT (inner_type));
3863 if (size_int % inner_size_int)
3865 if (attribute)
3866 error ("vector size not an integral multiple of component size");
3867 return NULL_TREE;
3870 if (size_int == 0)
3872 if (attribute)
3873 error ("zero vector size");
3874 return NULL_TREE;
3877 nunits = size_int / inner_size_int;
3878 if (nunits & (nunits - 1))
3880 if (attribute)
3881 error ("number of components of vector not a power of two");
3882 return NULL_TREE;
3885 return build_vector_type (inner_type, nunits);
3888 /* Return a vector type whose representative array type is ARRAY_TYPE, or
3889 NULL_TREE if this is not possible. If ATTRIBUTE is non-zero, we are
3890 processing the attribute and want to issue error messages on failure. */
3892 static tree
3893 build_vector_type_for_array (tree array_type, tree attribute)
3895 tree vector_type = build_vector_type_for_size (TREE_TYPE (array_type),
3896 TYPE_SIZE_UNIT (array_type),
3897 attribute);
3898 if (!vector_type)
3899 return NULL_TREE;
3901 TYPE_REPRESENTATIVE_ARRAY (vector_type) = array_type;
3902 return vector_type;
3905 /* Build a type to be used to represent an aliased object whose nominal type
3906 is an unconstrained array. This consists of a RECORD_TYPE containing a
3907 field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE.
3908 If ARRAY_TYPE is that of an unconstrained array, this is used to represent
3909 an arbitrary unconstrained object. Use NAME as the name of the record.
3910 DEBUG_INFO_P is true if we need to write debug information for the type. */
3912 tree
3913 build_unc_object_type (tree template_type, tree object_type, tree name,
3914 bool debug_info_p)
3916 tree decl;
3917 tree type = make_node (RECORD_TYPE);
3918 tree template_field
3919 = create_field_decl (get_identifier ("BOUNDS"), template_type, type,
3920 NULL_TREE, NULL_TREE, 0, 1);
3921 tree array_field
3922 = create_field_decl (get_identifier ("ARRAY"), object_type, type,
3923 NULL_TREE, NULL_TREE, 0, 1);
3925 TYPE_NAME (type) = name;
3926 TYPE_CONTAINS_TEMPLATE_P (type) = 1;
3927 DECL_CHAIN (template_field) = array_field;
3928 finish_record_type (type, template_field, 0, true);
3930 /* Declare it now since it will never be declared otherwise. This is
3931 necessary to ensure that its subtrees are properly marked. */
3932 decl = create_type_decl (name, type, true, debug_info_p, Empty);
3934 /* template_type will not be used elsewhere than here, so to keep the debug
3935 info clean and in order to avoid scoping issues, make decl its
3936 context. */
3937 gnat_set_type_context (template_type, decl);
3939 return type;
3942 /* Same, taking a thin or fat pointer type instead of a template type. */
3944 tree
3945 build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
3946 tree name, bool debug_info_p)
3948 tree template_type;
3950 gcc_assert (TYPE_IS_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
3952 template_type
3953 = (TYPE_IS_FAT_POINTER_P (thin_fat_ptr_type)
3954 ? TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (thin_fat_ptr_type))))
3955 : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type))));
3957 return
3958 build_unc_object_type (template_type, object_type, name, debug_info_p);
3961 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.
3962 In the normal case this is just two adjustments, but we have more to
3963 do if NEW_TYPE is an UNCONSTRAINED_ARRAY_TYPE. */
3965 void
3966 update_pointer_to (tree old_type, tree new_type)
3968 tree ptr = TYPE_POINTER_TO (old_type);
3969 tree ref = TYPE_REFERENCE_TO (old_type);
3970 tree t;
3972 /* If this is the main variant, process all the other variants first. */
3973 if (TYPE_MAIN_VARIANT (old_type) == old_type)
3974 for (t = TYPE_NEXT_VARIANT (old_type); t; t = TYPE_NEXT_VARIANT (t))
3975 update_pointer_to (t, new_type);
3977 /* If no pointers and no references, we are done. */
3978 if (!ptr && !ref)
3979 return;
3981 /* Merge the old type qualifiers in the new type.
3983 Each old variant has qualifiers for specific reasons, and the new
3984 designated type as well. Each set of qualifiers represents useful
3985 information grabbed at some point, and merging the two simply unifies
3986 these inputs into the final type description.
3988 Consider for instance a volatile type frozen after an access to constant
3989 type designating it; after the designated type's freeze, we get here with
3990 a volatile NEW_TYPE and a dummy OLD_TYPE with a readonly variant, created
3991 when the access type was processed. We will make a volatile and readonly
3992 designated type, because that's what it really is.
3994 We might also get here for a non-dummy OLD_TYPE variant with different
3995 qualifiers than those of NEW_TYPE, for instance in some cases of pointers
3996 to private record type elaboration (see the comments around the call to
3997 this routine in gnat_to_gnu_entity <E_Access_Type>). We have to merge
3998 the qualifiers in those cases too, to avoid accidentally discarding the
3999 initial set, and will often end up with OLD_TYPE == NEW_TYPE then. */
4000 new_type
4001 = build_qualified_type (new_type,
4002 TYPE_QUALS (old_type) | TYPE_QUALS (new_type));
4004 /* If old type and new type are identical, there is nothing to do. */
4005 if (old_type == new_type)
4006 return;
4008 /* Otherwise, first handle the simple case. */
4009 if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
4011 tree new_ptr, new_ref;
4013 /* If pointer or reference already points to new type, nothing to do.
4014 This can happen as update_pointer_to can be invoked multiple times
4015 on the same couple of types because of the type variants. */
4016 if ((ptr && TREE_TYPE (ptr) == new_type)
4017 || (ref && TREE_TYPE (ref) == new_type))
4018 return;
4020 /* Chain PTR and its variants at the end. */
4021 new_ptr = TYPE_POINTER_TO (new_type);
4022 if (new_ptr)
4024 while (TYPE_NEXT_PTR_TO (new_ptr))
4025 new_ptr = TYPE_NEXT_PTR_TO (new_ptr);
4026 TYPE_NEXT_PTR_TO (new_ptr) = ptr;
4028 else
4029 TYPE_POINTER_TO (new_type) = ptr;
4031 /* Now adjust them. */
4032 for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr))
4033 for (t = TYPE_MAIN_VARIANT (ptr); t; t = TYPE_NEXT_VARIANT (t))
4035 TREE_TYPE (t) = new_type;
4036 if (TYPE_NULL_BOUNDS (t))
4037 TREE_TYPE (TREE_OPERAND (TYPE_NULL_BOUNDS (t), 0)) = new_type;
4040 /* Chain REF and its variants at the end. */
4041 new_ref = TYPE_REFERENCE_TO (new_type);
4042 if (new_ref)
4044 while (TYPE_NEXT_REF_TO (new_ref))
4045 new_ref = TYPE_NEXT_REF_TO (new_ref);
4046 TYPE_NEXT_REF_TO (new_ref) = ref;
4048 else
4049 TYPE_REFERENCE_TO (new_type) = ref;
4051 /* Now adjust them. */
4052 for (; ref; ref = TYPE_NEXT_REF_TO (ref))
4053 for (t = TYPE_MAIN_VARIANT (ref); t; t = TYPE_NEXT_VARIANT (t))
4054 TREE_TYPE (t) = new_type;
4056 TYPE_POINTER_TO (old_type) = NULL_TREE;
4057 TYPE_REFERENCE_TO (old_type) = NULL_TREE;
4060 /* Now deal with the unconstrained array case. In this case the pointer
4061 is actually a record where both fields are pointers to dummy nodes.
4062 Turn them into pointers to the correct types using update_pointer_to.
4063 Likewise for the pointer to the object record (thin pointer). */
4064 else
4066 tree new_ptr = TYPE_POINTER_TO (new_type);
4068 gcc_assert (TYPE_IS_FAT_POINTER_P (ptr));
4070 /* If PTR already points to NEW_TYPE, nothing to do. This can happen
4071 since update_pointer_to can be invoked multiple times on the same
4072 couple of types because of the type variants. */
4073 if (TYPE_UNCONSTRAINED_ARRAY (ptr) == new_type)
4074 return;
4076 update_pointer_to
4077 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
4078 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr))));
4080 update_pointer_to
4081 (TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (ptr)))),
4082 TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (new_ptr)))));
4084 update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type),
4085 TYPE_OBJECT_RECORD_TYPE (new_type));
4087 TYPE_POINTER_TO (old_type) = NULL_TREE;
4088 TYPE_REFERENCE_TO (old_type) = NULL_TREE;
4092 /* Convert EXPR, a pointer to a constrained array, into a pointer to an
4093 unconstrained one. This involves making or finding a template. */
4095 static tree
4096 convert_to_fat_pointer (tree type, tree expr)
4098 tree template_type = TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))));
4099 tree p_array_type = TREE_TYPE (TYPE_FIELDS (type));
4100 tree etype = TREE_TYPE (expr);
4101 tree template_addr;
4102 vec<constructor_elt, va_gc> *v;
4103 vec_alloc (v, 2);
4105 /* If EXPR is null, make a fat pointer that contains a null pointer to the
4106 array (compare_fat_pointers ensures that this is the full discriminant)
4107 and a valid pointer to the bounds. This latter property is necessary
4108 since the compiler can hoist the load of the bounds done through it. */
4109 if (integer_zerop (expr))
4111 tree ptr_template_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)));
4112 tree null_bounds, t;
4114 if (TYPE_NULL_BOUNDS (ptr_template_type))
4115 null_bounds = TYPE_NULL_BOUNDS (ptr_template_type);
4116 else
4118 /* The template type can still be dummy at this point so we build an
4119 empty constructor. The middle-end will fill it in with zeros. */
4120 t = build_constructor (template_type, NULL);
4121 TREE_CONSTANT (t) = TREE_STATIC (t) = 1;
4122 null_bounds = build_unary_op (ADDR_EXPR, NULL_TREE, t);
4123 SET_TYPE_NULL_BOUNDS (ptr_template_type, null_bounds);
4126 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
4127 fold_convert (p_array_type, null_pointer_node));
4128 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), null_bounds);
4129 t = build_constructor (type, v);
4130 /* Do not set TREE_CONSTANT so as to force T to static memory. */
4131 TREE_CONSTANT (t) = 0;
4132 TREE_STATIC (t) = 1;
4134 return t;
4137 /* If EXPR is a thin pointer, make template and data from the record. */
4138 if (TYPE_IS_THIN_POINTER_P (etype))
4140 tree field = TYPE_FIELDS (TREE_TYPE (etype));
4142 expr = gnat_protect_expr (expr);
4144 /* If we have a TYPE_UNCONSTRAINED_ARRAY attached to the RECORD_TYPE,
4145 the thin pointer value has been shifted so we shift it back to get
4146 the template address. */
4147 if (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (etype)))
4149 template_addr
4150 = build_binary_op (POINTER_PLUS_EXPR, etype, expr,
4151 fold_build1 (NEGATE_EXPR, sizetype,
4152 byte_position
4153 (DECL_CHAIN (field))));
4154 template_addr
4155 = fold_convert (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))),
4156 template_addr);
4159 /* Otherwise we explicitly take the address of the fields. */
4160 else
4162 expr = build_unary_op (INDIRECT_REF, NULL_TREE, expr);
4163 template_addr
4164 = build_unary_op (ADDR_EXPR, NULL_TREE,
4165 build_component_ref (expr, field, false));
4166 expr = build_unary_op (ADDR_EXPR, NULL_TREE,
4167 build_component_ref (expr, DECL_CHAIN (field),
4168 false));
4172 /* Otherwise, build the constructor for the template. */
4173 else
4174 template_addr
4175 = build_unary_op (ADDR_EXPR, NULL_TREE,
4176 build_template (template_type, TREE_TYPE (etype),
4177 expr));
4179 /* The final result is a constructor for the fat pointer.
4181 If EXPR is an argument of a foreign convention subprogram, the type it
4182 points to is directly the component type. In this case, the expression
4183 type may not match the corresponding FIELD_DECL type at this point, so we
4184 call "convert" here to fix that up if necessary. This type consistency is
4185 required, for instance because it ensures that possible later folding of
4186 COMPONENT_REFs against this constructor always yields something of the
4187 same type as the initial reference.
4189 Note that the call to "build_template" above is still fine because it
4190 will only refer to the provided TEMPLATE_TYPE in this case. */
4191 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), convert (p_array_type, expr));
4192 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), template_addr);
4193 return gnat_build_constructor (type, v);
4196 /* Create an expression whose value is that of EXPR,
4197 converted to type TYPE. The TREE_TYPE of the value
4198 is always TYPE. This function implements all reasonable
4199 conversions; callers should filter out those that are
4200 not permitted by the language being compiled. */
4202 tree
4203 convert (tree type, tree expr)
4205 tree etype = TREE_TYPE (expr);
4206 enum tree_code ecode = TREE_CODE (etype);
4207 enum tree_code code = TREE_CODE (type);
4209 /* If the expression is already of the right type, we are done. */
4210 if (etype == type)
4211 return expr;
4213 /* If both input and output have padding and are of variable size, do this
4214 as an unchecked conversion. Likewise if one is a mere variant of the
4215 other, so we avoid a pointless unpad/repad sequence. */
4216 else if (code == RECORD_TYPE && ecode == RECORD_TYPE
4217 && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype)
4218 && (!TREE_CONSTANT (TYPE_SIZE (type))
4219 || !TREE_CONSTANT (TYPE_SIZE (etype))
4220 || TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
4221 || TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type)))
4222 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (etype)))))
4225 /* If the output type has padding, convert to the inner type and make a
4226 constructor to build the record, unless a variable size is involved. */
4227 else if (code == RECORD_TYPE && TYPE_PADDING_P (type))
4229 /* If we previously converted from another type and our type is
4230 of variable size, remove the conversion to avoid the need for
4231 variable-sized temporaries. Likewise for a conversion between
4232 original and packable version. */
4233 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
4234 && (!TREE_CONSTANT (TYPE_SIZE (type))
4235 || (ecode == RECORD_TYPE
4236 && TYPE_NAME (etype)
4237 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (expr, 0))))))
4238 expr = TREE_OPERAND (expr, 0);
4240 /* If we are just removing the padding from expr, convert the original
4241 object if we have variable size in order to avoid the need for some
4242 variable-sized temporaries. Likewise if the padding is a variant
4243 of the other, so we avoid a pointless unpad/repad sequence. */
4244 if (TREE_CODE (expr) == COMPONENT_REF
4245 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
4246 && (!TREE_CONSTANT (TYPE_SIZE (type))
4247 || TYPE_MAIN_VARIANT (type)
4248 == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (expr, 0)))
4249 || (ecode == RECORD_TYPE
4250 && TYPE_NAME (etype)
4251 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type))))))
4252 return convert (type, TREE_OPERAND (expr, 0));
4254 /* If the inner type is of self-referential size and the expression type
4255 is a record, do this as an unchecked conversion unless both types are
4256 essentially the same. But first pad the expression if possible to
4257 have the same size on both sides. */
4258 if (ecode == RECORD_TYPE
4259 && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type)))
4260 && TYPE_MAIN_VARIANT (etype)
4261 != TYPE_MAIN_VARIANT (TREE_TYPE (TYPE_FIELDS (type))))
4263 if (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST)
4264 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
4265 false, false, false, true),
4266 expr);
4267 return unchecked_convert (type, expr, false);
4270 /* If we are converting between array types with variable size, do the
4271 final conversion as an unchecked conversion, again to avoid the need
4272 for some variable-sized temporaries. If valid, this conversion is
4273 very likely purely technical and without real effects. */
4274 if (ecode == ARRAY_TYPE
4275 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == ARRAY_TYPE
4276 && !TREE_CONSTANT (TYPE_SIZE (etype))
4277 && !TREE_CONSTANT (TYPE_SIZE (type)))
4278 return unchecked_convert (type,
4279 convert (TREE_TYPE (TYPE_FIELDS (type)),
4280 expr),
4281 false);
4283 tree t = convert (TREE_TYPE (TYPE_FIELDS (type)), expr);
4285 /* If converting to the inner type has already created a CONSTRUCTOR with
4286 the right size, then reuse it instead of creating another one. This
4287 can happen for the padding type built to overalign local variables. */
4288 if (TREE_CODE (t) == VIEW_CONVERT_EXPR
4289 && TREE_CODE (TREE_OPERAND (t, 0)) == CONSTRUCTOR
4290 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (t, 0))))
4291 && tree_int_cst_equal (TYPE_SIZE (type),
4292 TYPE_SIZE (TREE_TYPE (TREE_OPERAND (t, 0)))))
4293 return build1 (VIEW_CONVERT_EXPR, type, TREE_OPERAND (t, 0));
4295 vec<constructor_elt, va_gc> *v;
4296 vec_alloc (v, 1);
4297 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), t);
4298 return gnat_build_constructor (type, v);
4301 /* If the input type has padding, remove it and convert to the output type.
4302 The conditions ordering is arranged to ensure that the output type is not
4303 a padding type here, as it is not clear whether the conversion would
4304 always be correct if this was to happen. */
4305 else if (ecode == RECORD_TYPE && TYPE_PADDING_P (etype))
4307 tree unpadded;
4309 /* If we have just converted to this padded type, just get the
4310 inner expression. */
4311 if (TREE_CODE (expr) == CONSTRUCTOR)
4312 unpadded = CONSTRUCTOR_ELT (expr, 0)->value;
4314 /* Otherwise, build an explicit component reference. */
4315 else
4316 unpadded = build_component_ref (expr, TYPE_FIELDS (etype), false);
4318 return convert (type, unpadded);
4321 /* If the input is a biased type, convert first to the base type and add
4322 the bias. Note that the bias must go through a full conversion to the
4323 base type, lest it is itself a biased value; this happens for subtypes
4324 of biased types. */
4325 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
4326 return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype),
4327 fold_convert (TREE_TYPE (etype), expr),
4328 convert (TREE_TYPE (etype),
4329 TYPE_MIN_VALUE (etype))));
4331 /* If the input is a justified modular type, we need to extract the actual
4332 object before converting it to any other type with the exceptions of an
4333 unconstrained array or of a mere type variant. It is useful to avoid the
4334 extraction and conversion in the type variant case because it could end
4335 up replacing a VAR_DECL expr by a constructor and we might be about the
4336 take the address of the result. */
4337 if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
4338 && code != UNCONSTRAINED_ARRAY_TYPE
4339 && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype))
4340 return
4341 convert (type, build_component_ref (expr, TYPE_FIELDS (etype), false));
4343 /* If converting to a type that contains a template, convert to the data
4344 type and then build the template. */
4345 if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type))
4347 tree obj_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)));
4348 vec<constructor_elt, va_gc> *v;
4349 vec_alloc (v, 2);
4351 /* If the source already has a template, get a reference to the
4352 associated array only, as we are going to rebuild a template
4353 for the target type anyway. */
4354 expr = maybe_unconstrained_array (expr);
4356 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
4357 build_template (TREE_TYPE (TYPE_FIELDS (type)),
4358 obj_type, NULL_TREE));
4359 if (expr)
4360 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
4361 convert (obj_type, expr));
4362 return gnat_build_constructor (type, v);
4365 /* There are some cases of expressions that we process specially. */
4366 switch (TREE_CODE (expr))
4368 case ERROR_MARK:
4369 return expr;
4371 case NULL_EXPR:
4372 /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
4373 conversion in gnat_expand_expr. NULL_EXPR does not represent
4374 and actual value, so no conversion is needed. */
4375 expr = copy_node (expr);
4376 TREE_TYPE (expr) = type;
4377 return expr;
4379 case STRING_CST:
4380 /* If we are converting a STRING_CST to another constrained array type,
4381 just make a new one in the proper type. */
4382 if (code == ecode && AGGREGATE_TYPE_P (etype)
4383 && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
4384 && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
4386 expr = copy_node (expr);
4387 TREE_TYPE (expr) = type;
4388 return expr;
4390 break;
4392 case VECTOR_CST:
4393 /* If we are converting a VECTOR_CST to a mere type variant, just make
4394 a new one in the proper type. */
4395 if (code == ecode && gnat_types_compatible_p (type, etype))
4397 expr = copy_node (expr);
4398 TREE_TYPE (expr) = type;
4399 return expr;
4401 break;
4403 case CONSTRUCTOR:
4404 /* If we are converting a CONSTRUCTOR to a mere type variant, or to
4405 another padding type around the same type, just make a new one in
4406 the proper type. */
4407 if (code == ecode
4408 && (gnat_types_compatible_p (type, etype)
4409 || (code == RECORD_TYPE
4410 && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype)
4411 && TREE_TYPE (TYPE_FIELDS (type))
4412 == TREE_TYPE (TYPE_FIELDS (etype)))))
4414 expr = copy_node (expr);
4415 TREE_TYPE (expr) = type;
4416 CONSTRUCTOR_ELTS (expr) = vec_safe_copy (CONSTRUCTOR_ELTS (expr));
4417 return expr;
4420 /* Likewise for a conversion between original and packable version, or
4421 conversion between types of the same size and with the same list of
4422 fields, but we have to work harder to preserve type consistency. */
4423 if (code == ecode
4424 && code == RECORD_TYPE
4425 && (TYPE_NAME (type) == TYPE_NAME (etype)
4426 || tree_int_cst_equal (TYPE_SIZE (type), TYPE_SIZE (etype))))
4429 vec<constructor_elt, va_gc> *e = CONSTRUCTOR_ELTS (expr);
4430 unsigned HOST_WIDE_INT len = vec_safe_length (e);
4431 vec<constructor_elt, va_gc> *v;
4432 vec_alloc (v, len);
4433 tree efield = TYPE_FIELDS (etype), field = TYPE_FIELDS (type);
4434 unsigned HOST_WIDE_INT idx;
4435 tree index, value;
4437 /* Whether we need to clear TREE_CONSTANT et al. on the output
4438 constructor when we convert in place. */
4439 bool clear_constant = false;
4441 FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value)
4443 /* Skip the missing fields in the CONSTRUCTOR. */
4444 while (efield && field && !SAME_FIELD_P (efield, index))
4446 efield = DECL_CHAIN (efield);
4447 field = DECL_CHAIN (field);
4449 /* The field must be the same. */
4450 if (!(efield && field && SAME_FIELD_P (efield, field)))
4451 break;
4452 constructor_elt elt
4453 = {field, convert (TREE_TYPE (field), value)};
4454 v->quick_push (elt);
4456 /* If packing has made this field a bitfield and the input
4457 value couldn't be emitted statically any more, we need to
4458 clear TREE_CONSTANT on our output. */
4459 if (!clear_constant
4460 && TREE_CONSTANT (expr)
4461 && !CONSTRUCTOR_BITFIELD_P (efield)
4462 && CONSTRUCTOR_BITFIELD_P (field)
4463 && !initializer_constant_valid_for_bitfield_p (value))
4464 clear_constant = true;
4466 efield = DECL_CHAIN (efield);
4467 field = DECL_CHAIN (field);
4470 /* If we have been able to match and convert all the input fields
4471 to their output type, convert in place now. We'll fallback to a
4472 view conversion downstream otherwise. */
4473 if (idx == len)
4475 expr = copy_node (expr);
4476 TREE_TYPE (expr) = type;
4477 CONSTRUCTOR_ELTS (expr) = v;
4478 if (clear_constant)
4479 TREE_CONSTANT (expr) = TREE_STATIC (expr) = 0;
4480 return expr;
4484 /* Likewise for a conversion between array type and vector type with a
4485 compatible representative array. */
4486 else if (code == VECTOR_TYPE
4487 && ecode == ARRAY_TYPE
4488 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
4489 etype))
4491 vec<constructor_elt, va_gc> *e = CONSTRUCTOR_ELTS (expr);
4492 unsigned HOST_WIDE_INT len = vec_safe_length (e);
4493 vec<constructor_elt, va_gc> *v;
4494 unsigned HOST_WIDE_INT ix;
4495 tree value;
4497 /* Build a VECTOR_CST from a *constant* array constructor. */
4498 if (TREE_CONSTANT (expr))
4500 bool constant_p = true;
4502 /* Iterate through elements and check if all constructor
4503 elements are *_CSTs. */
4504 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
4505 if (!CONSTANT_CLASS_P (value))
4507 constant_p = false;
4508 break;
4511 if (constant_p)
4512 return build_vector_from_ctor (type,
4513 CONSTRUCTOR_ELTS (expr));
4516 /* Otherwise, build a regular vector constructor. */
4517 vec_alloc (v, len);
4518 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
4520 constructor_elt elt = {NULL_TREE, value};
4521 v->quick_push (elt);
4523 expr = copy_node (expr);
4524 TREE_TYPE (expr) = type;
4525 CONSTRUCTOR_ELTS (expr) = v;
4526 return expr;
4528 break;
4530 case UNCONSTRAINED_ARRAY_REF:
4531 /* First retrieve the underlying array. */
4532 expr = maybe_unconstrained_array (expr);
4533 etype = TREE_TYPE (expr);
4534 ecode = TREE_CODE (etype);
4535 break;
4537 case VIEW_CONVERT_EXPR:
4539 /* GCC 4.x is very sensitive to type consistency overall, and view
4540 conversions thus are very frequent. Even though just "convert"ing
4541 the inner operand to the output type is fine in most cases, it
4542 might expose unexpected input/output type mismatches in special
4543 circumstances so we avoid such recursive calls when we can. */
4544 tree op0 = TREE_OPERAND (expr, 0);
4546 /* If we are converting back to the original type, we can just
4547 lift the input conversion. This is a common occurrence with
4548 switches back-and-forth amongst type variants. */
4549 if (type == TREE_TYPE (op0))
4550 return op0;
4552 /* Otherwise, if we're converting between two aggregate or vector
4553 types, we might be allowed to substitute the VIEW_CONVERT_EXPR
4554 target type in place or to just convert the inner expression. */
4555 if ((AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
4556 || (VECTOR_TYPE_P (type) && VECTOR_TYPE_P (etype)))
4558 /* If we are converting between mere variants, we can just
4559 substitute the VIEW_CONVERT_EXPR in place. */
4560 if (gnat_types_compatible_p (type, etype))
4561 return build1 (VIEW_CONVERT_EXPR, type, op0);
4563 /* Otherwise, we may just bypass the input view conversion unless
4564 one of the types is a fat pointer, which is handled by
4565 specialized code below which relies on exact type matching. */
4566 else if (!TYPE_IS_FAT_POINTER_P (type)
4567 && !TYPE_IS_FAT_POINTER_P (etype))
4568 return convert (type, op0);
4571 break;
4574 default:
4575 break;
4578 /* Check for converting to a pointer to an unconstrained array. */
4579 if (TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype))
4580 return convert_to_fat_pointer (type, expr);
4582 /* If we are converting between two aggregate or vector types that are mere
4583 variants, just make a VIEW_CONVERT_EXPR. Likewise when we are converting
4584 to a vector type from its representative array type. */
4585 else if ((code == ecode
4586 && (AGGREGATE_TYPE_P (type) || VECTOR_TYPE_P (type))
4587 && gnat_types_compatible_p (type, etype))
4588 || (code == VECTOR_TYPE
4589 && ecode == ARRAY_TYPE
4590 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
4591 etype)))
4592 return build1 (VIEW_CONVERT_EXPR, type, expr);
4594 /* If we are converting between tagged types, try to upcast properly. */
4595 else if (ecode == RECORD_TYPE && code == RECORD_TYPE
4596 && TYPE_ALIGN_OK (etype) && TYPE_ALIGN_OK (type))
4598 tree child_etype = etype;
4599 do {
4600 tree field = TYPE_FIELDS (child_etype);
4601 if (DECL_NAME (field) == parent_name_id && TREE_TYPE (field) == type)
4602 return build_component_ref (expr, field, false);
4603 child_etype = TREE_TYPE (field);
4604 } while (TREE_CODE (child_etype) == RECORD_TYPE);
4607 /* If we are converting from a smaller form of record type back to it, just
4608 make a VIEW_CONVERT_EXPR. But first pad the expression to have the same
4609 size on both sides. */
4610 else if (ecode == RECORD_TYPE && code == RECORD_TYPE
4611 && smaller_form_type_p (etype, type))
4613 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
4614 false, false, false, true),
4615 expr);
4616 return build1 (VIEW_CONVERT_EXPR, type, expr);
4619 /* In all other cases of related types, make a NOP_EXPR. */
4620 else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
4621 return fold_convert (type, expr);
4623 switch (code)
4625 case VOID_TYPE:
4626 return fold_build1 (CONVERT_EXPR, type, expr);
4628 case INTEGER_TYPE:
4629 if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
4630 && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
4631 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
4632 return unchecked_convert (type, expr, false);
4634 /* If the output is a biased type, convert first to the base type and
4635 subtract the bias. Note that the bias itself must go through a full
4636 conversion to the base type, lest it is a biased value; this happens
4637 for subtypes of biased types. */
4638 if (TYPE_BIASED_REPRESENTATION_P (type))
4639 return fold_convert (type,
4640 fold_build2 (MINUS_EXPR, TREE_TYPE (type),
4641 convert (TREE_TYPE (type), expr),
4642 convert (TREE_TYPE (type),
4643 TYPE_MIN_VALUE (type))));
4645 /* ... fall through ... */
4647 case ENUMERAL_TYPE:
4648 case BOOLEAN_TYPE:
4649 /* If we are converting an additive expression to an integer type
4650 with lower precision, be wary of the optimization that can be
4651 applied by convert_to_integer. There are 2 problematic cases:
4652 - if the first operand was originally of a biased type,
4653 because we could be recursively called to convert it
4654 to an intermediate type and thus rematerialize the
4655 additive operator endlessly,
4656 - if the expression contains a placeholder, because an
4657 intermediate conversion that changes the sign could
4658 be inserted and thus introduce an artificial overflow
4659 at compile time when the placeholder is substituted. */
4660 if (code == INTEGER_TYPE
4661 && ecode == INTEGER_TYPE
4662 && TYPE_PRECISION (type) < TYPE_PRECISION (etype)
4663 && (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR))
4665 tree op0 = get_unwidened (TREE_OPERAND (expr, 0), type);
4667 if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE
4668 && TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0)))
4669 || CONTAINS_PLACEHOLDER_P (expr))
4670 return build1 (NOP_EXPR, type, expr);
4673 return fold (convert_to_integer (type, expr));
4675 case POINTER_TYPE:
4676 case REFERENCE_TYPE:
4677 /* If converting between two thin pointers, adjust if needed to account
4678 for differing offsets from the base pointer, depending on whether
4679 there is a TYPE_UNCONSTRAINED_ARRAY attached to the record type. */
4680 if (TYPE_IS_THIN_POINTER_P (etype) && TYPE_IS_THIN_POINTER_P (type))
4682 tree etype_pos
4683 = TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (etype))
4684 ? byte_position (DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (etype))))
4685 : size_zero_node;
4686 tree type_pos
4687 = TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))
4688 ? byte_position (DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (type))))
4689 : size_zero_node;
4690 tree byte_diff = size_diffop (type_pos, etype_pos);
4692 expr = build1 (NOP_EXPR, type, expr);
4693 if (integer_zerop (byte_diff))
4694 return expr;
4696 return build_binary_op (POINTER_PLUS_EXPR, type, expr,
4697 fold_convert (sizetype, byte_diff));
4700 /* If converting fat pointer to normal or thin pointer, get the pointer
4701 to the array and then convert it. */
4702 if (TYPE_IS_FAT_POINTER_P (etype))
4703 expr = build_component_ref (expr, TYPE_FIELDS (etype), false);
4705 return fold (convert_to_pointer (type, expr));
4707 case REAL_TYPE:
4708 return fold (convert_to_real (type, expr));
4710 case RECORD_TYPE:
4711 /* Do a normal conversion between scalar and justified modular type. */
4712 if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype))
4714 vec<constructor_elt, va_gc> *v;
4715 vec_alloc (v, 1);
4717 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
4718 convert (TREE_TYPE (TYPE_FIELDS (type)),
4719 expr));
4720 return gnat_build_constructor (type, v);
4723 /* In these cases, assume the front-end has validated the conversion.
4724 If the conversion is valid, it will be a bit-wise conversion, so
4725 it can be viewed as an unchecked conversion. */
4726 return unchecked_convert (type, expr, false);
4728 case ARRAY_TYPE:
4729 /* Do a normal conversion between unconstrained and constrained array
4730 type, assuming the latter is a constrained version of the former. */
4731 if (TREE_CODE (expr) == INDIRECT_REF
4732 && ecode == ARRAY_TYPE
4733 && TREE_TYPE (etype) == TREE_TYPE (type))
4735 tree ptr_type = build_pointer_type (type);
4736 tree t = build_unary_op (INDIRECT_REF, NULL_TREE,
4737 fold_convert (ptr_type,
4738 TREE_OPERAND (expr, 0)));
4739 TREE_READONLY (t) = TREE_READONLY (expr);
4740 TREE_THIS_NOTRAP (t) = TREE_THIS_NOTRAP (expr);
4741 return t;
4744 /* In these cases, assume the front-end has validated the conversion.
4745 If the conversion is valid, it will be a bit-wise conversion, so
4746 it can be viewed as an unchecked conversion. */
4747 return unchecked_convert (type, expr, false);
4749 case UNION_TYPE:
4750 /* This is a either a conversion between a tagged type and some
4751 subtype, which we have to mark as a UNION_TYPE because of
4752 overlapping fields or a conversion of an Unchecked_Union. */
4753 return unchecked_convert (type, expr, false);
4755 case UNCONSTRAINED_ARRAY_TYPE:
4756 /* If the input is a VECTOR_TYPE, convert to the representative
4757 array type first. */
4758 if (ecode == VECTOR_TYPE)
4760 expr = convert (TYPE_REPRESENTATIVE_ARRAY (etype), expr);
4761 etype = TREE_TYPE (expr);
4762 ecode = TREE_CODE (etype);
4765 /* If EXPR is a constrained array, take its address, convert it to a
4766 fat pointer, and then dereference it. Likewise if EXPR is a
4767 record containing both a template and a constrained array.
4768 Note that a record representing a justified modular type
4769 always represents a packed constrained array. */
4770 if (ecode == ARRAY_TYPE
4771 || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
4772 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
4773 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))
4774 return
4775 build_unary_op
4776 (INDIRECT_REF, NULL_TREE,
4777 convert_to_fat_pointer (TREE_TYPE (type),
4778 build_unary_op (ADDR_EXPR,
4779 NULL_TREE, expr)));
4781 /* Do something very similar for converting one unconstrained
4782 array to another. */
4783 else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
4784 return
4785 build_unary_op (INDIRECT_REF, NULL_TREE,
4786 convert (TREE_TYPE (type),
4787 build_unary_op (ADDR_EXPR,
4788 NULL_TREE, expr)));
4789 else
4790 gcc_unreachable ();
4792 case COMPLEX_TYPE:
4793 return fold (convert_to_complex (type, expr));
4795 default:
4796 gcc_unreachable ();
4800 /* Create an expression whose value is that of EXPR converted to the common
4801 index type, which is sizetype. EXPR is supposed to be in the base type
4802 of the GNAT index type. Calling it is equivalent to doing
4804 convert (sizetype, expr)
4806 but we try to distribute the type conversion with the knowledge that EXPR
4807 cannot overflow in its type. This is a best-effort approach and we fall
4808 back to the above expression as soon as difficulties are encountered.
4810 This is necessary to overcome issues that arise when the GNAT base index
4811 type and the GCC common index type (sizetype) don't have the same size,
4812 which is quite frequent on 64-bit architectures. In this case, and if
4813 the GNAT base index type is signed but the iteration type of the loop has
4814 been forced to unsigned, the loop scalar evolution engine cannot compute
4815 a simple evolution for the general induction variables associated with the
4816 array indices, because it will preserve the wrap-around semantics in the
4817 unsigned type of their "inner" part. As a result, many loop optimizations
4818 are blocked.
4820 The solution is to use a special (basic) induction variable that is at
4821 least as large as sizetype, and to express the aforementioned general
4822 induction variables in terms of this induction variable, eliminating
4823 the problematic intermediate truncation to the GNAT base index type.
4824 This is possible as long as the original expression doesn't overflow
4825 and if the middle-end hasn't introduced artificial overflows in the
4826 course of the various simplification it can make to the expression. */
4828 tree
4829 convert_to_index_type (tree expr)
4831 enum tree_code code = TREE_CODE (expr);
4832 tree type = TREE_TYPE (expr);
4834 /* If the type is unsigned, overflow is allowed so we cannot be sure that
4835 EXPR doesn't overflow. Keep it simple if optimization is disabled. */
4836 if (TYPE_UNSIGNED (type) || !optimize)
4837 return convert (sizetype, expr);
4839 switch (code)
4841 case VAR_DECL:
4842 /* The main effect of the function: replace a loop parameter with its
4843 associated special induction variable. */
4844 if (DECL_LOOP_PARM_P (expr) && DECL_INDUCTION_VAR (expr))
4845 expr = DECL_INDUCTION_VAR (expr);
4846 break;
4848 CASE_CONVERT:
4850 tree otype = TREE_TYPE (TREE_OPERAND (expr, 0));
4851 /* Bail out as soon as we suspect some sort of type frobbing. */
4852 if (TYPE_PRECISION (type) != TYPE_PRECISION (otype)
4853 || TYPE_UNSIGNED (type) != TYPE_UNSIGNED (otype))
4854 break;
4857 /* ... fall through ... */
4859 case NON_LVALUE_EXPR:
4860 return fold_build1 (code, sizetype,
4861 convert_to_index_type (TREE_OPERAND (expr, 0)));
4863 case PLUS_EXPR:
4864 case MINUS_EXPR:
4865 case MULT_EXPR:
4866 return fold_build2 (code, sizetype,
4867 convert_to_index_type (TREE_OPERAND (expr, 0)),
4868 convert_to_index_type (TREE_OPERAND (expr, 1)));
4870 case COMPOUND_EXPR:
4871 return fold_build2 (code, sizetype, TREE_OPERAND (expr, 0),
4872 convert_to_index_type (TREE_OPERAND (expr, 1)));
4874 case COND_EXPR:
4875 return fold_build3 (code, sizetype, TREE_OPERAND (expr, 0),
4876 convert_to_index_type (TREE_OPERAND (expr, 1)),
4877 convert_to_index_type (TREE_OPERAND (expr, 2)));
4879 default:
4880 break;
4883 return convert (sizetype, expr);
4886 /* Remove all conversions that are done in EXP. This includes converting
4887 from a padded type or to a justified modular type. If TRUE_ADDRESS
4888 is true, always return the address of the containing object even if
4889 the address is not bit-aligned. */
4891 tree
4892 remove_conversions (tree exp, bool true_address)
4894 switch (TREE_CODE (exp))
4896 case CONSTRUCTOR:
4897 if (true_address
4898 && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
4899 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
4900 return
4901 remove_conversions (CONSTRUCTOR_ELT (exp, 0)->value, true);
4902 break;
4904 case COMPONENT_REF:
4905 if (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
4906 return remove_conversions (TREE_OPERAND (exp, 0), true_address);
4907 break;
4909 CASE_CONVERT:
4910 case VIEW_CONVERT_EXPR:
4911 case NON_LVALUE_EXPR:
4912 return remove_conversions (TREE_OPERAND (exp, 0), true_address);
4914 default:
4915 break;
4918 return exp;
4921 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
4922 refers to the underlying array. If it has TYPE_CONTAINS_TEMPLATE_P,
4923 likewise return an expression pointing to the underlying array. */
4925 tree
4926 maybe_unconstrained_array (tree exp)
4928 enum tree_code code = TREE_CODE (exp);
4929 tree type = TREE_TYPE (exp);
4931 switch (TREE_CODE (type))
4933 case UNCONSTRAINED_ARRAY_TYPE:
4934 if (code == UNCONSTRAINED_ARRAY_REF)
4936 const bool read_only = TREE_READONLY (exp);
4937 const bool no_trap = TREE_THIS_NOTRAP (exp);
4939 exp = TREE_OPERAND (exp, 0);
4940 type = TREE_TYPE (exp);
4942 if (TREE_CODE (exp) == COND_EXPR)
4944 tree op1
4945 = build_unary_op (INDIRECT_REF, NULL_TREE,
4946 build_component_ref (TREE_OPERAND (exp, 1),
4947 TYPE_FIELDS (type),
4948 false));
4949 tree op2
4950 = build_unary_op (INDIRECT_REF, NULL_TREE,
4951 build_component_ref (TREE_OPERAND (exp, 2),
4952 TYPE_FIELDS (type),
4953 false));
4955 exp = build3 (COND_EXPR,
4956 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (type))),
4957 TREE_OPERAND (exp, 0), op1, op2);
4959 else
4961 exp = build_unary_op (INDIRECT_REF, NULL_TREE,
4962 build_component_ref (exp,
4963 TYPE_FIELDS (type),
4964 false));
4965 TREE_READONLY (exp) = read_only;
4966 TREE_THIS_NOTRAP (exp) = no_trap;
4970 else if (code == NULL_EXPR)
4971 exp = build1 (NULL_EXPR,
4972 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))),
4973 TREE_OPERAND (exp, 0));
4974 break;
4976 case RECORD_TYPE:
4977 /* If this is a padded type and it contains a template, convert to the
4978 unpadded type first. */
4979 if (TYPE_PADDING_P (type)
4980 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
4981 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
4983 exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
4984 code = TREE_CODE (exp);
4985 type = TREE_TYPE (exp);
4988 if (TYPE_CONTAINS_TEMPLATE_P (type))
4990 /* If the array initializer is a box, return NULL_TREE. */
4991 if (code == CONSTRUCTOR && CONSTRUCTOR_NELTS (exp) < 2)
4992 return NULL_TREE;
4994 exp = build_component_ref (exp, DECL_CHAIN (TYPE_FIELDS (type)),
4995 false);
4996 type = TREE_TYPE (exp);
4998 /* If the array type is padded, convert to the unpadded type. */
4999 if (TYPE_IS_PADDING_P (type))
5000 exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
5002 break;
5004 default:
5005 break;
5008 return exp;
5011 /* Return true if EXPR is an expression that can be folded as an operand
5012 of a VIEW_CONVERT_EXPR. See ada-tree.h for a complete rationale. */
5014 static bool
5015 can_fold_for_view_convert_p (tree expr)
5017 tree t1, t2;
5019 /* The folder will fold NOP_EXPRs between integral types with the same
5020 precision (in the middle-end's sense). We cannot allow it if the
5021 types don't have the same precision in the Ada sense as well. */
5022 if (TREE_CODE (expr) != NOP_EXPR)
5023 return true;
5025 t1 = TREE_TYPE (expr);
5026 t2 = TREE_TYPE (TREE_OPERAND (expr, 0));
5028 /* Defer to the folder for non-integral conversions. */
5029 if (!(INTEGRAL_TYPE_P (t1) && INTEGRAL_TYPE_P (t2)))
5030 return true;
5032 /* Only fold conversions that preserve both precisions. */
5033 if (TYPE_PRECISION (t1) == TYPE_PRECISION (t2)
5034 && operand_equal_p (rm_size (t1), rm_size (t2), 0))
5035 return true;
5037 return false;
5040 /* Return an expression that does an unchecked conversion of EXPR to TYPE.
5041 If NOTRUNC_P is true, truncation operations should be suppressed.
5043 Special care is required with (source or target) integral types whose
5044 precision is not equal to their size, to make sure we fetch or assign
5045 the value bits whose location might depend on the endianness, e.g.
5047 Rmsize : constant := 8;
5048 subtype Int is Integer range 0 .. 2 ** Rmsize - 1;
5050 type Bit_Array is array (1 .. Rmsize) of Boolean;
5051 pragma Pack (Bit_Array);
5053 function To_Bit_Array is new Unchecked_Conversion (Int, Bit_Array);
5055 Value : Int := 2#1000_0001#;
5056 Vbits : Bit_Array := To_Bit_Array (Value);
5058 we expect the 8 bits at Vbits'Address to always contain Value, while
5059 their original location depends on the endianness, at Value'Address
5060 on a little-endian architecture but not on a big-endian one.
5062 One pitfall is that we cannot use TYPE_UNSIGNED directly to decide how
5063 the bits between the precision and the size are filled, because of the
5064 trick used in the E_Signed_Integer_Subtype case of gnat_to_gnu_entity.
5065 So we use the special predicate type_unsigned_for_rm above. */
5067 tree
5068 unchecked_convert (tree type, tree expr, bool notrunc_p)
5070 tree etype = TREE_TYPE (expr);
5071 enum tree_code ecode = TREE_CODE (etype);
5072 enum tree_code code = TREE_CODE (type);
5073 tree tem;
5074 int c;
5076 /* If the expression is already of the right type, we are done. */
5077 if (etype == type)
5078 return expr;
5080 /* If both types are integral just do a normal conversion.
5081 Likewise for a conversion to an unconstrained array. */
5082 if (((INTEGRAL_TYPE_P (type)
5083 || (POINTER_TYPE_P (type) && !TYPE_IS_THIN_POINTER_P (type))
5084 || (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type)))
5085 && (INTEGRAL_TYPE_P (etype)
5086 || (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype))
5087 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))))
5088 || code == UNCONSTRAINED_ARRAY_TYPE)
5090 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
5092 tree ntype = copy_type (etype);
5093 TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
5094 TYPE_MAIN_VARIANT (ntype) = ntype;
5095 expr = build1 (NOP_EXPR, ntype, expr);
5098 if (code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
5100 tree rtype = copy_type (type);
5101 TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
5102 TYPE_MAIN_VARIANT (rtype) = rtype;
5103 expr = convert (rtype, expr);
5104 expr = build1 (NOP_EXPR, type, expr);
5106 else
5107 expr = convert (type, expr);
5110 /* If we are converting to an integral type whose precision is not equal
5111 to its size, first unchecked convert to a record type that contains a
5112 field of the given precision. Then extract the result from the field.
5114 There is a subtlety if the source type is an aggregate type with reverse
5115 storage order because its representation is not contiguous in the native
5116 storage order, i.e. a direct unchecked conversion to an integral type
5117 with N bits of precision cannot read the first N bits of the aggregate
5118 type. To overcome it, we do an unchecked conversion to an integral type
5119 with reverse storage order and return the resulting value. This also
5120 ensures that the result of the unchecked conversion doesn't depend on
5121 the endianness of the target machine, but only on the storage order of
5122 the aggregate type.
5124 Finally, for the sake of consistency, we do the unchecked conversion
5125 to an integral type with reverse storage order as soon as the source
5126 type is an aggregate type with reverse storage order, even if there
5127 are no considerations of precision or size involved. */
5128 else if (INTEGRAL_TYPE_P (type)
5129 && TYPE_RM_SIZE (type)
5130 && (tree_int_cst_compare (TYPE_RM_SIZE (type),
5131 TYPE_SIZE (type)) < 0
5132 || (AGGREGATE_TYPE_P (etype)
5133 && TYPE_REVERSE_STORAGE_ORDER (etype))))
5135 tree rec_type = make_node (RECORD_TYPE);
5136 unsigned HOST_WIDE_INT prec = TREE_INT_CST_LOW (TYPE_RM_SIZE (type));
5137 tree field_type, field;
5139 if (AGGREGATE_TYPE_P (etype))
5140 TYPE_REVERSE_STORAGE_ORDER (rec_type)
5141 = TYPE_REVERSE_STORAGE_ORDER (etype);
5143 if (type_unsigned_for_rm (type))
5144 field_type = make_unsigned_type (prec);
5145 else
5146 field_type = make_signed_type (prec);
5147 SET_TYPE_RM_SIZE (field_type, TYPE_RM_SIZE (type));
5149 field = create_field_decl (get_identifier ("OBJ"), field_type, rec_type,
5150 NULL_TREE, bitsize_zero_node, 1, 0);
5152 finish_record_type (rec_type, field, 1, false);
5154 expr = unchecked_convert (rec_type, expr, notrunc_p);
5155 expr = build_component_ref (expr, field, false);
5156 expr = fold_build1 (NOP_EXPR, type, expr);
5159 /* Similarly if we are converting from an integral type whose precision is
5160 not equal to its size, first copy into a field of the given precision
5161 and unchecked convert the record type.
5163 The same considerations as above apply if the target type is an aggregate
5164 type with reverse storage order and we also proceed similarly. */
5165 else if (INTEGRAL_TYPE_P (etype)
5166 && TYPE_RM_SIZE (etype)
5167 && (tree_int_cst_compare (TYPE_RM_SIZE (etype),
5168 TYPE_SIZE (etype)) < 0
5169 || (AGGREGATE_TYPE_P (type)
5170 && TYPE_REVERSE_STORAGE_ORDER (type))))
5172 tree rec_type = make_node (RECORD_TYPE);
5173 unsigned HOST_WIDE_INT prec = TREE_INT_CST_LOW (TYPE_RM_SIZE (etype));
5174 vec<constructor_elt, va_gc> *v;
5175 vec_alloc (v, 1);
5176 tree field_type, field;
5178 if (AGGREGATE_TYPE_P (type))
5179 TYPE_REVERSE_STORAGE_ORDER (rec_type)
5180 = TYPE_REVERSE_STORAGE_ORDER (type);
5182 if (type_unsigned_for_rm (etype))
5183 field_type = make_unsigned_type (prec);
5184 else
5185 field_type = make_signed_type (prec);
5186 SET_TYPE_RM_SIZE (field_type, TYPE_RM_SIZE (etype));
5188 field = create_field_decl (get_identifier ("OBJ"), field_type, rec_type,
5189 NULL_TREE, bitsize_zero_node, 1, 0);
5191 finish_record_type (rec_type, field, 1, false);
5193 expr = fold_build1 (NOP_EXPR, field_type, expr);
5194 CONSTRUCTOR_APPEND_ELT (v, field, expr);
5195 expr = gnat_build_constructor (rec_type, v);
5196 expr = unchecked_convert (type, expr, notrunc_p);
5199 /* If we are converting from a scalar type to a type with a different size,
5200 we need to pad to have the same size on both sides.
5202 ??? We cannot do it unconditionally because unchecked conversions are
5203 used liberally by the front-end to implement polymorphism, e.g. in:
5205 S191s : constant ada__tags__addr_ptr := ada__tags__addr_ptr!(S190s);
5206 return p___size__4 (p__object!(S191s.all));
5208 so we skip all expressions that are references. */
5209 else if (!REFERENCE_CLASS_P (expr)
5210 && !AGGREGATE_TYPE_P (etype)
5211 && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST
5212 && (c = tree_int_cst_compare (TYPE_SIZE (etype), TYPE_SIZE (type))))
5214 if (c < 0)
5216 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
5217 false, false, false, true),
5218 expr);
5219 expr = unchecked_convert (type, expr, notrunc_p);
5221 else
5223 tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty,
5224 false, false, false, true);
5225 expr = unchecked_convert (rec_type, expr, notrunc_p);
5226 expr = build_component_ref (expr, TYPE_FIELDS (rec_type), false);
5230 /* We have a special case when we are converting between two unconstrained
5231 array types. In that case, take the address, convert the fat pointer
5232 types, and dereference. */
5233 else if (ecode == code && code == UNCONSTRAINED_ARRAY_TYPE)
5234 expr = build_unary_op (INDIRECT_REF, NULL_TREE,
5235 build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type),
5236 build_unary_op (ADDR_EXPR, NULL_TREE,
5237 expr)));
5239 /* Another special case is when we are converting to a vector type from its
5240 representative array type; this a regular conversion. */
5241 else if (code == VECTOR_TYPE
5242 && ecode == ARRAY_TYPE
5243 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
5244 etype))
5245 expr = convert (type, expr);
5247 /* And, if the array type is not the representative, we try to build an
5248 intermediate vector type of which the array type is the representative
5249 and to do the unchecked conversion between the vector types, in order
5250 to enable further simplifications in the middle-end. */
5251 else if (code == VECTOR_TYPE
5252 && ecode == ARRAY_TYPE
5253 && (tem = build_vector_type_for_array (etype, NULL_TREE)))
5255 expr = convert (tem, expr);
5256 return unchecked_convert (type, expr, notrunc_p);
5259 /* If we are converting a CONSTRUCTOR to a more aligned RECORD_TYPE, bump
5260 the alignment of the CONSTRUCTOR to speed up the copy operation. */
5261 else if (TREE_CODE (expr) == CONSTRUCTOR
5262 && code == RECORD_TYPE
5263 && TYPE_ALIGN (etype) < TYPE_ALIGN (type))
5265 expr = convert (maybe_pad_type (etype, NULL_TREE, TYPE_ALIGN (type),
5266 Empty, false, false, false, true),
5267 expr);
5268 return unchecked_convert (type, expr, notrunc_p);
5271 /* Otherwise, just build a VIEW_CONVERT_EXPR of the expression. */
5272 else
5274 expr = maybe_unconstrained_array (expr);
5275 etype = TREE_TYPE (expr);
5276 ecode = TREE_CODE (etype);
5277 if (can_fold_for_view_convert_p (expr))
5278 expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr);
5279 else
5280 expr = build1 (VIEW_CONVERT_EXPR, type, expr);
5283 /* If the result is a non-biased integral type whose precision is not equal
5284 to its size, sign- or zero-extend the result. But we need not do this
5285 if the input is also an integral type and both are unsigned or both are
5286 signed and have the same precision. */
5287 if (!notrunc_p
5288 && INTEGRAL_TYPE_P (type)
5289 && !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
5290 && TYPE_RM_SIZE (type)
5291 && tree_int_cst_compare (TYPE_RM_SIZE (type), TYPE_SIZE (type)) < 0
5292 && !(INTEGRAL_TYPE_P (etype)
5293 && type_unsigned_for_rm (type) == type_unsigned_for_rm (etype)
5294 && (type_unsigned_for_rm (type)
5295 || tree_int_cst_compare (TYPE_RM_SIZE (type),
5296 TYPE_RM_SIZE (etype)
5297 ? TYPE_RM_SIZE (etype)
5298 : TYPE_SIZE (etype)) == 0)))
5300 if (integer_zerop (TYPE_RM_SIZE (type)))
5301 expr = build_int_cst (type, 0);
5302 else
5304 tree base_type
5305 = gnat_type_for_size (TREE_INT_CST_LOW (TYPE_SIZE (type)),
5306 type_unsigned_for_rm (type));
5307 tree shift_expr
5308 = convert (base_type,
5309 size_binop (MINUS_EXPR,
5310 TYPE_SIZE (type), TYPE_RM_SIZE (type)));
5311 expr
5312 = convert (type,
5313 build_binary_op (RSHIFT_EXPR, base_type,
5314 build_binary_op (LSHIFT_EXPR, base_type,
5315 convert (base_type,
5316 expr),
5317 shift_expr),
5318 shift_expr));
5322 /* An unchecked conversion should never raise Constraint_Error. The code
5323 below assumes that GCC's conversion routines overflow the same way that
5324 the underlying hardware does. This is probably true. In the rare case
5325 when it is false, we can rely on the fact that such conversions are
5326 erroneous anyway. */
5327 if (TREE_CODE (expr) == INTEGER_CST)
5328 TREE_OVERFLOW (expr) = 0;
5330 /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
5331 show no longer constant. */
5332 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
5333 && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype),
5334 OEP_ONLY_CONST))
5335 TREE_CONSTANT (expr) = 0;
5337 return expr;
5340 /* Return the appropriate GCC tree code for the specified GNAT_TYPE,
5341 the latter being a record type as predicated by Is_Record_Type. */
5343 enum tree_code
5344 tree_code_for_record_type (Entity_Id gnat_type)
5346 Node_Id component_list, component;
5348 /* Return UNION_TYPE if it's an Unchecked_Union whose non-discriminant
5349 fields are all in the variant part. Otherwise, return RECORD_TYPE. */
5350 if (!Is_Unchecked_Union (gnat_type))
5351 return RECORD_TYPE;
5353 gnat_type = Implementation_Base_Type (gnat_type);
5354 component_list
5355 = Component_List (Type_Definition (Declaration_Node (gnat_type)));
5357 for (component = First_Non_Pragma (Component_Items (component_list));
5358 Present (component);
5359 component = Next_Non_Pragma (component))
5360 if (Ekind (Defining_Entity (component)) == E_Component)
5361 return RECORD_TYPE;
5363 return UNION_TYPE;
5366 /* Return true if GNAT_TYPE is a "double" floating-point type, i.e. whose
5367 size is equal to 64 bits, or an array of such a type. Set ALIGN_CLAUSE
5368 according to the presence of an alignment clause on the type or, if it
5369 is an array, on the component type. */
5371 bool
5372 is_double_float_or_array (Entity_Id gnat_type, bool *align_clause)
5374 gnat_type = Underlying_Type (gnat_type);
5376 *align_clause = Present (Alignment_Clause (gnat_type));
5378 if (Is_Array_Type (gnat_type))
5380 gnat_type = Underlying_Type (Component_Type (gnat_type));
5381 if (Present (Alignment_Clause (gnat_type)))
5382 *align_clause = true;
5385 if (!Is_Floating_Point_Type (gnat_type))
5386 return false;
5388 if (UI_To_Int (Esize (gnat_type)) != 64)
5389 return false;
5391 return true;
5394 /* Return true if GNAT_TYPE is a "double" or larger scalar type, i.e. whose
5395 size is greater or equal to 64 bits, or an array of such a type. Set
5396 ALIGN_CLAUSE according to the presence of an alignment clause on the
5397 type or, if it is an array, on the component type. */
5399 bool
5400 is_double_scalar_or_array (Entity_Id gnat_type, bool *align_clause)
5402 gnat_type = Underlying_Type (gnat_type);
5404 *align_clause = Present (Alignment_Clause (gnat_type));
5406 if (Is_Array_Type (gnat_type))
5408 gnat_type = Underlying_Type (Component_Type (gnat_type));
5409 if (Present (Alignment_Clause (gnat_type)))
5410 *align_clause = true;
5413 if (!Is_Scalar_Type (gnat_type))
5414 return false;
5416 if (UI_To_Int (Esize (gnat_type)) < 64)
5417 return false;
5419 return true;
5422 /* Return true if GNU_TYPE is suitable as the type of a non-aliased
5423 component of an aggregate type. */
5425 bool
5426 type_for_nonaliased_component_p (tree gnu_type)
5428 /* If the type is passed by reference, we may have pointers to the
5429 component so it cannot be made non-aliased. */
5430 if (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type))
5431 return false;
5433 /* We used to say that any component of aggregate type is aliased
5434 because the front-end may take 'Reference of it. The front-end
5435 has been enhanced in the meantime so as to use a renaming instead
5436 in most cases, but the back-end can probably take the address of
5437 such a component too so we go for the conservative stance.
5439 For instance, we might need the address of any array type, even
5440 if normally passed by copy, to construct a fat pointer if the
5441 component is used as an actual for an unconstrained formal.
5443 Likewise for record types: even if a specific record subtype is
5444 passed by copy, the parent type might be passed by ref (e.g. if
5445 it's of variable size) and we might take the address of a child
5446 component to pass to a parent formal. We have no way to check
5447 for such conditions here. */
5448 if (AGGREGATE_TYPE_P (gnu_type))
5449 return false;
5451 return true;
5454 /* Return true if TYPE is a smaller form of ORIG_TYPE. */
5456 bool
5457 smaller_form_type_p (tree type, tree orig_type)
5459 tree size, osize;
5461 /* We're not interested in variants here. */
5462 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (orig_type))
5463 return false;
5465 /* Like a variant, a packable version keeps the original TYPE_NAME. */
5466 if (TYPE_NAME (type) != TYPE_NAME (orig_type))
5467 return false;
5469 size = TYPE_SIZE (type);
5470 osize = TYPE_SIZE (orig_type);
5472 if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (osize) == INTEGER_CST))
5473 return false;
5475 return tree_int_cst_lt (size, osize) != 0;
5478 /* Return whether EXPR, which is the renamed object in an object renaming
5479 declaration, can be materialized as a reference (with a REFERENCE_TYPE).
5480 This should be synchronized with Exp_Dbug.Debug_Renaming_Declaration. */
5482 bool
5483 can_materialize_object_renaming_p (Node_Id expr)
5485 while (true)
5487 expr = Original_Node (expr);
5489 switch Nkind (expr)
5491 case N_Identifier:
5492 case N_Expanded_Name:
5493 if (!Present (Renamed_Object (Entity (expr))))
5494 return true;
5495 expr = Renamed_Object (Entity (expr));
5496 break;
5498 case N_Selected_Component:
5500 if (Is_Packed (Underlying_Type (Etype (Prefix (expr)))))
5501 return false;
5503 const Uint bitpos
5504 = Normalized_First_Bit (Entity (Selector_Name (expr)));
5505 if (!UI_Is_In_Int_Range (bitpos)
5506 || (bitpos != UI_No_Uint && bitpos != UI_From_Int (0)))
5507 return false;
5509 expr = Prefix (expr);
5510 break;
5513 case N_Indexed_Component:
5514 case N_Slice:
5516 const Entity_Id t = Underlying_Type (Etype (Prefix (expr)));
5518 if (Is_Array_Type (t) && Present (Packed_Array_Impl_Type (t)))
5519 return false;
5521 expr = Prefix (expr);
5522 break;
5525 case N_Explicit_Dereference:
5526 expr = Prefix (expr);
5527 break;
5529 default:
5530 return true;
5535 /* Perform final processing on global declarations. */
5537 static GTY (()) tree dummy_global;
5539 void
5540 gnat_write_global_declarations (void)
5542 unsigned int i;
5543 tree iter;
5545 /* If we have declared types as used at the global level, insert them in
5546 the global hash table. We use a dummy variable for this purpose, but
5547 we need to build it unconditionally to avoid -fcompare-debug issues. */
5548 if (first_global_object_name)
5550 struct varpool_node *node;
5551 char *label;
5553 ASM_FORMAT_PRIVATE_NAME (label, first_global_object_name, 0);
5554 dummy_global
5555 = build_decl (BUILTINS_LOCATION, VAR_DECL, get_identifier (label),
5556 void_type_node);
5557 DECL_HARD_REGISTER (dummy_global) = 1;
5558 TREE_STATIC (dummy_global) = 1;
5559 node = varpool_node::get_create (dummy_global);
5560 node->definition = 1;
5561 node->force_output = 1;
5563 if (types_used_by_cur_var_decl)
5564 while (!types_used_by_cur_var_decl->is_empty ())
5566 tree t = types_used_by_cur_var_decl->pop ();
5567 types_used_by_var_decl_insert (t, dummy_global);
5571 /* Output debug information for all global type declarations first. This
5572 ensures that global types whose compilation hasn't been finalized yet,
5573 for example pointers to Taft amendment types, have their compilation
5574 finalized in the right context. */
5575 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
5576 if (TREE_CODE (iter) == TYPE_DECL && !DECL_IGNORED_P (iter))
5577 debug_hooks->type_decl (iter, false);
5579 /* Output imported functions. */
5580 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
5581 if (TREE_CODE (iter) == FUNCTION_DECL
5582 && DECL_EXTERNAL (iter)
5583 && DECL_INITIAL (iter) == NULL
5584 && !DECL_IGNORED_P (iter)
5585 && DECL_FUNCTION_IS_DEF (iter))
5586 debug_hooks->early_global_decl (iter);
5588 /* Then output the global variables. We need to do that after the debug
5589 information for global types is emitted so that they are finalized. Skip
5590 external global variables, unless we need to emit debug info for them:
5591 this is useful for imported variables, for instance. */
5592 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
5593 if (TREE_CODE (iter) == VAR_DECL
5594 && (!DECL_EXTERNAL (iter) || !DECL_IGNORED_P (iter)))
5595 rest_of_decl_compilation (iter, true, 0);
5597 /* Output the imported modules/declarations. In GNAT, these are only
5598 materializing subprogram. */
5599 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
5600 if (TREE_CODE (iter) == IMPORTED_DECL && !DECL_IGNORED_P (iter))
5601 debug_hooks->imported_module_or_decl (iter, DECL_NAME (iter),
5602 DECL_CONTEXT (iter), false, false);
5605 /* ************************************************************************
5606 * * GCC builtins support *
5607 * ************************************************************************ */
5609 /* The general scheme is fairly simple:
5611 For each builtin function/type to be declared, gnat_install_builtins calls
5612 internal facilities which eventually get to gnat_pushdecl, which in turn
5613 tracks the so declared builtin function decls in the 'builtin_decls' global
5614 datastructure. When an Intrinsic subprogram declaration is processed, we
5615 search this global datastructure to retrieve the associated BUILT_IN DECL
5616 node. */
5618 /* Search the chain of currently available builtin declarations for a node
5619 corresponding to function NAME (an IDENTIFIER_NODE). Return the first node
5620 found, if any, or NULL_TREE otherwise. */
5621 tree
5622 builtin_decl_for (tree name)
5624 unsigned i;
5625 tree decl;
5627 FOR_EACH_VEC_SAFE_ELT (builtin_decls, i, decl)
5628 if (DECL_NAME (decl) == name)
5629 return decl;
5631 return NULL_TREE;
5634 /* The code below eventually exposes gnat_install_builtins, which declares
5635 the builtin types and functions we might need, either internally or as
5636 user accessible facilities.
5638 ??? This is a first implementation shot, still in rough shape. It is
5639 heavily inspired from the "C" family implementation, with chunks copied
5640 verbatim from there.
5642 Two obvious improvement candidates are:
5643 o Use a more efficient name/decl mapping scheme
5644 o Devise a middle-end infrastructure to avoid having to copy
5645 pieces between front-ends. */
5647 /* ----------------------------------------------------------------------- *
5648 * BUILTIN ELEMENTARY TYPES *
5649 * ----------------------------------------------------------------------- */
5651 /* Standard data types to be used in builtin argument declarations. */
5653 enum c_tree_index
5655 CTI_SIGNED_SIZE_TYPE, /* For format checking only. */
5656 CTI_STRING_TYPE,
5657 CTI_CONST_STRING_TYPE,
5659 CTI_MAX
5662 static tree c_global_trees[CTI_MAX];
5664 #define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE]
5665 #define string_type_node c_global_trees[CTI_STRING_TYPE]
5666 #define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE]
5668 /* ??? In addition some attribute handlers, we currently don't support a
5669 (small) number of builtin-types, which in turns inhibits support for a
5670 number of builtin functions. */
5671 #define wint_type_node void_type_node
5672 #define intmax_type_node void_type_node
5673 #define uintmax_type_node void_type_node
5675 /* Used to help initialize the builtin-types.def table. When a type of
5676 the correct size doesn't exist, use error_mark_node instead of NULL.
5677 The later results in segfaults even when a decl using the type doesn't
5678 get invoked. */
5680 static tree
5681 builtin_type_for_size (int size, bool unsignedp)
5683 tree type = gnat_type_for_size (size, unsignedp);
5684 return type ? type : error_mark_node;
5687 /* Build/push the elementary type decls that builtin functions/types
5688 will need. */
5690 static void
5691 install_builtin_elementary_types (void)
5693 signed_size_type_node = gnat_signed_type_for (size_type_node);
5694 pid_type_node = integer_type_node;
5696 string_type_node = build_pointer_type (char_type_node);
5697 const_string_type_node
5698 = build_pointer_type (build_qualified_type
5699 (char_type_node, TYPE_QUAL_CONST));
5702 /* ----------------------------------------------------------------------- *
5703 * BUILTIN FUNCTION TYPES *
5704 * ----------------------------------------------------------------------- */
5706 /* Now, builtin function types per se. */
5708 enum c_builtin_type
5710 #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
5711 #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
5712 #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
5713 #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
5714 #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
5715 #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
5716 #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
5717 #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5718 ARG6) NAME,
5719 #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5720 ARG6, ARG7) NAME,
5721 #define DEF_FUNCTION_TYPE_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5722 ARG6, ARG7, ARG8) NAME,
5723 #define DEF_FUNCTION_TYPE_9(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5724 ARG6, ARG7, ARG8, ARG9) NAME,
5725 #define DEF_FUNCTION_TYPE_10(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5726 ARG6, ARG7, ARG8, ARG9, ARG10) NAME,
5727 #define DEF_FUNCTION_TYPE_11(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5728 ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) NAME,
5729 #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
5730 #define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME,
5731 #define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME,
5732 #define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
5733 #define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
5734 #define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5735 NAME,
5736 #define DEF_FUNCTION_TYPE_VAR_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5737 ARG6) NAME,
5738 #define DEF_FUNCTION_TYPE_VAR_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5739 ARG6, ARG7) NAME,
5740 #define DEF_POINTER_TYPE(NAME, TYPE) NAME,
5741 #include "builtin-types.def"
5742 #undef DEF_PRIMITIVE_TYPE
5743 #undef DEF_FUNCTION_TYPE_0
5744 #undef DEF_FUNCTION_TYPE_1
5745 #undef DEF_FUNCTION_TYPE_2
5746 #undef DEF_FUNCTION_TYPE_3
5747 #undef DEF_FUNCTION_TYPE_4
5748 #undef DEF_FUNCTION_TYPE_5
5749 #undef DEF_FUNCTION_TYPE_6
5750 #undef DEF_FUNCTION_TYPE_7
5751 #undef DEF_FUNCTION_TYPE_8
5752 #undef DEF_FUNCTION_TYPE_9
5753 #undef DEF_FUNCTION_TYPE_10
5754 #undef DEF_FUNCTION_TYPE_11
5755 #undef DEF_FUNCTION_TYPE_VAR_0
5756 #undef DEF_FUNCTION_TYPE_VAR_1
5757 #undef DEF_FUNCTION_TYPE_VAR_2
5758 #undef DEF_FUNCTION_TYPE_VAR_3
5759 #undef DEF_FUNCTION_TYPE_VAR_4
5760 #undef DEF_FUNCTION_TYPE_VAR_5
5761 #undef DEF_FUNCTION_TYPE_VAR_6
5762 #undef DEF_FUNCTION_TYPE_VAR_7
5763 #undef DEF_POINTER_TYPE
5764 BT_LAST
5767 typedef enum c_builtin_type builtin_type;
5769 /* A temporary array used in communication with def_fn_type. */
5770 static GTY(()) tree builtin_types[(int) BT_LAST + 1];
5772 /* A helper function for install_builtin_types. Build function type
5773 for DEF with return type RET and N arguments. If VAR is true, then the
5774 function should be variadic after those N arguments.
5776 Takes special care not to ICE if any of the types involved are
5777 error_mark_node, which indicates that said type is not in fact available
5778 (see builtin_type_for_size). In which case the function type as a whole
5779 should be error_mark_node. */
5781 static void
5782 def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...)
5784 tree t;
5785 tree *args = XALLOCAVEC (tree, n);
5786 va_list list;
5787 int i;
5789 va_start (list, n);
5790 for (i = 0; i < n; ++i)
5792 builtin_type a = (builtin_type) va_arg (list, int);
5793 t = builtin_types[a];
5794 if (t == error_mark_node)
5795 goto egress;
5796 args[i] = t;
5799 t = builtin_types[ret];
5800 if (t == error_mark_node)
5801 goto egress;
5802 if (var)
5803 t = build_varargs_function_type_array (t, n, args);
5804 else
5805 t = build_function_type_array (t, n, args);
5807 egress:
5808 builtin_types[def] = t;
5809 va_end (list);
5812 /* Build the builtin function types and install them in the builtin_types
5813 array for later use in builtin function decls. */
5815 static void
5816 install_builtin_function_types (void)
5818 tree va_list_ref_type_node;
5819 tree va_list_arg_type_node;
5821 if (TREE_CODE (va_list_type_node) == ARRAY_TYPE)
5823 va_list_arg_type_node = va_list_ref_type_node =
5824 build_pointer_type (TREE_TYPE (va_list_type_node));
5826 else
5828 va_list_arg_type_node = va_list_type_node;
5829 va_list_ref_type_node = build_reference_type (va_list_type_node);
5832 #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
5833 builtin_types[ENUM] = VALUE;
5834 #define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \
5835 def_fn_type (ENUM, RETURN, 0, 0);
5836 #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \
5837 def_fn_type (ENUM, RETURN, 0, 1, ARG1);
5838 #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \
5839 def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2);
5840 #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
5841 def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3);
5842 #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
5843 def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4);
5844 #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5845 def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
5846 #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5847 ARG6) \
5848 def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6);
5849 #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5850 ARG6, ARG7) \
5851 def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7);
5852 #define DEF_FUNCTION_TYPE_8(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5853 ARG6, ARG7, ARG8) \
5854 def_fn_type (ENUM, RETURN, 0, 8, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \
5855 ARG7, ARG8);
5856 #define DEF_FUNCTION_TYPE_9(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5857 ARG6, ARG7, ARG8, ARG9) \
5858 def_fn_type (ENUM, RETURN, 0, 9, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \
5859 ARG7, ARG8, ARG9);
5860 #define DEF_FUNCTION_TYPE_10(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5,\
5861 ARG6, ARG7, ARG8, ARG9, ARG10) \
5862 def_fn_type (ENUM, RETURN, 0, 10, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \
5863 ARG7, ARG8, ARG9, ARG10);
5864 #define DEF_FUNCTION_TYPE_11(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5,\
5865 ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) \
5866 def_fn_type (ENUM, RETURN, 0, 11, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \
5867 ARG7, ARG8, ARG9, ARG10, ARG11);
5868 #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \
5869 def_fn_type (ENUM, RETURN, 1, 0);
5870 #define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \
5871 def_fn_type (ENUM, RETURN, 1, 1, ARG1);
5872 #define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \
5873 def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2);
5874 #define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
5875 def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3);
5876 #define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
5877 def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4);
5878 #define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5879 def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
5880 #define DEF_FUNCTION_TYPE_VAR_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5881 ARG6) \
5882 def_fn_type (ENUM, RETURN, 1, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6);
5883 #define DEF_FUNCTION_TYPE_VAR_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5884 ARG6, ARG7) \
5885 def_fn_type (ENUM, RETURN, 1, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7);
5886 #define DEF_POINTER_TYPE(ENUM, TYPE) \
5887 builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]);
5889 #include "builtin-types.def"
5891 #undef DEF_PRIMITIVE_TYPE
5892 #undef DEF_FUNCTION_TYPE_0
5893 #undef DEF_FUNCTION_TYPE_1
5894 #undef DEF_FUNCTION_TYPE_2
5895 #undef DEF_FUNCTION_TYPE_3
5896 #undef DEF_FUNCTION_TYPE_4
5897 #undef DEF_FUNCTION_TYPE_5
5898 #undef DEF_FUNCTION_TYPE_6
5899 #undef DEF_FUNCTION_TYPE_7
5900 #undef DEF_FUNCTION_TYPE_8
5901 #undef DEF_FUNCTION_TYPE_9
5902 #undef DEF_FUNCTION_TYPE_10
5903 #undef DEF_FUNCTION_TYPE_11
5904 #undef DEF_FUNCTION_TYPE_VAR_0
5905 #undef DEF_FUNCTION_TYPE_VAR_1
5906 #undef DEF_FUNCTION_TYPE_VAR_2
5907 #undef DEF_FUNCTION_TYPE_VAR_3
5908 #undef DEF_FUNCTION_TYPE_VAR_4
5909 #undef DEF_FUNCTION_TYPE_VAR_5
5910 #undef DEF_FUNCTION_TYPE_VAR_6
5911 #undef DEF_FUNCTION_TYPE_VAR_7
5912 #undef DEF_POINTER_TYPE
5913 builtin_types[(int) BT_LAST] = NULL_TREE;
5916 /* ----------------------------------------------------------------------- *
5917 * BUILTIN ATTRIBUTES *
5918 * ----------------------------------------------------------------------- */
5920 enum built_in_attribute
5922 #define DEF_ATTR_NULL_TREE(ENUM) ENUM,
5923 #define DEF_ATTR_INT(ENUM, VALUE) ENUM,
5924 #define DEF_ATTR_STRING(ENUM, VALUE) ENUM,
5925 #define DEF_ATTR_IDENT(ENUM, STRING) ENUM,
5926 #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM,
5927 #include "builtin-attrs.def"
5928 #undef DEF_ATTR_NULL_TREE
5929 #undef DEF_ATTR_INT
5930 #undef DEF_ATTR_STRING
5931 #undef DEF_ATTR_IDENT
5932 #undef DEF_ATTR_TREE_LIST
5933 ATTR_LAST
5936 static GTY(()) tree built_in_attributes[(int) ATTR_LAST];
5938 static void
5939 install_builtin_attributes (void)
5941 /* Fill in the built_in_attributes array. */
5942 #define DEF_ATTR_NULL_TREE(ENUM) \
5943 built_in_attributes[(int) ENUM] = NULL_TREE;
5944 #define DEF_ATTR_INT(ENUM, VALUE) \
5945 built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE);
5946 #define DEF_ATTR_STRING(ENUM, VALUE) \
5947 built_in_attributes[(int) ENUM] = build_string (strlen (VALUE), VALUE);
5948 #define DEF_ATTR_IDENT(ENUM, STRING) \
5949 built_in_attributes[(int) ENUM] = get_identifier (STRING);
5950 #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \
5951 built_in_attributes[(int) ENUM] \
5952 = tree_cons (built_in_attributes[(int) PURPOSE], \
5953 built_in_attributes[(int) VALUE], \
5954 built_in_attributes[(int) CHAIN]);
5955 #include "builtin-attrs.def"
5956 #undef DEF_ATTR_NULL_TREE
5957 #undef DEF_ATTR_INT
5958 #undef DEF_ATTR_STRING
5959 #undef DEF_ATTR_IDENT
5960 #undef DEF_ATTR_TREE_LIST
5963 /* Handle a "const" attribute; arguments as in
5964 struct attribute_spec.handler. */
5966 static tree
5967 handle_const_attribute (tree *node, tree ARG_UNUSED (name),
5968 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5969 bool *no_add_attrs)
5971 if (TREE_CODE (*node) == FUNCTION_DECL)
5972 TREE_READONLY (*node) = 1;
5973 else
5974 *no_add_attrs = true;
5976 return NULL_TREE;
5979 /* Handle a "nothrow" attribute; arguments as in
5980 struct attribute_spec.handler. */
5982 static tree
5983 handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name),
5984 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5985 bool *no_add_attrs)
5987 if (TREE_CODE (*node) == FUNCTION_DECL)
5988 TREE_NOTHROW (*node) = 1;
5989 else
5990 *no_add_attrs = true;
5992 return NULL_TREE;
5995 /* Handle a "pure" attribute; arguments as in
5996 struct attribute_spec.handler. */
5998 static tree
5999 handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6000 int ARG_UNUSED (flags), bool *no_add_attrs)
6002 if (TREE_CODE (*node) == FUNCTION_DECL)
6003 DECL_PURE_P (*node) = 1;
6004 /* TODO: support types. */
6005 else
6007 warning (OPT_Wattributes, "%qs attribute ignored",
6008 IDENTIFIER_POINTER (name));
6009 *no_add_attrs = true;
6012 return NULL_TREE;
6015 /* Handle a "no vops" attribute; arguments as in
6016 struct attribute_spec.handler. */
6018 static tree
6019 handle_novops_attribute (tree *node, tree ARG_UNUSED (name),
6020 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
6021 bool *ARG_UNUSED (no_add_attrs))
6023 gcc_assert (TREE_CODE (*node) == FUNCTION_DECL);
6024 DECL_IS_NOVOPS (*node) = 1;
6025 return NULL_TREE;
6028 /* Helper for nonnull attribute handling; fetch the operand number
6029 from the attribute argument list. */
6031 static bool
6032 get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp)
6034 /* Verify the arg number is a constant. */
6035 if (!tree_fits_uhwi_p (arg_num_expr))
6036 return false;
6038 *valp = TREE_INT_CST_LOW (arg_num_expr);
6039 return true;
6042 /* Handle the "nonnull" attribute. */
6043 static tree
6044 handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name),
6045 tree args, int ARG_UNUSED (flags),
6046 bool *no_add_attrs)
6048 tree type = *node;
6049 unsigned HOST_WIDE_INT attr_arg_num;
6051 /* If no arguments are specified, all pointer arguments should be
6052 non-null. Verify a full prototype is given so that the arguments
6053 will have the correct types when we actually check them later.
6054 Avoid diagnosing type-generic built-ins since those have no
6055 prototype. */
6056 if (!args)
6058 if (!prototype_p (type)
6059 && (!TYPE_ATTRIBUTES (type)
6060 || !lookup_attribute ("type generic", TYPE_ATTRIBUTES (type))))
6062 error ("nonnull attribute without arguments on a non-prototype");
6063 *no_add_attrs = true;
6065 return NULL_TREE;
6068 /* Argument list specified. Verify that each argument number references
6069 a pointer argument. */
6070 for (attr_arg_num = 1; args; args = TREE_CHAIN (args))
6072 unsigned HOST_WIDE_INT arg_num = 0, ck_num;
6074 if (!get_nonnull_operand (TREE_VALUE (args), &arg_num))
6076 error ("nonnull argument has invalid operand number (argument %lu)",
6077 (unsigned long) attr_arg_num);
6078 *no_add_attrs = true;
6079 return NULL_TREE;
6082 if (prototype_p (type))
6084 function_args_iterator iter;
6085 tree argument;
6087 function_args_iter_init (&iter, type);
6088 for (ck_num = 1; ; ck_num++, function_args_iter_next (&iter))
6090 argument = function_args_iter_cond (&iter);
6091 if (!argument || ck_num == arg_num)
6092 break;
6095 if (!argument
6096 || TREE_CODE (argument) == VOID_TYPE)
6098 error ("nonnull argument with out-of-range operand number "
6099 "(argument %lu, operand %lu)",
6100 (unsigned long) attr_arg_num, (unsigned long) arg_num);
6101 *no_add_attrs = true;
6102 return NULL_TREE;
6105 if (TREE_CODE (argument) != POINTER_TYPE)
6107 error ("nonnull argument references non-pointer operand "
6108 "(argument %lu, operand %lu)",
6109 (unsigned long) attr_arg_num, (unsigned long) arg_num);
6110 *no_add_attrs = true;
6111 return NULL_TREE;
6116 return NULL_TREE;
6119 /* Handle a "sentinel" attribute. */
6121 static tree
6122 handle_sentinel_attribute (tree *node, tree name, tree args,
6123 int ARG_UNUSED (flags), bool *no_add_attrs)
6125 if (!prototype_p (*node))
6127 warning (OPT_Wattributes,
6128 "%qs attribute requires prototypes with named arguments",
6129 IDENTIFIER_POINTER (name));
6130 *no_add_attrs = true;
6132 else
6134 if (!stdarg_p (*node))
6136 warning (OPT_Wattributes,
6137 "%qs attribute only applies to variadic functions",
6138 IDENTIFIER_POINTER (name));
6139 *no_add_attrs = true;
6143 if (args)
6145 tree position = TREE_VALUE (args);
6147 if (TREE_CODE (position) != INTEGER_CST)
6149 warning (0, "requested position is not an integer constant");
6150 *no_add_attrs = true;
6152 else
6154 if (tree_int_cst_lt (position, integer_zero_node))
6156 warning (0, "requested position is less than zero");
6157 *no_add_attrs = true;
6162 return NULL_TREE;
6165 /* Handle a "noreturn" attribute; arguments as in
6166 struct attribute_spec.handler. */
6168 static tree
6169 handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6170 int ARG_UNUSED (flags), bool *no_add_attrs)
6172 tree type = TREE_TYPE (*node);
6174 /* See FIXME comment in c_common_attribute_table. */
6175 if (TREE_CODE (*node) == FUNCTION_DECL)
6176 TREE_THIS_VOLATILE (*node) = 1;
6177 else if (TREE_CODE (type) == POINTER_TYPE
6178 && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
6179 TREE_TYPE (*node)
6180 = build_pointer_type
6181 (build_type_variant (TREE_TYPE (type),
6182 TYPE_READONLY (TREE_TYPE (type)), 1));
6183 else
6185 warning (OPT_Wattributes, "%qs attribute ignored",
6186 IDENTIFIER_POINTER (name));
6187 *no_add_attrs = true;
6190 return NULL_TREE;
6193 /* Handle a "noinline" attribute; arguments as in
6194 struct attribute_spec.handler. */
6196 static tree
6197 handle_noinline_attribute (tree *node, tree name,
6198 tree ARG_UNUSED (args),
6199 int ARG_UNUSED (flags), bool *no_add_attrs)
6201 if (TREE_CODE (*node) == FUNCTION_DECL)
6203 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (*node)))
6205 warning (OPT_Wattributes, "%qE attribute ignored due to conflict "
6206 "with attribute %qs", name, "always_inline");
6207 *no_add_attrs = true;
6209 else
6210 DECL_UNINLINABLE (*node) = 1;
6212 else
6214 warning (OPT_Wattributes, "%qE attribute ignored", name);
6215 *no_add_attrs = true;
6218 return NULL_TREE;
6221 /* Handle a "noclone" attribute; arguments as in
6222 struct attribute_spec.handler. */
6224 static tree
6225 handle_noclone_attribute (tree *node, tree name,
6226 tree ARG_UNUSED (args),
6227 int ARG_UNUSED (flags), bool *no_add_attrs)
6229 if (TREE_CODE (*node) != FUNCTION_DECL)
6231 warning (OPT_Wattributes, "%qE attribute ignored", name);
6232 *no_add_attrs = true;
6235 return NULL_TREE;
6238 /* Handle a "leaf" attribute; arguments as in
6239 struct attribute_spec.handler. */
6241 static tree
6242 handle_leaf_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6243 int ARG_UNUSED (flags), bool *no_add_attrs)
6245 if (TREE_CODE (*node) != FUNCTION_DECL)
6247 warning (OPT_Wattributes, "%qE attribute ignored", name);
6248 *no_add_attrs = true;
6250 if (!TREE_PUBLIC (*node))
6252 warning (OPT_Wattributes, "%qE attribute has no effect", name);
6253 *no_add_attrs = true;
6256 return NULL_TREE;
6259 /* Handle a "always_inline" attribute; arguments as in
6260 struct attribute_spec.handler. */
6262 static tree
6263 handle_always_inline_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6264 int ARG_UNUSED (flags), bool *no_add_attrs)
6266 if (TREE_CODE (*node) == FUNCTION_DECL)
6268 /* Set the attribute and mark it for disregarding inline limits. */
6269 DECL_DISREGARD_INLINE_LIMITS (*node) = 1;
6271 else
6273 warning (OPT_Wattributes, "%qE attribute ignored", name);
6274 *no_add_attrs = true;
6277 return NULL_TREE;
6280 /* Handle a "malloc" attribute; arguments as in
6281 struct attribute_spec.handler. */
6283 static tree
6284 handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6285 int ARG_UNUSED (flags), bool *no_add_attrs)
6287 if (TREE_CODE (*node) == FUNCTION_DECL
6288 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node))))
6289 DECL_IS_MALLOC (*node) = 1;
6290 else
6292 warning (OPT_Wattributes, "%qs attribute ignored",
6293 IDENTIFIER_POINTER (name));
6294 *no_add_attrs = true;
6297 return NULL_TREE;
6300 /* Fake handler for attributes we don't properly support. */
6302 tree
6303 fake_attribute_handler (tree * ARG_UNUSED (node),
6304 tree ARG_UNUSED (name),
6305 tree ARG_UNUSED (args),
6306 int ARG_UNUSED (flags),
6307 bool * ARG_UNUSED (no_add_attrs))
6309 return NULL_TREE;
6312 /* Handle a "type_generic" attribute. */
6314 static tree
6315 handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name),
6316 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
6317 bool * ARG_UNUSED (no_add_attrs))
6319 /* Ensure we have a function type. */
6320 gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE);
6322 /* Ensure we have a variadic function. */
6323 gcc_assert (!prototype_p (*node) || stdarg_p (*node));
6325 return NULL_TREE;
6328 /* Handle a "vector_size" attribute; arguments as in
6329 struct attribute_spec.handler. */
6331 static tree
6332 handle_vector_size_attribute (tree *node, tree name, tree args,
6333 int ARG_UNUSED (flags), bool *no_add_attrs)
6335 tree type = *node;
6336 tree vector_type;
6338 *no_add_attrs = true;
6340 /* We need to provide for vector pointers, vector arrays, and
6341 functions returning vectors. For example:
6343 __attribute__((vector_size(16))) short *foo;
6345 In this case, the mode is SI, but the type being modified is
6346 HI, so we need to look further. */
6347 while (POINTER_TYPE_P (type)
6348 || TREE_CODE (type) == FUNCTION_TYPE
6349 || TREE_CODE (type) == ARRAY_TYPE)
6350 type = TREE_TYPE (type);
6352 vector_type = build_vector_type_for_size (type, TREE_VALUE (args), name);
6353 if (!vector_type)
6354 return NULL_TREE;
6356 /* Build back pointers if needed. */
6357 *node = reconstruct_complex_type (*node, vector_type);
6359 return NULL_TREE;
6362 /* Handle a "vector_type" attribute; arguments as in
6363 struct attribute_spec.handler. */
6365 static tree
6366 handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6367 int ARG_UNUSED (flags), bool *no_add_attrs)
6369 tree type = *node;
6370 tree vector_type;
6372 *no_add_attrs = true;
6374 if (TREE_CODE (type) != ARRAY_TYPE)
6376 error ("attribute %qs applies to array types only",
6377 IDENTIFIER_POINTER (name));
6378 return NULL_TREE;
6381 vector_type = build_vector_type_for_array (type, name);
6382 if (!vector_type)
6383 return NULL_TREE;
6385 TYPE_REPRESENTATIVE_ARRAY (vector_type) = type;
6386 *node = vector_type;
6388 return NULL_TREE;
6391 /* ----------------------------------------------------------------------- *
6392 * BUILTIN FUNCTIONS *
6393 * ----------------------------------------------------------------------- */
6395 /* Worker for DEF_BUILTIN. Possibly define a builtin function with one or two
6396 names. Does not declare a non-__builtin_ function if flag_no_builtin, or
6397 if nonansi_p and flag_no_nonansi_builtin. */
6399 static void
6400 def_builtin_1 (enum built_in_function fncode,
6401 const char *name,
6402 enum built_in_class fnclass,
6403 tree fntype, tree libtype,
6404 bool both_p, bool fallback_p,
6405 bool nonansi_p ATTRIBUTE_UNUSED,
6406 tree fnattrs, bool implicit_p)
6408 tree decl;
6409 const char *libname;
6411 /* Preserve an already installed decl. It most likely was setup in advance
6412 (e.g. as part of the internal builtins) for specific reasons. */
6413 if (builtin_decl_explicit (fncode))
6414 return;
6416 gcc_assert ((!both_p && !fallback_p)
6417 || !strncmp (name, "__builtin_",
6418 strlen ("__builtin_")));
6420 libname = name + strlen ("__builtin_");
6421 decl = add_builtin_function (name, fntype, fncode, fnclass,
6422 (fallback_p ? libname : NULL),
6423 fnattrs);
6424 if (both_p)
6425 /* ??? This is normally further controlled by command-line options
6426 like -fno-builtin, but we don't have them for Ada. */
6427 add_builtin_function (libname, libtype, fncode, fnclass,
6428 NULL, fnattrs);
6430 set_builtin_decl (fncode, decl, implicit_p);
6433 static int flag_isoc94 = 0;
6434 static int flag_isoc99 = 0;
6435 static int flag_isoc11 = 0;
6437 /* Install what the common builtins.def offers. */
6439 static void
6440 install_builtin_functions (void)
6442 #define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \
6443 NONANSI_P, ATTRS, IMPLICIT, COND) \
6444 if (NAME && COND) \
6445 def_builtin_1 (ENUM, NAME, CLASS, \
6446 builtin_types[(int) TYPE], \
6447 builtin_types[(int) LIBTYPE], \
6448 BOTH_P, FALLBACK_P, NONANSI_P, \
6449 built_in_attributes[(int) ATTRS], IMPLICIT);
6450 #include "builtins.def"
6453 /* ----------------------------------------------------------------------- *
6454 * BUILTIN FUNCTIONS *
6455 * ----------------------------------------------------------------------- */
6457 /* Install the builtin functions we might need. */
6459 void
6460 gnat_install_builtins (void)
6462 install_builtin_elementary_types ();
6463 install_builtin_function_types ();
6464 install_builtin_attributes ();
6466 /* Install builtins used by generic middle-end pieces first. Some of these
6467 know about internal specificities and control attributes accordingly, for
6468 instance __builtin_alloca vs no-throw and -fstack-check. We will ignore
6469 the generic definition from builtins.def. */
6470 build_common_builtin_nodes ();
6472 /* Now, install the target specific builtins, such as the AltiVec family on
6473 ppc, and the common set as exposed by builtins.def. */
6474 targetm.init_builtins ();
6475 install_builtin_functions ();
6478 #include "gt-ada-utils.h"
6479 #include "gtype-ada.h"