* gcc-interface/misc.c (gnat_tree_size): Move around.
[official-gcc.git] / gcc / ada / gcc-interface / utils.c
blob99453821e419eac433298f940a2b46ed94d309b6
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 },
114 { "nothrow", 0, 0, true, false, false, handle_nothrow_attribute,
115 false },
116 { "pure", 0, 0, true, false, false, handle_pure_attribute,
117 false },
118 { "no vops", 0, 0, true, false, false, handle_novops_attribute,
119 false },
120 { "nonnull", 0, -1, false, true, true, handle_nonnull_attribute,
121 false },
122 { "sentinel", 0, 1, false, true, true, handle_sentinel_attribute,
123 false },
124 { "noreturn", 0, 0, true, false, false, handle_noreturn_attribute,
125 false },
126 { "noinline", 0, 0, true, false, false, handle_noinline_attribute,
127 false },
128 { "noclone", 0, 0, true, false, false, handle_noclone_attribute,
129 false },
130 { "leaf", 0, 0, true, false, false, handle_leaf_attribute,
131 false },
132 { "always_inline",0, 0, true, false, false, handle_always_inline_attribute,
133 false },
134 { "malloc", 0, 0, true, false, false, handle_malloc_attribute,
135 false },
136 { "type generic", 0, 0, false, true, true, handle_type_generic_attribute,
137 false },
139 { "vector_size", 1, 1, false, true, false, handle_vector_size_attribute,
140 false },
141 { "vector_type", 0, 0, false, true, false, handle_vector_type_attribute,
142 false },
143 { "may_alias", 0, 0, false, true, false, NULL, false },
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 { "format_arg", 1, 1, false, true, true, fake_attribute_handler, false },
151 { NULL, 0, 0, false, false, false, NULL, false }
154 /* Associates a GNAT tree node to a GCC tree node. It is used in
155 `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
156 of `save_gnu_tree' for more info. */
157 static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
159 #define GET_GNU_TREE(GNAT_ENTITY) \
160 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id]
162 #define SET_GNU_TREE(GNAT_ENTITY,VAL) \
163 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL)
165 #define PRESENT_GNU_TREE(GNAT_ENTITY) \
166 (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
168 /* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */
169 static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table;
171 #define GET_DUMMY_NODE(GNAT_ENTITY) \
172 dummy_node_table[(GNAT_ENTITY) - First_Node_Id]
174 #define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \
175 dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL)
177 #define PRESENT_DUMMY_NODE(GNAT_ENTITY) \
178 (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
180 /* This variable keeps a table for types for each precision so that we only
181 allocate each of them once. Signed and unsigned types are kept separate.
183 Note that these types are only used when fold-const requests something
184 special. Perhaps we should NOT share these types; we'll see how it
185 goes later. */
186 static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
188 /* Likewise for float types, but record these by mode. */
189 static GTY(()) tree float_types[NUM_MACHINE_MODES];
191 /* For each binding contour we allocate a binding_level structure to indicate
192 the binding depth. */
194 struct GTY((chain_next ("%h.chain"))) gnat_binding_level {
195 /* The binding level containing this one (the enclosing binding level). */
196 struct gnat_binding_level *chain;
197 /* The BLOCK node for this level. */
198 tree block;
199 /* If nonzero, the setjmp buffer that needs to be updated for any
200 variable-sized definition within this context. */
201 tree jmpbuf_decl;
204 /* The binding level currently in effect. */
205 static GTY(()) struct gnat_binding_level *current_binding_level;
207 /* A chain of gnat_binding_level structures awaiting reuse. */
208 static GTY((deletable)) struct gnat_binding_level *free_binding_level;
210 /* The context to be used for global declarations. */
211 static GTY(()) tree global_context;
213 /* An array of global declarations. */
214 static GTY(()) vec<tree, va_gc> *global_decls;
216 /* An array of builtin function declarations. */
217 static GTY(()) vec<tree, va_gc> *builtin_decls;
219 /* A chain of unused BLOCK nodes. */
220 static GTY((deletable)) tree free_block_chain;
222 /* A hash table of padded types. It is modelled on the generic type
223 hash table in tree.c, which must thus be used as a reference. */
225 struct GTY((for_user)) pad_type_hash {
226 unsigned long hash;
227 tree type;
230 struct pad_type_hasher : ggc_cache_ptr_hash<pad_type_hash>
232 static inline hashval_t hash (pad_type_hash *t) { return t->hash; }
233 static bool equal (pad_type_hash *a, pad_type_hash *b);
235 static int
236 keep_cache_entry (pad_type_hash *&t)
238 return ggc_marked_p (t->type);
242 static GTY ((cache)) hash_table<pad_type_hasher> *pad_type_hash_table;
244 static tree merge_sizes (tree, tree, tree, bool, bool);
245 static tree fold_bit_position (const_tree);
246 static tree compute_related_constant (tree, tree);
247 static tree split_plus (tree, tree *);
248 static tree float_type_for_precision (int, machine_mode);
249 static tree convert_to_fat_pointer (tree, tree);
250 static unsigned int scale_by_factor_of (tree, unsigned int);
251 static bool potential_alignment_gap (tree, tree, tree);
253 /* Linked list used as a queue to defer the initialization of the DECL_CONTEXT
254 of ..._DECL nodes and of the TYPE_CONTEXT of ..._TYPE nodes. */
255 struct deferred_decl_context_node
257 /* The ..._DECL node to work on. */
258 tree decl;
260 /* The corresponding entity's Scope. */
261 Entity_Id gnat_scope;
263 /* The value of force_global when DECL was pushed. */
264 int force_global;
266 /* The list of ..._TYPE nodes to propagate the context to. */
267 vec<tree> types;
269 /* The next queue item. */
270 struct deferred_decl_context_node *next;
273 static struct deferred_decl_context_node *deferred_decl_context_queue = NULL;
275 /* Defer the initialization of DECL's DECL_CONTEXT attribute, scheduling to
276 feed it with the elaboration of GNAT_SCOPE. */
277 static struct deferred_decl_context_node *
278 add_deferred_decl_context (tree decl, Entity_Id gnat_scope, int force_global);
280 /* Defer the initialization of TYPE's TYPE_CONTEXT attribute, scheduling to
281 feed it with the DECL_CONTEXT computed as part of N as soon as it is
282 computed. */
283 static void add_deferred_type_context (struct deferred_decl_context_node *n,
284 tree type);
286 /* Initialize data structures of the utils.c module. */
288 void
289 init_gnat_utils (void)
291 /* Initialize the association of GNAT nodes to GCC trees. */
292 associate_gnat_to_gnu = ggc_cleared_vec_alloc<tree> (max_gnat_nodes);
294 /* Initialize the association of GNAT nodes to GCC trees as dummies. */
295 dummy_node_table = ggc_cleared_vec_alloc<tree> (max_gnat_nodes);
297 /* Initialize the hash table of padded types. */
298 pad_type_hash_table = hash_table<pad_type_hasher>::create_ggc (512);
301 /* Destroy data structures of the utils.c module. */
303 void
304 destroy_gnat_utils (void)
306 /* Destroy the association of GNAT nodes to GCC trees. */
307 ggc_free (associate_gnat_to_gnu);
308 associate_gnat_to_gnu = NULL;
310 /* Destroy the association of GNAT nodes to GCC trees as dummies. */
311 ggc_free (dummy_node_table);
312 dummy_node_table = NULL;
314 /* Destroy the hash table of padded types. */
315 pad_type_hash_table->empty ();
316 pad_type_hash_table = NULL;
319 /* GNAT_ENTITY is a GNAT tree node for an entity. Associate GNU_DECL, a GCC
320 tree node, with GNAT_ENTITY. If GNU_DECL is not a ..._DECL node, abort.
321 If NO_CHECK is true, the latter check is suppressed.
323 If GNU_DECL is zero, reset a previous association. */
325 void
326 save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check)
328 /* Check that GNAT_ENTITY is not already defined and that it is being set
329 to something which is a decl. If that is not the case, this usually
330 means GNAT_ENTITY is defined twice, but occasionally is due to some
331 Gigi problem. */
332 gcc_assert (!(gnu_decl
333 && (PRESENT_GNU_TREE (gnat_entity)
334 || (!no_check && !DECL_P (gnu_decl)))));
336 SET_GNU_TREE (gnat_entity, gnu_decl);
339 /* GNAT_ENTITY is a GNAT tree node for an entity. Return the GCC tree node
340 that was associated with it. If there is no such tree node, abort.
342 In some cases, such as delayed elaboration or expressions that need to
343 be elaborated only once, GNAT_ENTITY is really not an entity. */
345 tree
346 get_gnu_tree (Entity_Id gnat_entity)
348 gcc_assert (PRESENT_GNU_TREE (gnat_entity));
349 return GET_GNU_TREE (gnat_entity);
352 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
354 bool
355 present_gnu_tree (Entity_Id gnat_entity)
357 return PRESENT_GNU_TREE (gnat_entity);
360 /* Make a dummy type corresponding to GNAT_TYPE. */
362 tree
363 make_dummy_type (Entity_Id gnat_type)
365 Entity_Id gnat_equiv = Gigi_Equivalent_Type (Underlying_Type (gnat_type));
366 tree gnu_type, debug_type;
368 /* If there was no equivalent type (can only happen when just annotating
369 types) or underlying type, go back to the original type. */
370 if (No (gnat_equiv))
371 gnat_equiv = gnat_type;
373 /* If it there already a dummy type, use that one. Else make one. */
374 if (PRESENT_DUMMY_NODE (gnat_equiv))
375 return GET_DUMMY_NODE (gnat_equiv);
377 /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make
378 an ENUMERAL_TYPE. */
379 gnu_type = make_node (Is_Record_Type (gnat_equiv)
380 ? tree_code_for_record_type (gnat_equiv)
381 : ENUMERAL_TYPE);
382 TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
383 TYPE_DUMMY_P (gnu_type) = 1;
384 TYPE_STUB_DECL (gnu_type)
385 = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
386 if (Is_By_Reference_Type (gnat_equiv))
387 TYPE_BY_REFERENCE_P (gnu_type) = 1;
389 SET_DUMMY_NODE (gnat_equiv, gnu_type);
391 /* Create a debug type so that debug info consumers only see an unspecified
392 type. */
393 if (Needs_Debug_Info (gnat_type))
395 debug_type = make_node (LANG_TYPE);
396 SET_TYPE_DEBUG_TYPE (gnu_type, debug_type);
398 TYPE_NAME (debug_type) = TYPE_NAME (gnu_type);
399 TYPE_ARTIFICIAL (debug_type) = TYPE_ARTIFICIAL (gnu_type);
402 return gnu_type;
405 /* Return the dummy type that was made for GNAT_TYPE, if any. */
407 tree
408 get_dummy_type (Entity_Id gnat_type)
410 return GET_DUMMY_NODE (gnat_type);
413 /* Build dummy fat and thin pointer types whose designated type is specified
414 by GNAT_DESIG_TYPE/GNU_DESIG_TYPE and attach them to the latter. */
416 void
417 build_dummy_unc_pointer_types (Entity_Id gnat_desig_type, tree gnu_desig_type)
419 tree gnu_template_type, gnu_ptr_template, gnu_array_type, gnu_ptr_array;
420 tree gnu_fat_type, fields, gnu_object_type;
422 gnu_template_type = make_node (RECORD_TYPE);
423 TYPE_NAME (gnu_template_type) = create_concat_name (gnat_desig_type, "XUB");
424 TYPE_DUMMY_P (gnu_template_type) = 1;
425 gnu_ptr_template = build_pointer_type (gnu_template_type);
427 gnu_array_type = make_node (ENUMERAL_TYPE);
428 TYPE_NAME (gnu_array_type) = create_concat_name (gnat_desig_type, "XUA");
429 TYPE_DUMMY_P (gnu_array_type) = 1;
430 gnu_ptr_array = build_pointer_type (gnu_array_type);
432 gnu_fat_type = make_node (RECORD_TYPE);
433 /* Build a stub DECL to trigger the special processing for fat pointer types
434 in gnat_pushdecl. */
435 TYPE_NAME (gnu_fat_type)
436 = create_type_stub_decl (create_concat_name (gnat_desig_type, "XUP"),
437 gnu_fat_type);
438 fields = create_field_decl (get_identifier ("P_ARRAY"), gnu_ptr_array,
439 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
440 DECL_CHAIN (fields)
441 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
442 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
443 finish_fat_pointer_type (gnu_fat_type, fields);
444 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_desig_type);
445 /* Suppress debug info until after the type is completed. */
446 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 1;
448 gnu_object_type = make_node (RECORD_TYPE);
449 TYPE_NAME (gnu_object_type) = create_concat_name (gnat_desig_type, "XUT");
450 TYPE_DUMMY_P (gnu_object_type) = 1;
452 TYPE_POINTER_TO (gnu_desig_type) = gnu_fat_type;
453 TYPE_REFERENCE_TO (gnu_desig_type) = gnu_fat_type;
454 TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type;
457 /* Return true if we are in the global binding level. */
459 bool
460 global_bindings_p (void)
462 return force_global || !current_function_decl;
465 /* Enter a new binding level. */
467 void
468 gnat_pushlevel (void)
470 struct gnat_binding_level *newlevel = NULL;
472 /* Reuse a struct for this binding level, if there is one. */
473 if (free_binding_level)
475 newlevel = free_binding_level;
476 free_binding_level = free_binding_level->chain;
478 else
479 newlevel = ggc_alloc<gnat_binding_level> ();
481 /* Use a free BLOCK, if any; otherwise, allocate one. */
482 if (free_block_chain)
484 newlevel->block = free_block_chain;
485 free_block_chain = BLOCK_CHAIN (free_block_chain);
486 BLOCK_CHAIN (newlevel->block) = NULL_TREE;
488 else
489 newlevel->block = make_node (BLOCK);
491 /* Point the BLOCK we just made to its parent. */
492 if (current_binding_level)
493 BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
495 BLOCK_VARS (newlevel->block) = NULL_TREE;
496 BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
497 TREE_USED (newlevel->block) = 1;
499 /* Add this level to the front of the chain (stack) of active levels. */
500 newlevel->chain = current_binding_level;
501 newlevel->jmpbuf_decl = NULL_TREE;
502 current_binding_level = newlevel;
505 /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
506 and point FNDECL to this BLOCK. */
508 void
509 set_current_block_context (tree fndecl)
511 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
512 DECL_INITIAL (fndecl) = current_binding_level->block;
513 set_block_for_group (current_binding_level->block);
516 /* Set the jmpbuf_decl for the current binding level to DECL. */
518 void
519 set_block_jmpbuf_decl (tree decl)
521 current_binding_level->jmpbuf_decl = decl;
524 /* Get the jmpbuf_decl, if any, for the current binding level. */
526 tree
527 get_block_jmpbuf_decl (void)
529 return current_binding_level->jmpbuf_decl;
532 /* Exit a binding level. Set any BLOCK into the current code group. */
534 void
535 gnat_poplevel (void)
537 struct gnat_binding_level *level = current_binding_level;
538 tree block = level->block;
540 BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
541 BLOCK_SUBBLOCKS (block) = blocks_nreverse (BLOCK_SUBBLOCKS (block));
543 /* If this is a function-level BLOCK don't do anything. Otherwise, if there
544 are no variables free the block and merge its subblocks into those of its
545 parent block. Otherwise, add it to the list of its parent. */
546 if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
548 else if (!BLOCK_VARS (block))
550 BLOCK_SUBBLOCKS (level->chain->block)
551 = block_chainon (BLOCK_SUBBLOCKS (block),
552 BLOCK_SUBBLOCKS (level->chain->block));
553 BLOCK_CHAIN (block) = free_block_chain;
554 free_block_chain = block;
556 else
558 BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block);
559 BLOCK_SUBBLOCKS (level->chain->block) = block;
560 TREE_USED (block) = 1;
561 set_block_for_group (block);
564 /* Free this binding structure. */
565 current_binding_level = level->chain;
566 level->chain = free_binding_level;
567 free_binding_level = level;
570 /* Exit a binding level and discard the associated BLOCK. */
572 void
573 gnat_zaplevel (void)
575 struct gnat_binding_level *level = current_binding_level;
576 tree block = level->block;
578 BLOCK_CHAIN (block) = free_block_chain;
579 free_block_chain = block;
581 /* Free this binding structure. */
582 current_binding_level = level->chain;
583 level->chain = free_binding_level;
584 free_binding_level = level;
587 /* Set the context of TYPE and its parallel types (if any) to CONTEXT. */
589 static void
590 gnat_set_type_context (tree type, tree context)
592 tree decl = TYPE_STUB_DECL (type);
594 TYPE_CONTEXT (type) = context;
596 while (decl && DECL_PARALLEL_TYPE (decl))
598 tree parallel_type = DECL_PARALLEL_TYPE (decl);
600 /* Give a context to the parallel types and their stub decl, if any.
601 Some parallel types seems to be present in multiple parallel type
602 chains, so don't mess with their context if they already have one. */
603 if (!TYPE_CONTEXT (parallel_type))
605 if (TYPE_STUB_DECL (parallel_type))
606 DECL_CONTEXT (TYPE_STUB_DECL (parallel_type)) = context;
607 TYPE_CONTEXT (parallel_type) = context;
610 decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl));
614 /* Return the innermost scope, starting at GNAT_NODE, we are be interested in
615 the debug info, or Empty if there is no such scope. If not NULL, set
616 IS_SUBPROGRAM to whether the returned entity is a subprogram. */
618 Entity_Id
619 get_debug_scope (Node_Id gnat_node, bool *is_subprogram)
621 Entity_Id gnat_entity;
623 if (is_subprogram)
624 *is_subprogram = false;
626 if (Nkind (gnat_node) == N_Defining_Identifier
627 || Nkind (gnat_node) == N_Defining_Operator_Symbol)
628 gnat_entity = Scope (gnat_node);
629 else
630 return Empty;
632 while (Present (gnat_entity))
634 switch (Ekind (gnat_entity))
636 case E_Function:
637 case E_Procedure:
638 if (Present (Protected_Body_Subprogram (gnat_entity)))
639 gnat_entity = Protected_Body_Subprogram (gnat_entity);
641 /* If the scope is a subprogram, then just rely on
642 current_function_decl, so that we don't have to defer
643 anything. This is needed because other places rely on the
644 validity of the DECL_CONTEXT attribute of FUNCTION_DECL nodes. */
645 if (is_subprogram)
646 *is_subprogram = true;
647 return gnat_entity;
649 case E_Record_Type:
650 case E_Record_Subtype:
651 return gnat_entity;
653 default:
654 /* By default, we are not interested in this particular scope: go to
655 the outer one. */
656 break;
659 gnat_entity = Scope (gnat_entity);
662 return Empty;
665 /* If N is NULL, set TYPE's context to CONTEXT. Defer this to the processing
666 of N otherwise. */
668 static void
669 defer_or_set_type_context (tree type, tree context,
670 struct deferred_decl_context_node *n)
672 if (n)
673 add_deferred_type_context (n, type);
674 else
675 gnat_set_type_context (type, context);
678 /* Return global_context, but create it first if need be. */
680 static tree
681 get_global_context (void)
683 if (!global_context)
685 global_context
686 = build_translation_unit_decl (get_identifier (main_input_filename));
687 debug_hooks->register_main_translation_unit (global_context);
690 return global_context;
693 /* Record DECL as belonging to the current lexical scope and use GNAT_NODE
694 for location information and flag propagation. */
696 void
697 gnat_pushdecl (tree decl, Node_Id gnat_node)
699 tree context = NULL_TREE;
700 struct deferred_decl_context_node *deferred_decl_context = NULL;
702 /* If explicitely asked to make DECL global or if it's an imported nested
703 object, short-circuit the regular Scope-based context computation. */
704 if (!((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || force_global == 1))
706 /* Rely on the GNAT scope, or fallback to the current_function_decl if
707 the GNAT scope reached the global scope, if it reached a subprogram
708 or the declaration is a subprogram or a variable (for them we skip
709 intermediate context types because the subprogram body elaboration
710 machinery and the inliner both expect a subprogram context).
712 Falling back to current_function_decl is necessary for implicit
713 subprograms created by gigi, such as the elaboration subprograms. */
714 bool context_is_subprogram = false;
715 const Entity_Id gnat_scope
716 = get_debug_scope (gnat_node, &context_is_subprogram);
718 if (Present (gnat_scope)
719 && !context_is_subprogram
720 && TREE_CODE (decl) != FUNCTION_DECL
721 && TREE_CODE (decl) != VAR_DECL)
722 /* Always assume the scope has not been elaborated, thus defer the
723 context propagation to the time its elaboration will be
724 available. */
725 deferred_decl_context
726 = add_deferred_decl_context (decl, gnat_scope, force_global);
728 /* External declarations (when force_global > 0) may not be in a
729 local context. */
730 else if (current_function_decl && force_global == 0)
731 context = current_function_decl;
734 /* If either we are forced to be in global mode or if both the GNAT scope and
735 the current_function_decl did not help in determining the context, use the
736 global scope. */
737 if (!deferred_decl_context && !context)
738 context = get_global_context ();
740 /* Functions imported in another function are not really nested.
741 For really nested functions mark them initially as needing
742 a static chain for uses of that flag before unnesting;
743 lower_nested_functions will then recompute it. */
744 if (TREE_CODE (decl) == FUNCTION_DECL
745 && !TREE_PUBLIC (decl)
746 && context
747 && (TREE_CODE (context) == FUNCTION_DECL
748 || decl_function_context (context)))
749 DECL_STATIC_CHAIN (decl) = 1;
751 if (!deferred_decl_context)
752 DECL_CONTEXT (decl) = context;
754 TREE_NO_WARNING (decl) = (No (gnat_node) || Warnings_Off (gnat_node));
756 /* Set the location of DECL and emit a declaration for it. */
757 if (Present (gnat_node) && !renaming_from_instantiation_p (gnat_node))
758 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl));
760 add_decl_expr (decl, gnat_node);
762 /* Put the declaration on the list. The list of declarations is in reverse
763 order. The list will be reversed later. Put global declarations in the
764 globals list and local ones in the current block. But skip TYPE_DECLs
765 for UNCONSTRAINED_ARRAY_TYPE in both cases, as they will cause trouble
766 with the debugger and aren't needed anyway. */
767 if (!(TREE_CODE (decl) == TYPE_DECL
768 && TREE_CODE (TREE_TYPE (decl)) == UNCONSTRAINED_ARRAY_TYPE))
770 /* External declarations must go to the binding level they belong to.
771 This will make corresponding imported entities are available in the
772 debugger at the proper time. */
773 if (DECL_EXTERNAL (decl)
774 && TREE_CODE (decl) == FUNCTION_DECL
775 && DECL_BUILT_IN (decl))
776 vec_safe_push (builtin_decls, decl);
777 else if (global_bindings_p ())
778 vec_safe_push (global_decls, decl);
779 else
781 DECL_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
782 BLOCK_VARS (current_binding_level->block) = decl;
786 /* For the declaration of a type, set its name either if it isn't already
787 set or if the previous type name was not derived from a source name.
788 We'd rather have the type named with a real name and all the pointer
789 types to the same object have the same node, except when the names are
790 both derived from source names. */
791 if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl))
793 tree t = TREE_TYPE (decl);
795 /* Array and pointer types aren't tagged types in the C sense so we need
796 to generate a typedef in DWARF for them and make sure it is preserved,
797 unless the type is artificial. */
798 if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)
799 && ((TREE_CODE (t) != ARRAY_TYPE && TREE_CODE (t) != POINTER_TYPE)
800 || DECL_ARTIFICIAL (decl)))
802 /* For array and pointer types, create the DECL_ORIGINAL_TYPE that will
803 generate the typedef in DWARF. Also do that for fat pointer types
804 because, even though they are tagged types in the C sense, they are
805 still XUP types attached to the base array type at this point. */
806 else if (!DECL_ARTIFICIAL (decl)
807 && (TREE_CODE (t) == ARRAY_TYPE
808 || TREE_CODE (t) == POINTER_TYPE
809 || TYPE_IS_FAT_POINTER_P (t)))
811 tree tt = build_variant_type_copy (t);
812 TYPE_NAME (tt) = decl;
813 defer_or_set_type_context (tt,
814 DECL_CONTEXT (decl),
815 deferred_decl_context);
816 TREE_TYPE (decl) = tt;
817 if (TYPE_NAME (t)
818 && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL
819 && DECL_ORIGINAL_TYPE (TYPE_NAME (t)))
820 DECL_ORIGINAL_TYPE (decl) = DECL_ORIGINAL_TYPE (TYPE_NAME (t));
821 else
822 DECL_ORIGINAL_TYPE (decl) = t;
823 /* Array types need to have a name so that they can be related to
824 their GNAT encodings. */
825 if (TREE_CODE (t) == ARRAY_TYPE && !TYPE_NAME (t))
826 TYPE_NAME (t) = DECL_NAME (decl);
827 t = NULL_TREE;
829 else if (TYPE_NAME (t)
830 && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL
831 && DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl))
833 else
834 t = NULL_TREE;
836 /* Propagate the name to all the variants, this is needed for the type
837 qualifiers machinery to work properly (see check_qualified_type).
838 Also propagate the context to them. Note that it will be propagated
839 to all parallel types too thanks to gnat_set_type_context. */
840 if (t)
841 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
842 /* ??? Because of the previous kludge, we can have variants of fat
843 pointer types with different names. */
844 if (!(TYPE_IS_FAT_POINTER_P (t)
845 && TYPE_NAME (t)
846 && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
848 TYPE_NAME (t) = decl;
849 defer_or_set_type_context (t,
850 DECL_CONTEXT (decl),
851 deferred_decl_context);
856 /* Create a record type that contains a SIZE bytes long field of TYPE with a
857 starting bit position so that it is aligned to ALIGN bits, and leaving at
858 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
859 record is guaranteed to get. GNAT_NODE is used for the position of the
860 associated TYPE_DECL. */
862 tree
863 make_aligning_type (tree type, unsigned int align, tree size,
864 unsigned int base_align, int room, Node_Id gnat_node)
866 /* We will be crafting a record type with one field at a position set to be
867 the next multiple of ALIGN past record'address + room bytes. We use a
868 record placeholder to express record'address. */
869 tree record_type = make_node (RECORD_TYPE);
870 tree record = build0 (PLACEHOLDER_EXPR, record_type);
872 tree record_addr_st
873 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
875 /* The diagram below summarizes the shape of what we manipulate:
877 <--------- pos ---------->
878 { +------------+-------------+-----------------+
879 record =>{ |############| ... | field (type) |
880 { +------------+-------------+-----------------+
881 |<-- room -->|<- voffset ->|<---- size ----->|
884 record_addr vblock_addr
886 Every length is in sizetype bytes there, except "pos" which has to be
887 set as a bit position in the GCC tree for the record. */
888 tree room_st = size_int (room);
889 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
890 tree voffset_st, pos, field;
892 tree name = TYPE_IDENTIFIER (type);
894 name = concat_name (name, "ALIGN");
895 TYPE_NAME (record_type) = name;
897 /* Compute VOFFSET and then POS. The next byte position multiple of some
898 alignment after some address is obtained by "and"ing the alignment minus
899 1 with the two's complement of the address. */
900 voffset_st = size_binop (BIT_AND_EXPR,
901 fold_build1 (NEGATE_EXPR, sizetype, vblock_addr_st),
902 size_int ((align / BITS_PER_UNIT) - 1));
904 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
905 pos = size_binop (MULT_EXPR,
906 convert (bitsizetype,
907 size_binop (PLUS_EXPR, room_st, voffset_st)),
908 bitsize_unit_node);
910 /* Craft the GCC record representation. We exceptionally do everything
911 manually here because 1) our generic circuitry is not quite ready to
912 handle the complex position/size expressions we are setting up, 2) we
913 have a strong simplifying factor at hand: we know the maximum possible
914 value of voffset, and 3) we have to set/reset at least the sizes in
915 accordance with this maximum value anyway, as we need them to convey
916 what should be "alloc"ated for this type.
918 Use -1 as the 'addressable' indication for the field to prevent the
919 creation of a bitfield. We don't need one, it would have damaging
920 consequences on the alignment computation, and create_field_decl would
921 make one without this special argument, for instance because of the
922 complex position expression. */
923 field = create_field_decl (get_identifier ("F"), type, record_type, size,
924 pos, 1, -1);
925 TYPE_FIELDS (record_type) = field;
927 SET_TYPE_ALIGN (record_type, base_align);
928 TYPE_USER_ALIGN (record_type) = 1;
930 TYPE_SIZE (record_type)
931 = size_binop (PLUS_EXPR,
932 size_binop (MULT_EXPR, convert (bitsizetype, size),
933 bitsize_unit_node),
934 bitsize_int (align + room * BITS_PER_UNIT));
935 TYPE_SIZE_UNIT (record_type)
936 = size_binop (PLUS_EXPR, size,
937 size_int (room + align / BITS_PER_UNIT));
939 SET_TYPE_MODE (record_type, BLKmode);
940 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
942 /* Declare it now since it will never be declared otherwise. This is
943 necessary to ensure that its subtrees are properly marked. */
944 create_type_decl (name, record_type, true, false, gnat_node);
946 return record_type;
949 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
950 as the field type of a packed record if IN_RECORD is true, or as the
951 component type of a packed array if IN_RECORD is false. See if we can
952 rewrite it either as a type that has non-BLKmode, which we can pack
953 tighter in the packed record case, or as a smaller type with at most
954 MAX_ALIGN alignment if the value is non-zero. If so, return the new
955 type; if not, return the original type. */
957 tree
958 make_packable_type (tree type, bool in_record, unsigned int max_align)
960 unsigned HOST_WIDE_INT size = tree_to_uhwi (TYPE_SIZE (type));
961 unsigned HOST_WIDE_INT new_size;
962 unsigned int align = TYPE_ALIGN (type);
963 unsigned int new_align;
965 /* No point in doing anything if the size is zero. */
966 if (size == 0)
967 return type;
969 tree new_type = make_node (TREE_CODE (type));
971 /* Copy the name and flags from the old type to that of the new.
972 Note that we rely on the pointer equality created here for
973 TYPE_NAME to look through conversions in various places. */
974 TYPE_NAME (new_type) = TYPE_NAME (type);
975 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
976 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
977 TYPE_REVERSE_STORAGE_ORDER (new_type) = TYPE_REVERSE_STORAGE_ORDER (type);
978 if (TREE_CODE (type) == RECORD_TYPE)
979 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
981 /* If we are in a record and have a small size, set the alignment to
982 try for an integral mode. Otherwise set it to try for a smaller
983 type with BLKmode. */
984 if (in_record && size <= MAX_FIXED_MODE_SIZE)
986 new_size = ceil_pow2 (size);
987 new_align = MIN (new_size, BIGGEST_ALIGNMENT);
988 SET_TYPE_ALIGN (new_type, new_align);
990 else
992 /* Do not try to shrink the size if the RM size is not constant. */
993 if (TYPE_CONTAINS_TEMPLATE_P (type)
994 || !tree_fits_uhwi_p (TYPE_ADA_SIZE (type)))
995 return type;
997 /* Round the RM size up to a unit boundary to get the minimal size
998 for a BLKmode record. Give up if it's already the size and we
999 don't need to lower the alignment. */
1000 new_size = tree_to_uhwi (TYPE_ADA_SIZE (type));
1001 new_size = (new_size + BITS_PER_UNIT - 1) & -BITS_PER_UNIT;
1002 if (new_size == size && (max_align == 0 || align <= max_align))
1003 return type;
1005 new_align = MIN (new_size & -new_size, BIGGEST_ALIGNMENT);
1006 if (max_align > 0 && new_align > max_align)
1007 new_align = max_align;
1008 SET_TYPE_ALIGN (new_type, MIN (align, new_align));
1011 TYPE_USER_ALIGN (new_type) = 1;
1013 /* Now copy the fields, keeping the position and size as we don't want
1014 to change the layout by propagating the packedness downwards. */
1015 tree new_field_list = NULL_TREE;
1016 for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
1018 tree new_field_type = TREE_TYPE (field);
1019 tree new_field, new_size;
1021 if (RECORD_OR_UNION_TYPE_P (new_field_type)
1022 && !TYPE_FAT_POINTER_P (new_field_type)
1023 && tree_fits_uhwi_p (TYPE_SIZE (new_field_type)))
1024 new_field_type = make_packable_type (new_field_type, true, max_align);
1026 /* However, for the last field in a not already packed record type
1027 that is of an aggregate type, we need to use the RM size in the
1028 packable version of the record type, see finish_record_type. */
1029 if (!DECL_CHAIN (field)
1030 && !TYPE_PACKED (type)
1031 && RECORD_OR_UNION_TYPE_P (new_field_type)
1032 && !TYPE_FAT_POINTER_P (new_field_type)
1033 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
1034 && TYPE_ADA_SIZE (new_field_type))
1035 new_size = TYPE_ADA_SIZE (new_field_type);
1036 else
1037 new_size = DECL_SIZE (field);
1039 new_field
1040 = create_field_decl (DECL_NAME (field), new_field_type, new_type,
1041 new_size, bit_position (field),
1042 TYPE_PACKED (type),
1043 !DECL_NONADDRESSABLE_P (field));
1045 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (field);
1046 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
1047 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
1048 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (field);
1050 DECL_CHAIN (new_field) = new_field_list;
1051 new_field_list = new_field;
1054 finish_record_type (new_type, nreverse (new_field_list), 2, false);
1055 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
1056 if (TYPE_STUB_DECL (type))
1057 SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
1058 DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)));
1060 /* If this is a padding record, we never want to make the size smaller
1061 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
1062 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
1064 TYPE_SIZE (new_type) = TYPE_SIZE (type);
1065 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
1066 new_size = size;
1068 else
1070 TYPE_SIZE (new_type) = bitsize_int (new_size);
1071 TYPE_SIZE_UNIT (new_type) = size_int (new_size / BITS_PER_UNIT);
1074 if (!TYPE_CONTAINS_TEMPLATE_P (type))
1075 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
1077 compute_record_mode (new_type);
1079 /* Try harder to get a packable type if necessary, for example
1080 in case the record itself contains a BLKmode field. */
1081 if (in_record && TYPE_MODE (new_type) == BLKmode)
1082 SET_TYPE_MODE (new_type,
1083 mode_for_size_tree (TYPE_SIZE (new_type),
1084 MODE_INT, 1).else_blk ());
1086 /* If neither mode nor size nor alignment shrunk, return the old type. */
1087 if (TYPE_MODE (new_type) == BLKmode && new_size >= size && max_align == 0)
1088 return type;
1090 return new_type;
1093 /* Return true if TYPE has an unsigned representation. This needs to be used
1094 when the representation of types whose precision is not equal to their size
1095 is manipulated based on the RM size. */
1097 static inline bool
1098 type_unsigned_for_rm (tree type)
1100 /* This is the common case. */
1101 if (TYPE_UNSIGNED (type))
1102 return true;
1104 /* See the E_Signed_Integer_Subtype case of gnat_to_gnu_entity. */
1105 if (TREE_CODE (TYPE_MIN_VALUE (type)) == INTEGER_CST
1106 && tree_int_cst_sgn (TYPE_MIN_VALUE (type)) >= 0)
1107 return true;
1109 return false;
1112 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
1113 If TYPE is the best type, return it. Otherwise, make a new type. We
1114 only support new integral and pointer types. FOR_BIASED is true if
1115 we are making a biased type. */
1117 tree
1118 make_type_from_size (tree type, tree size_tree, bool for_biased)
1120 unsigned HOST_WIDE_INT size;
1121 bool biased_p;
1122 tree new_type;
1124 /* If size indicates an error, just return TYPE to avoid propagating
1125 the error. Likewise if it's too large to represent. */
1126 if (!size_tree || !tree_fits_uhwi_p (size_tree))
1127 return type;
1129 size = tree_to_uhwi (size_tree);
1131 switch (TREE_CODE (type))
1133 case INTEGER_TYPE:
1134 case ENUMERAL_TYPE:
1135 case BOOLEAN_TYPE:
1136 biased_p = (TREE_CODE (type) == INTEGER_TYPE
1137 && TYPE_BIASED_REPRESENTATION_P (type));
1139 /* Integer types with precision 0 are forbidden. */
1140 if (size == 0)
1141 size = 1;
1143 /* Only do something if the type isn't a packed array type and doesn't
1144 already have the proper size and the size isn't too large. */
1145 if (TYPE_IS_PACKED_ARRAY_TYPE_P (type)
1146 || (TYPE_PRECISION (type) == size && biased_p == for_biased)
1147 || size > LONG_LONG_TYPE_SIZE)
1148 break;
1150 biased_p |= for_biased;
1152 /* The type should be an unsigned type if the original type is unsigned
1153 or if the lower bound is constant and non-negative or if the type is
1154 biased, see E_Signed_Integer_Subtype case of gnat_to_gnu_entity. */
1155 if (type_unsigned_for_rm (type) || biased_p)
1156 new_type = make_unsigned_type (size);
1157 else
1158 new_type = make_signed_type (size);
1159 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
1160 SET_TYPE_RM_MIN_VALUE (new_type, TYPE_MIN_VALUE (type));
1161 SET_TYPE_RM_MAX_VALUE (new_type, TYPE_MAX_VALUE (type));
1162 /* Copy the name to show that it's essentially the same type and
1163 not a subrange type. */
1164 TYPE_NAME (new_type) = TYPE_NAME (type);
1165 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
1166 SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
1167 return new_type;
1169 case RECORD_TYPE:
1170 /* Do something if this is a fat pointer, in which case we
1171 may need to return the thin pointer. */
1172 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
1174 scalar_int_mode p_mode;
1175 if (!int_mode_for_size (size, 0).exists (&p_mode)
1176 || !targetm.valid_pointer_mode (p_mode))
1177 p_mode = ptr_mode;
1178 return
1179 build_pointer_type_for_mode
1180 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
1181 p_mode, 0);
1183 break;
1185 case POINTER_TYPE:
1186 /* Only do something if this is a thin pointer, in which case we
1187 may need to return the fat pointer. */
1188 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
1189 return
1190 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
1191 break;
1193 default:
1194 break;
1197 return type;
1200 /* Return true iff the padded types are equivalent. */
1202 bool
1203 pad_type_hasher::equal (pad_type_hash *t1, pad_type_hash *t2)
1205 tree type1, type2;
1207 if (t1->hash != t2->hash)
1208 return 0;
1210 type1 = t1->type;
1211 type2 = t2->type;
1213 /* We consider that the padded types are equivalent if they pad the same type
1214 and have the same size, alignment, RM size and storage order. Taking the
1215 mode into account is redundant since it is determined by the others. */
1216 return
1217 TREE_TYPE (TYPE_FIELDS (type1)) == TREE_TYPE (TYPE_FIELDS (type2))
1218 && TYPE_SIZE (type1) == TYPE_SIZE (type2)
1219 && TYPE_ALIGN (type1) == TYPE_ALIGN (type2)
1220 && TYPE_ADA_SIZE (type1) == TYPE_ADA_SIZE (type2)
1221 && TYPE_REVERSE_STORAGE_ORDER (type1) == TYPE_REVERSE_STORAGE_ORDER (type2);
1224 /* Look up the padded TYPE in the hash table and return its canonical version
1225 if it exists; otherwise, insert it into the hash table. */
1227 static tree
1228 lookup_and_insert_pad_type (tree type)
1230 hashval_t hashcode;
1231 struct pad_type_hash in, *h;
1233 hashcode
1234 = iterative_hash_object (TYPE_HASH (TREE_TYPE (TYPE_FIELDS (type))), 0);
1235 hashcode = iterative_hash_expr (TYPE_SIZE (type), hashcode);
1236 hashcode = iterative_hash_hashval_t (TYPE_ALIGN (type), hashcode);
1237 hashcode = iterative_hash_expr (TYPE_ADA_SIZE (type), hashcode);
1239 in.hash = hashcode;
1240 in.type = type;
1241 h = pad_type_hash_table->find_with_hash (&in, hashcode);
1242 if (h)
1243 return h->type;
1245 h = ggc_alloc<pad_type_hash> ();
1246 h->hash = hashcode;
1247 h->type = type;
1248 *pad_type_hash_table->find_slot_with_hash (h, hashcode, INSERT) = h;
1249 return NULL_TREE;
1252 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
1253 if needed. We have already verified that SIZE and ALIGN are large enough.
1254 GNAT_ENTITY is used to name the resulting record and to issue a warning.
1255 IS_COMPONENT_TYPE is true if this is being done for the component type of
1256 an array. IS_USER_TYPE is true if the original type needs to be completed.
1257 DEFINITION is true if this type is being defined. SET_RM_SIZE is true if
1258 the RM size of the resulting type is to be set to SIZE too; in this case,
1259 the padded type is canonicalized before being returned. */
1261 tree
1262 maybe_pad_type (tree type, tree size, unsigned int align,
1263 Entity_Id gnat_entity, bool is_component_type,
1264 bool is_user_type, bool definition, bool set_rm_size)
1266 tree orig_size = TYPE_SIZE (type);
1267 unsigned int orig_align = TYPE_ALIGN (type);
1268 tree record, field;
1270 /* If TYPE is a padded type, see if it agrees with any size and alignment
1271 we were given. If so, return the original type. Otherwise, strip
1272 off the padding, since we will either be returning the inner type
1273 or repadding it. If no size or alignment is specified, use that of
1274 the original padded type. */
1275 if (TYPE_IS_PADDING_P (type))
1277 if ((!size
1278 || operand_equal_p (round_up (size, orig_align), orig_size, 0))
1279 && (align == 0 || align == orig_align))
1280 return type;
1282 if (!size)
1283 size = orig_size;
1284 if (align == 0)
1285 align = orig_align;
1287 type = TREE_TYPE (TYPE_FIELDS (type));
1288 orig_size = TYPE_SIZE (type);
1289 orig_align = TYPE_ALIGN (type);
1292 /* If the size is either not being changed or is being made smaller (which
1293 is not done here and is only valid for bitfields anyway), show the size
1294 isn't changing. Likewise, clear the alignment if it isn't being
1295 changed. Then return if we aren't doing anything. */
1296 if (size
1297 && (operand_equal_p (size, orig_size, 0)
1298 || (TREE_CODE (orig_size) == INTEGER_CST
1299 && tree_int_cst_lt (size, orig_size))))
1300 size = NULL_TREE;
1302 if (align == orig_align)
1303 align = 0;
1305 if (align == 0 && !size)
1306 return type;
1308 /* If requested, complete the original type and give it a name. */
1309 if (is_user_type)
1310 create_type_decl (get_entity_name (gnat_entity), type,
1311 !Comes_From_Source (gnat_entity),
1312 !(TYPE_NAME (type)
1313 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
1314 && DECL_IGNORED_P (TYPE_NAME (type))),
1315 gnat_entity);
1317 /* We used to modify the record in place in some cases, but that could
1318 generate incorrect debugging information. So make a new record
1319 type and name. */
1320 record = make_node (RECORD_TYPE);
1321 TYPE_PADDING_P (record) = 1;
1323 /* ??? Padding types around packed array implementation types will be
1324 considered as root types in the array descriptor language hook (see
1325 gnat_get_array_descr_info). Give them the original packed array type
1326 name so that the one coming from sources appears in the debugging
1327 information. */
1328 if (TYPE_IMPL_PACKED_ARRAY_P (type)
1329 && TYPE_ORIGINAL_PACKED_ARRAY (type)
1330 && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1331 TYPE_NAME (record) = TYPE_NAME (TYPE_ORIGINAL_PACKED_ARRAY (type));
1332 else if (Present (gnat_entity))
1333 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
1335 SET_TYPE_ALIGN (record, align ? align : orig_align);
1336 TYPE_SIZE (record) = size ? size : orig_size;
1337 TYPE_SIZE_UNIT (record)
1338 = convert (sizetype,
1339 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
1340 bitsize_unit_node));
1342 /* If we are changing the alignment and the input type is a record with
1343 BLKmode and a small constant size, try to make a form that has an
1344 integral mode. This might allow the padding record to also have an
1345 integral mode, which will be much more efficient. There is no point
1346 in doing so if a size is specified unless it is also a small constant
1347 size and it is incorrect to do so if we cannot guarantee that the mode
1348 will be naturally aligned since the field must always be addressable.
1350 ??? This might not always be a win when done for a stand-alone object:
1351 since the nominal and the effective type of the object will now have
1352 different modes, a VIEW_CONVERT_EXPR will be required for converting
1353 between them and it might be hard to overcome afterwards, including
1354 at the RTL level when the stand-alone object is accessed as a whole. */
1355 if (align != 0
1356 && RECORD_OR_UNION_TYPE_P (type)
1357 && TYPE_MODE (type) == BLKmode
1358 && !TYPE_BY_REFERENCE_P (type)
1359 && TREE_CODE (orig_size) == INTEGER_CST
1360 && !TREE_OVERFLOW (orig_size)
1361 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
1362 && (!size
1363 || (TREE_CODE (size) == INTEGER_CST
1364 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
1366 tree packable_type = make_packable_type (type, true);
1367 if (TYPE_MODE (packable_type) != BLKmode
1368 && align >= TYPE_ALIGN (packable_type))
1369 type = packable_type;
1372 /* Now create the field with the original size. */
1373 field = create_field_decl (get_identifier ("F"), type, record, orig_size,
1374 bitsize_zero_node, 0, 1);
1375 DECL_INTERNAL_P (field) = 1;
1377 /* We will output additional debug info manually below. */
1378 finish_record_type (record, field, 1, false);
1380 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1381 SET_TYPE_DEBUG_TYPE (record, type);
1383 /* Set the RM size if requested. */
1384 if (set_rm_size)
1386 tree canonical_pad_type;
1388 SET_TYPE_ADA_SIZE (record, size ? size : orig_size);
1390 /* If the padded type is complete and has constant size, we canonicalize
1391 it by means of the hash table. This is consistent with the language
1392 semantics and ensures that gigi and the middle-end have a common view
1393 of these padded types. */
1394 if (TREE_CONSTANT (TYPE_SIZE (record))
1395 && (canonical_pad_type = lookup_and_insert_pad_type (record)))
1397 record = canonical_pad_type;
1398 goto built;
1402 /* Unless debugging information isn't being written for the input type,
1403 write a record that shows what we are a subtype of and also make a
1404 variable that indicates our size, if still variable. */
1405 if (TREE_CODE (orig_size) != INTEGER_CST
1406 && TYPE_NAME (record)
1407 && TYPE_NAME (type)
1408 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
1409 && DECL_IGNORED_P (TYPE_NAME (type))))
1411 tree name = TYPE_IDENTIFIER (record);
1412 tree size_unit = TYPE_SIZE_UNIT (record);
1414 /* A variable that holds the size is required even with no encoding since
1415 it will be referenced by debugging information attributes. At global
1416 level, we need a single variable across all translation units. */
1417 if (size
1418 && TREE_CODE (size) != INTEGER_CST
1419 && (definition || global_bindings_p ()))
1421 /* Whether or not gnat_entity comes from source, this XVZ variable is
1422 is a compilation artifact. */
1423 size_unit
1424 = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
1425 size_unit, true, global_bindings_p (),
1426 !definition && global_bindings_p (), false,
1427 false, true, true, NULL, gnat_entity);
1428 TYPE_SIZE_UNIT (record) = size_unit;
1431 /* There is no need to show what we are a subtype of when outputting as
1432 few encodings as possible: regular debugging infomation makes this
1433 redundant. */
1434 if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
1436 tree marker = make_node (RECORD_TYPE);
1437 tree orig_name = TYPE_IDENTIFIER (type);
1439 TYPE_NAME (marker) = concat_name (name, "XVS");
1440 finish_record_type (marker,
1441 create_field_decl (orig_name,
1442 build_reference_type (type),
1443 marker, NULL_TREE, NULL_TREE,
1444 0, 0),
1445 0, true);
1446 TYPE_SIZE_UNIT (marker) = size_unit;
1448 add_parallel_type (record, marker);
1452 built:
1453 /* If a simple size was explicitly given, maybe issue a warning. */
1454 if (!size
1455 || TREE_CODE (size) == COND_EXPR
1456 || TREE_CODE (size) == MAX_EXPR
1457 || No (gnat_entity))
1458 return record;
1460 /* But don't do it if we are just annotating types and the type is tagged or
1461 concurrent, since these types aren't fully laid out in this mode. */
1462 if (type_annotate_only)
1464 Entity_Id gnat_type
1465 = is_component_type
1466 ? Component_Type (gnat_entity) : Etype (gnat_entity);
1468 if (Is_Tagged_Type (gnat_type) || Is_Concurrent_Type (gnat_type))
1469 return record;
1472 /* Take the original size as the maximum size of the input if there was an
1473 unconstrained record involved and round it up to the specified alignment,
1474 if one was specified, but only for aggregate types. */
1475 if (CONTAINS_PLACEHOLDER_P (orig_size))
1476 orig_size = max_size (orig_size, true);
1478 if (align && AGGREGATE_TYPE_P (type))
1479 orig_size = round_up (orig_size, align);
1481 if (!operand_equal_p (size, orig_size, 0)
1482 && !(TREE_CODE (size) == INTEGER_CST
1483 && TREE_CODE (orig_size) == INTEGER_CST
1484 && (TREE_OVERFLOW (size)
1485 || TREE_OVERFLOW (orig_size)
1486 || tree_int_cst_lt (size, orig_size))))
1488 Node_Id gnat_error_node = Empty;
1490 /* For a packed array, post the message on the original array type. */
1491 if (Is_Packed_Array_Impl_Type (gnat_entity))
1492 gnat_entity = Original_Array_Type (gnat_entity);
1494 if ((Ekind (gnat_entity) == E_Component
1495 || Ekind (gnat_entity) == E_Discriminant)
1496 && Present (Component_Clause (gnat_entity)))
1497 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
1498 else if (Present (Size_Clause (gnat_entity)))
1499 gnat_error_node = Expression (Size_Clause (gnat_entity));
1501 /* Generate message only for entities that come from source, since
1502 if we have an entity created by expansion, the message will be
1503 generated for some other corresponding source entity. */
1504 if (Comes_From_Source (gnat_entity))
1506 if (Present (gnat_error_node))
1507 post_error_ne_tree ("{^ }bits of & unused?",
1508 gnat_error_node, gnat_entity,
1509 size_diffop (size, orig_size));
1510 else if (is_component_type)
1511 post_error_ne_tree ("component of& padded{ by ^ bits}?",
1512 gnat_entity, gnat_entity,
1513 size_diffop (size, orig_size));
1517 return record;
1520 /* Return a copy of the padded TYPE but with reverse storage order. */
1522 tree
1523 set_reverse_storage_order_on_pad_type (tree type)
1525 tree field, canonical_pad_type;
1527 if (flag_checking)
1529 /* If the inner type is not scalar then the function does nothing. */
1530 tree inner_type = TREE_TYPE (TYPE_FIELDS (type));
1531 gcc_assert (!AGGREGATE_TYPE_P (inner_type)
1532 && !VECTOR_TYPE_P (inner_type));
1535 /* This is required for the canonicalization. */
1536 gcc_assert (TREE_CONSTANT (TYPE_SIZE (type)));
1538 field = copy_node (TYPE_FIELDS (type));
1539 type = copy_type (type);
1540 DECL_CONTEXT (field) = type;
1541 TYPE_FIELDS (type) = field;
1542 TYPE_REVERSE_STORAGE_ORDER (type) = 1;
1543 canonical_pad_type = lookup_and_insert_pad_type (type);
1544 return canonical_pad_type ? canonical_pad_type : type;
1547 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
1548 If this is a multi-dimensional array type, do this recursively.
1550 OP may be
1551 - ALIAS_SET_COPY: the new set is made a copy of the old one.
1552 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
1553 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
1555 void
1556 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
1558 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
1559 of a one-dimensional array, since the padding has the same alias set
1560 as the field type, but if it's a multi-dimensional array, we need to
1561 see the inner types. */
1562 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
1563 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
1564 || TYPE_PADDING_P (gnu_old_type)))
1565 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
1567 /* Unconstrained array types are deemed incomplete and would thus be given
1568 alias set 0. Retrieve the underlying array type. */
1569 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
1570 gnu_old_type
1571 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
1572 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
1573 gnu_new_type
1574 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
1576 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
1577 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
1578 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
1579 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
1581 switch (op)
1583 case ALIAS_SET_COPY:
1584 /* The alias set shouldn't be copied between array types with different
1585 aliasing settings because this can break the aliasing relationship
1586 between the array type and its element type. */
1587 if (flag_checking || flag_strict_aliasing)
1588 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
1589 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
1590 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
1591 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
1593 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
1594 break;
1596 case ALIAS_SET_SUBSET:
1597 case ALIAS_SET_SUPERSET:
1599 alias_set_type old_set = get_alias_set (gnu_old_type);
1600 alias_set_type new_set = get_alias_set (gnu_new_type);
1602 /* Do nothing if the alias sets conflict. This ensures that we
1603 never call record_alias_subset several times for the same pair
1604 or at all for alias set 0. */
1605 if (!alias_sets_conflict_p (old_set, new_set))
1607 if (op == ALIAS_SET_SUBSET)
1608 record_alias_subset (old_set, new_set);
1609 else
1610 record_alias_subset (new_set, old_set);
1613 break;
1615 default:
1616 gcc_unreachable ();
1619 record_component_aliases (gnu_new_type);
1622 /* Record TYPE as a builtin type for Ada. NAME is the name of the type.
1623 ARTIFICIAL_P is true if the type was generated by the compiler. */
1625 void
1626 record_builtin_type (const char *name, tree type, bool artificial_p)
1628 tree type_decl = build_decl (input_location,
1629 TYPE_DECL, get_identifier (name), type);
1630 DECL_ARTIFICIAL (type_decl) = artificial_p;
1631 TYPE_ARTIFICIAL (type) = artificial_p;
1632 gnat_pushdecl (type_decl, Empty);
1634 if (debug_hooks->type_decl)
1635 debug_hooks->type_decl (type_decl, false);
1638 /* Finish constructing the character type CHAR_TYPE.
1640 In Ada character types are enumeration types and, as a consequence, are
1641 represented in the front-end by integral types holding the positions of
1642 the enumeration values as defined by the language, which means that the
1643 integral types are unsigned.
1645 Unfortunately the signedness of 'char' in C is implementation-defined
1646 and GCC even has the option -fsigned-char to toggle it at run time.
1647 Since GNAT's philosophy is to be compatible with C by default, to wit
1648 Interfaces.C.char is defined as a mere copy of Character, we may need
1649 to declare character types as signed types in GENERIC and generate the
1650 necessary adjustments to make them behave as unsigned types.
1652 The overall strategy is as follows: if 'char' is unsigned, do nothing;
1653 if 'char' is signed, translate character types of CHAR_TYPE_SIZE and
1654 character subtypes with RM_Size = Esize = CHAR_TYPE_SIZE into signed
1655 types. The idea is to ensure that the bit pattern contained in the
1656 Esize'd objects is not changed, even though the numerical value will
1657 be interpreted differently depending on the signedness. */
1659 void
1660 finish_character_type (tree char_type)
1662 if (TYPE_UNSIGNED (char_type))
1663 return;
1665 /* Make a copy of a generic unsigned version since we'll modify it. */
1666 tree unsigned_char_type
1667 = (char_type == char_type_node
1668 ? unsigned_char_type_node
1669 : copy_type (gnat_unsigned_type_for (char_type)));
1671 /* Create an unsigned version of the type and set it as debug type. */
1672 TYPE_NAME (unsigned_char_type) = TYPE_NAME (char_type);
1673 TYPE_STRING_FLAG (unsigned_char_type) = TYPE_STRING_FLAG (char_type);
1674 TYPE_ARTIFICIAL (unsigned_char_type) = TYPE_ARTIFICIAL (char_type);
1675 SET_TYPE_DEBUG_TYPE (char_type, unsigned_char_type);
1677 /* If this is a subtype, make the debug type a subtype of the debug type
1678 of the base type and convert literal RM bounds to unsigned. */
1679 if (TREE_TYPE (char_type))
1681 tree base_unsigned_char_type = TYPE_DEBUG_TYPE (TREE_TYPE (char_type));
1682 tree min_value = TYPE_RM_MIN_VALUE (char_type);
1683 tree max_value = TYPE_RM_MAX_VALUE (char_type);
1685 if (TREE_CODE (min_value) == INTEGER_CST)
1686 min_value = fold_convert (base_unsigned_char_type, min_value);
1687 if (TREE_CODE (max_value) == INTEGER_CST)
1688 max_value = fold_convert (base_unsigned_char_type, max_value);
1690 TREE_TYPE (unsigned_char_type) = base_unsigned_char_type;
1691 SET_TYPE_RM_MIN_VALUE (unsigned_char_type, min_value);
1692 SET_TYPE_RM_MAX_VALUE (unsigned_char_type, max_value);
1695 /* Adjust the RM bounds of the original type to unsigned; that's especially
1696 important for types since they are implicit in this case. */
1697 SET_TYPE_RM_MIN_VALUE (char_type, TYPE_MIN_VALUE (unsigned_char_type));
1698 SET_TYPE_RM_MAX_VALUE (char_type, TYPE_MAX_VALUE (unsigned_char_type));
1701 /* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
1702 finish constructing the record type as a fat pointer type. */
1704 void
1705 finish_fat_pointer_type (tree record_type, tree field_list)
1707 /* Make sure we can put it into a register. */
1708 if (STRICT_ALIGNMENT)
1709 SET_TYPE_ALIGN (record_type, MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE));
1711 /* Show what it really is. */
1712 TYPE_FAT_POINTER_P (record_type) = 1;
1714 /* Do not emit debug info for it since the types of its fields may still be
1715 incomplete at this point. */
1716 finish_record_type (record_type, field_list, 0, false);
1718 /* Force type_contains_placeholder_p to return true on it. Although the
1719 PLACEHOLDER_EXPRs are referenced only indirectly, this isn't a pointer
1720 type but the representation of the unconstrained array. */
1721 TYPE_CONTAINS_PLACEHOLDER_INTERNAL (record_type) = 2;
1724 /* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
1725 finish constructing the record or union type. If REP_LEVEL is zero, this
1726 record has no representation clause and so will be entirely laid out here.
1727 If REP_LEVEL is one, this record has a representation clause and has been
1728 laid out already; only set the sizes and alignment. If REP_LEVEL is two,
1729 this record is derived from a parent record and thus inherits its layout;
1730 only make a pass on the fields to finalize them. DEBUG_INFO_P is true if
1731 additional debug info needs to be output for this type. */
1733 void
1734 finish_record_type (tree record_type, tree field_list, int rep_level,
1735 bool debug_info_p)
1737 enum tree_code code = TREE_CODE (record_type);
1738 tree name = TYPE_IDENTIFIER (record_type);
1739 tree ada_size = bitsize_zero_node;
1740 tree size = bitsize_zero_node;
1741 bool had_size = TYPE_SIZE (record_type) != 0;
1742 bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0;
1743 bool had_align = TYPE_ALIGN (record_type) != 0;
1744 tree field;
1746 TYPE_FIELDS (record_type) = field_list;
1748 /* Always attach the TYPE_STUB_DECL for a record type. It is required to
1749 generate debug info and have a parallel type. */
1750 TYPE_STUB_DECL (record_type) = create_type_stub_decl (name, record_type);
1752 /* Globally initialize the record first. If this is a rep'ed record,
1753 that just means some initializations; otherwise, layout the record. */
1754 if (rep_level > 0)
1756 SET_TYPE_ALIGN (record_type, MAX (BITS_PER_UNIT,
1757 TYPE_ALIGN (record_type)));
1759 if (!had_size_unit)
1760 TYPE_SIZE_UNIT (record_type) = size_zero_node;
1762 if (!had_size)
1763 TYPE_SIZE (record_type) = bitsize_zero_node;
1765 /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
1766 out just like a UNION_TYPE, since the size will be fixed. */
1767 else if (code == QUAL_UNION_TYPE)
1768 code = UNION_TYPE;
1770 else
1772 /* Ensure there isn't a size already set. There can be in an error
1773 case where there is a rep clause but all fields have errors and
1774 no longer have a position. */
1775 TYPE_SIZE (record_type) = 0;
1777 /* Ensure we use the traditional GCC layout for bitfields when we need
1778 to pack the record type or have a representation clause. The other
1779 possible layout (Microsoft C compiler), if available, would prevent
1780 efficient packing in almost all cases. */
1781 #ifdef TARGET_MS_BITFIELD_LAYOUT
1782 if (TARGET_MS_BITFIELD_LAYOUT && TYPE_PACKED (record_type))
1783 decl_attributes (&record_type,
1784 tree_cons (get_identifier ("gcc_struct"),
1785 NULL_TREE, NULL_TREE),
1786 ATTR_FLAG_TYPE_IN_PLACE);
1787 #endif
1789 layout_type (record_type);
1792 /* At this point, the position and size of each field is known. It was
1793 either set before entry by a rep clause, or by laying out the type above.
1795 We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs)
1796 to compute the Ada size; the GCC size and alignment (for rep'ed records
1797 that are not padding types); and the mode (for rep'ed records). We also
1798 clear the DECL_BIT_FIELD indication for the cases we know have not been
1799 handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */
1801 if (code == QUAL_UNION_TYPE)
1802 field_list = nreverse (field_list);
1804 for (field = field_list; field; field = DECL_CHAIN (field))
1806 tree type = TREE_TYPE (field);
1807 tree pos = bit_position (field);
1808 tree this_size = DECL_SIZE (field);
1809 tree this_ada_size;
1811 if (RECORD_OR_UNION_TYPE_P (type)
1812 && !TYPE_FAT_POINTER_P (type)
1813 && !TYPE_CONTAINS_TEMPLATE_P (type)
1814 && TYPE_ADA_SIZE (type))
1815 this_ada_size = TYPE_ADA_SIZE (type);
1816 else
1817 this_ada_size = this_size;
1819 /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */
1820 if (DECL_BIT_FIELD (field)
1821 && operand_equal_p (this_size, TYPE_SIZE (type), 0))
1823 unsigned int align = TYPE_ALIGN (type);
1825 /* In the general case, type alignment is required. */
1826 if (value_factor_p (pos, align))
1828 /* The enclosing record type must be sufficiently aligned.
1829 Otherwise, if no alignment was specified for it and it
1830 has been laid out already, bump its alignment to the
1831 desired one if this is compatible with its size and
1832 maximum alignment, if any. */
1833 if (TYPE_ALIGN (record_type) >= align)
1835 SET_DECL_ALIGN (field, MAX (DECL_ALIGN (field), align));
1836 DECL_BIT_FIELD (field) = 0;
1838 else if (!had_align
1839 && rep_level == 0
1840 && value_factor_p (TYPE_SIZE (record_type), align)
1841 && (!TYPE_MAX_ALIGN (record_type)
1842 || TYPE_MAX_ALIGN (record_type) >= align))
1844 SET_TYPE_ALIGN (record_type, align);
1845 SET_DECL_ALIGN (field, MAX (DECL_ALIGN (field), align));
1846 DECL_BIT_FIELD (field) = 0;
1850 /* In the non-strict alignment case, only byte alignment is. */
1851 if (!STRICT_ALIGNMENT
1852 && DECL_BIT_FIELD (field)
1853 && value_factor_p (pos, BITS_PER_UNIT))
1854 DECL_BIT_FIELD (field) = 0;
1857 /* If we still have DECL_BIT_FIELD set at this point, we know that the
1858 field is technically not addressable. Except that it can actually
1859 be addressed if it is BLKmode and happens to be properly aligned. */
1860 if (DECL_BIT_FIELD (field)
1861 && !(DECL_MODE (field) == BLKmode
1862 && value_factor_p (pos, BITS_PER_UNIT)))
1863 DECL_NONADDRESSABLE_P (field) = 1;
1865 /* A type must be as aligned as its most aligned field that is not
1866 a bit-field. But this is already enforced by layout_type. */
1867 if (rep_level > 0 && !DECL_BIT_FIELD (field))
1868 SET_TYPE_ALIGN (record_type,
1869 MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field)));
1871 switch (code)
1873 case UNION_TYPE:
1874 ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size);
1875 size = size_binop (MAX_EXPR, size, this_size);
1876 break;
1878 case QUAL_UNION_TYPE:
1879 ada_size
1880 = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
1881 this_ada_size, ada_size);
1882 size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
1883 this_size, size);
1884 break;
1886 case RECORD_TYPE:
1887 /* Since we know here that all fields are sorted in order of
1888 increasing bit position, the size of the record is one
1889 higher than the ending bit of the last field processed
1890 unless we have a rep clause, since in that case we might
1891 have a field outside a QUAL_UNION_TYPE that has a higher ending
1892 position. So use a MAX in that case. Also, if this field is a
1893 QUAL_UNION_TYPE, we need to take into account the previous size in
1894 the case of empty variants. */
1895 ada_size
1896 = merge_sizes (ada_size, pos, this_ada_size,
1897 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
1898 size
1899 = merge_sizes (size, pos, this_size,
1900 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
1901 break;
1903 default:
1904 gcc_unreachable ();
1908 if (code == QUAL_UNION_TYPE)
1909 nreverse (field_list);
1911 if (rep_level < 2)
1913 /* If this is a padding record, we never want to make the size smaller
1914 than what was specified in it, if any. */
1915 if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
1916 size = TYPE_SIZE (record_type);
1918 /* Now set any of the values we've just computed that apply. */
1919 if (!TYPE_FAT_POINTER_P (record_type)
1920 && !TYPE_CONTAINS_TEMPLATE_P (record_type))
1921 SET_TYPE_ADA_SIZE (record_type, ada_size);
1923 if (rep_level > 0)
1925 tree size_unit = had_size_unit
1926 ? TYPE_SIZE_UNIT (record_type)
1927 : convert (sizetype,
1928 size_binop (CEIL_DIV_EXPR, size,
1929 bitsize_unit_node));
1930 unsigned int align = TYPE_ALIGN (record_type);
1932 TYPE_SIZE (record_type) = variable_size (round_up (size, align));
1933 TYPE_SIZE_UNIT (record_type)
1934 = variable_size (round_up (size_unit, align / BITS_PER_UNIT));
1936 compute_record_mode (record_type);
1940 /* Reset the TYPE_MAX_ALIGN field since it's private to gigi. */
1941 TYPE_MAX_ALIGN (record_type) = 0;
1943 if (debug_info_p)
1944 rest_of_record_type_compilation (record_type);
1947 /* Append PARALLEL_TYPE on the chain of parallel types of TYPE. If
1948 PARRALEL_TYPE has no context and its computation is not deferred yet, also
1949 propagate TYPE's context to PARALLEL_TYPE's or defer its propagation to the
1950 moment TYPE will get a context. */
1952 void
1953 add_parallel_type (tree type, tree parallel_type)
1955 tree decl = TYPE_STUB_DECL (type);
1957 while (DECL_PARALLEL_TYPE (decl))
1958 decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl));
1960 SET_DECL_PARALLEL_TYPE (decl, parallel_type);
1962 /* If PARALLEL_TYPE already has a context, we are done. */
1963 if (TYPE_CONTEXT (parallel_type))
1964 return;
1966 /* Otherwise, try to get one from TYPE's context. If so, simply propagate
1967 it to PARALLEL_TYPE. */
1968 if (TYPE_CONTEXT (type))
1969 gnat_set_type_context (parallel_type, TYPE_CONTEXT (type));
1971 /* Otherwise TYPE has not context yet. We know it will have one thanks to
1972 gnat_pushdecl and then its context will be propagated to PARALLEL_TYPE,
1973 so we have nothing to do in this case. */
1976 /* Return true if TYPE has a parallel type. */
1978 static bool
1979 has_parallel_type (tree type)
1981 tree decl = TYPE_STUB_DECL (type);
1983 return DECL_PARALLEL_TYPE (decl) != NULL_TREE;
1986 /* Wrap up compilation of RECORD_TYPE, i.e. output additional debug info
1987 associated with it. It need not be invoked directly in most cases as
1988 finish_record_type takes care of doing so. */
1990 void
1991 rest_of_record_type_compilation (tree record_type)
1993 bool var_size = false;
1994 tree field;
1996 /* If this is a padded type, the bulk of the debug info has already been
1997 generated for the field's type. */
1998 if (TYPE_IS_PADDING_P (record_type))
1999 return;
2001 /* If the type already has a parallel type (XVS type), then we're done. */
2002 if (has_parallel_type (record_type))
2003 return;
2005 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
2007 /* We need to make an XVE/XVU record if any field has variable size,
2008 whether or not the record does. For example, if we have a union,
2009 it may be that all fields, rounded up to the alignment, have the
2010 same size, in which case we'll use that size. But the debug
2011 output routines (except Dwarf2) won't be able to output the fields,
2012 so we need to make the special record. */
2013 if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST
2014 /* If a field has a non-constant qualifier, the record will have
2015 variable size too. */
2016 || (TREE_CODE (record_type) == QUAL_UNION_TYPE
2017 && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST))
2019 var_size = true;
2020 break;
2024 /* If this record type is of variable size, make a parallel record type that
2025 will tell the debugger how the former is laid out (see exp_dbug.ads). */
2026 if (var_size && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
2028 tree new_record_type
2029 = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
2030 ? UNION_TYPE : TREE_CODE (record_type));
2031 tree orig_name = TYPE_IDENTIFIER (record_type), new_name;
2032 tree last_pos = bitsize_zero_node;
2033 tree old_field, prev_old_field = NULL_TREE;
2035 new_name
2036 = concat_name (orig_name, TREE_CODE (record_type) == QUAL_UNION_TYPE
2037 ? "XVU" : "XVE");
2038 TYPE_NAME (new_record_type) = new_name;
2039 SET_TYPE_ALIGN (new_record_type, BIGGEST_ALIGNMENT);
2040 TYPE_STUB_DECL (new_record_type)
2041 = create_type_stub_decl (new_name, new_record_type);
2042 DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
2043 = DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
2044 gnat_pushdecl (TYPE_STUB_DECL (new_record_type), Empty);
2045 TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
2046 TYPE_SIZE_UNIT (new_record_type)
2047 = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT);
2049 /* Now scan all the fields, replacing each field with a new field
2050 corresponding to the new encoding. */
2051 for (old_field = TYPE_FIELDS (record_type); old_field;
2052 old_field = DECL_CHAIN (old_field))
2054 tree field_type = TREE_TYPE (old_field);
2055 tree field_name = DECL_NAME (old_field);
2056 tree curpos = fold_bit_position (old_field);
2057 tree pos, new_field;
2058 bool var = false;
2059 unsigned int align = 0;
2061 /* See how the position was modified from the last position.
2063 There are two basic cases we support: a value was added
2064 to the last position or the last position was rounded to
2065 a boundary and they something was added. Check for the
2066 first case first. If not, see if there is any evidence
2067 of rounding. If so, round the last position and retry.
2069 If this is a union, the position can be taken as zero. */
2070 if (TREE_CODE (new_record_type) == UNION_TYPE)
2071 pos = bitsize_zero_node;
2072 else
2073 pos = compute_related_constant (curpos, last_pos);
2075 if (!pos
2076 && TREE_CODE (curpos) == MULT_EXPR
2077 && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1)))
2079 tree offset = TREE_OPERAND (curpos, 0);
2080 align = tree_to_uhwi (TREE_OPERAND (curpos, 1));
2081 align = scale_by_factor_of (offset, align);
2082 last_pos = round_up (last_pos, align);
2083 pos = compute_related_constant (curpos, last_pos);
2085 else if (!pos
2086 && TREE_CODE (curpos) == PLUS_EXPR
2087 && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1))
2088 && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR
2089 && tree_fits_uhwi_p
2090 (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1)))
2092 tree offset = TREE_OPERAND (TREE_OPERAND (curpos, 0), 0);
2093 unsigned HOST_WIDE_INT addend
2094 = tree_to_uhwi (TREE_OPERAND (curpos, 1));
2095 align
2096 = tree_to_uhwi (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1));
2097 align = scale_by_factor_of (offset, align);
2098 align = MIN (align, addend & -addend);
2099 last_pos = round_up (last_pos, align);
2100 pos = compute_related_constant (curpos, last_pos);
2102 else if (potential_alignment_gap (prev_old_field, old_field, pos))
2104 align = TYPE_ALIGN (field_type);
2105 last_pos = round_up (last_pos, align);
2106 pos = compute_related_constant (curpos, last_pos);
2109 /* If we can't compute a position, set it to zero.
2111 ??? We really should abort here, but it's too much work
2112 to get this correct for all cases. */
2113 if (!pos)
2114 pos = bitsize_zero_node;
2116 /* See if this type is variable-sized and make a pointer type
2117 and indicate the indirection if so. Beware that the debug
2118 back-end may adjust the position computed above according
2119 to the alignment of the field type, i.e. the pointer type
2120 in this case, if we don't preventively counter that. */
2121 if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
2123 field_type = build_pointer_type (field_type);
2124 if (align != 0 && TYPE_ALIGN (field_type) > align)
2126 field_type = copy_type (field_type);
2127 SET_TYPE_ALIGN (field_type, align);
2129 var = true;
2132 /* Make a new field name, if necessary. */
2133 if (var || align != 0)
2135 char suffix[16];
2137 if (align != 0)
2138 sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
2139 align / BITS_PER_UNIT);
2140 else
2141 strcpy (suffix, "XVL");
2143 field_name = concat_name (field_name, suffix);
2146 new_field
2147 = create_field_decl (field_name, field_type, new_record_type,
2148 DECL_SIZE (old_field), pos, 0, 0);
2149 DECL_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
2150 TYPE_FIELDS (new_record_type) = new_field;
2152 /* If old_field is a QUAL_UNION_TYPE, take its size as being
2153 zero. The only time it's not the last field of the record
2154 is when there are other components at fixed positions after
2155 it (meaning there was a rep clause for every field) and we
2156 want to be able to encode them. */
2157 last_pos = size_binop (PLUS_EXPR, curpos,
2158 (TREE_CODE (TREE_TYPE (old_field))
2159 == QUAL_UNION_TYPE)
2160 ? bitsize_zero_node
2161 : DECL_SIZE (old_field));
2162 prev_old_field = old_field;
2165 TYPE_FIELDS (new_record_type) = nreverse (TYPE_FIELDS (new_record_type));
2167 add_parallel_type (record_type, new_record_type);
2171 /* Utility function of above to merge LAST_SIZE, the previous size of a record
2172 with FIRST_BIT and SIZE that describe a field. SPECIAL is true if this
2173 represents a QUAL_UNION_TYPE in which case we must look for COND_EXPRs and
2174 replace a value of zero with the old size. If HAS_REP is true, we take the
2175 MAX of the end position of this field with LAST_SIZE. In all other cases,
2176 we use FIRST_BIT plus SIZE. Return an expression for the size. */
2178 static tree
2179 merge_sizes (tree last_size, tree first_bit, tree size, bool special,
2180 bool has_rep)
2182 tree type = TREE_TYPE (last_size);
2183 tree new_size;
2185 if (!special || TREE_CODE (size) != COND_EXPR)
2187 new_size = size_binop (PLUS_EXPR, first_bit, size);
2188 if (has_rep)
2189 new_size = size_binop (MAX_EXPR, last_size, new_size);
2192 else
2193 new_size = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
2194 integer_zerop (TREE_OPERAND (size, 1))
2195 ? last_size : merge_sizes (last_size, first_bit,
2196 TREE_OPERAND (size, 1),
2197 1, has_rep),
2198 integer_zerop (TREE_OPERAND (size, 2))
2199 ? last_size : merge_sizes (last_size, first_bit,
2200 TREE_OPERAND (size, 2),
2201 1, has_rep));
2203 /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
2204 when fed through substitute_in_expr) into thinking that a constant
2205 size is not constant. */
2206 while (TREE_CODE (new_size) == NON_LVALUE_EXPR)
2207 new_size = TREE_OPERAND (new_size, 0);
2209 return new_size;
2212 /* Return the bit position of FIELD, in bits from the start of the record,
2213 and fold it as much as possible. This is a tree of type bitsizetype. */
2215 static tree
2216 fold_bit_position (const_tree field)
2218 tree offset = DECL_FIELD_OFFSET (field);
2219 if (TREE_CODE (offset) == MULT_EXPR || TREE_CODE (offset) == PLUS_EXPR)
2220 offset = size_binop (TREE_CODE (offset),
2221 fold_convert (bitsizetype, TREE_OPERAND (offset, 0)),
2222 fold_convert (bitsizetype, TREE_OPERAND (offset, 1)));
2223 else
2224 offset = fold_convert (bitsizetype, offset);
2225 return size_binop (PLUS_EXPR, DECL_FIELD_BIT_OFFSET (field),
2226 size_binop (MULT_EXPR, offset, bitsize_unit_node));
2229 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
2230 related by the addition of a constant. Return that constant if so. */
2232 static tree
2233 compute_related_constant (tree op0, tree op1)
2235 tree factor, op0_var, op1_var, op0_cst, op1_cst, result;
2237 if (TREE_CODE (op0) == MULT_EXPR
2238 && TREE_CODE (op1) == MULT_EXPR
2239 && TREE_CODE (TREE_OPERAND (op0, 1)) == INTEGER_CST
2240 && TREE_OPERAND (op1, 1) == TREE_OPERAND (op0, 1))
2242 factor = TREE_OPERAND (op0, 1);
2243 op0 = TREE_OPERAND (op0, 0);
2244 op1 = TREE_OPERAND (op1, 0);
2246 else
2247 factor = NULL_TREE;
2249 op0_cst = split_plus (op0, &op0_var);
2250 op1_cst = split_plus (op1, &op1_var);
2251 result = size_binop (MINUS_EXPR, op0_cst, op1_cst);
2253 if (operand_equal_p (op0_var, op1_var, 0))
2254 return factor ? size_binop (MULT_EXPR, factor, result) : result;
2256 return NULL_TREE;
2259 /* Utility function of above to split a tree OP which may be a sum, into a
2260 constant part, which is returned, and a variable part, which is stored
2261 in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of
2262 bitsizetype. */
2264 static tree
2265 split_plus (tree in, tree *pvar)
2267 /* Strip conversions in order to ease the tree traversal and maximize the
2268 potential for constant or plus/minus discovery. We need to be careful
2269 to always return and set *pvar to bitsizetype trees, but it's worth
2270 the effort. */
2271 in = remove_conversions (in, false);
2273 *pvar = convert (bitsizetype, in);
2275 if (TREE_CODE (in) == INTEGER_CST)
2277 *pvar = bitsize_zero_node;
2278 return convert (bitsizetype, in);
2280 else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
2282 tree lhs_var, rhs_var;
2283 tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
2284 tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
2286 if (lhs_var == TREE_OPERAND (in, 0)
2287 && rhs_var == TREE_OPERAND (in, 1))
2288 return bitsize_zero_node;
2290 *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
2291 return size_binop (TREE_CODE (in), lhs_con, rhs_con);
2293 else
2294 return bitsize_zero_node;
2297 /* Return a copy of TYPE but safe to modify in any way. */
2299 tree
2300 copy_type (tree type)
2302 tree new_type = copy_node (type);
2304 /* Unshare the language-specific data. */
2305 if (TYPE_LANG_SPECIFIC (type))
2307 TYPE_LANG_SPECIFIC (new_type) = NULL;
2308 SET_TYPE_LANG_SPECIFIC (new_type, GET_TYPE_LANG_SPECIFIC (type));
2311 /* And the contents of the language-specific slot if needed. */
2312 if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE)
2313 && TYPE_RM_VALUES (type))
2315 TYPE_RM_VALUES (new_type) = NULL_TREE;
2316 SET_TYPE_RM_SIZE (new_type, TYPE_RM_SIZE (type));
2317 SET_TYPE_RM_MIN_VALUE (new_type, TYPE_RM_MIN_VALUE (type));
2318 SET_TYPE_RM_MAX_VALUE (new_type, TYPE_RM_MAX_VALUE (type));
2321 /* copy_node clears this field instead of copying it, because it is
2322 aliased with TREE_CHAIN. */
2323 TYPE_STUB_DECL (new_type) = TYPE_STUB_DECL (type);
2325 TYPE_POINTER_TO (new_type) = NULL_TREE;
2326 TYPE_REFERENCE_TO (new_type) = NULL_TREE;
2327 TYPE_MAIN_VARIANT (new_type) = new_type;
2328 TYPE_NEXT_VARIANT (new_type) = NULL_TREE;
2329 TYPE_CANONICAL (new_type) = new_type;
2331 return new_type;
2334 /* Return a subtype of sizetype with range MIN to MAX and whose
2335 TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position
2336 of the associated TYPE_DECL. */
2338 tree
2339 create_index_type (tree min, tree max, tree index, Node_Id gnat_node)
2341 /* First build a type for the desired range. */
2342 tree type = build_nonshared_range_type (sizetype, min, max);
2344 /* Then set the index type. */
2345 SET_TYPE_INDEX_TYPE (type, index);
2346 create_type_decl (NULL_TREE, type, true, false, gnat_node);
2348 return type;
2351 /* Return a subtype of TYPE with range MIN to MAX. If TYPE is NULL,
2352 sizetype is used. */
2354 tree
2355 create_range_type (tree type, tree min, tree max)
2357 tree range_type;
2359 if (!type)
2360 type = sizetype;
2362 /* First build a type with the base range. */
2363 range_type = build_nonshared_range_type (type, TYPE_MIN_VALUE (type),
2364 TYPE_MAX_VALUE (type));
2366 /* Then set the actual range. */
2367 SET_TYPE_RM_MIN_VALUE (range_type, min);
2368 SET_TYPE_RM_MAX_VALUE (range_type, max);
2370 return range_type;
2373 /* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of TYPE.
2374 NAME gives the name of the type to be used in the declaration. */
2376 tree
2377 create_type_stub_decl (tree name, tree type)
2379 tree type_decl = build_decl (input_location, TYPE_DECL, name, type);
2380 DECL_ARTIFICIAL (type_decl) = 1;
2381 TYPE_ARTIFICIAL (type) = 1;
2382 return type_decl;
2385 /* Return a TYPE_DECL node for TYPE. NAME gives the name of the type to be
2386 used in the declaration. ARTIFICIAL_P is true if the declaration was
2387 generated by the compiler. DEBUG_INFO_P is true if we need to write
2388 debug information about this type. GNAT_NODE is used for the position
2389 of the decl. */
2391 tree
2392 create_type_decl (tree name, tree type, bool artificial_p, bool debug_info_p,
2393 Node_Id gnat_node)
2395 enum tree_code code = TREE_CODE (type);
2396 bool is_named
2397 = TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL;
2398 tree type_decl;
2400 /* Only the builtin TYPE_STUB_DECL should be used for dummy types. */
2401 gcc_assert (!TYPE_IS_DUMMY_P (type));
2403 /* If the type hasn't been named yet, we're naming it; preserve an existing
2404 TYPE_STUB_DECL that has been attached to it for some purpose. */
2405 if (!is_named && TYPE_STUB_DECL (type))
2407 type_decl = TYPE_STUB_DECL (type);
2408 DECL_NAME (type_decl) = name;
2410 else
2411 type_decl = build_decl (input_location, TYPE_DECL, name, type);
2413 DECL_ARTIFICIAL (type_decl) = artificial_p;
2414 TYPE_ARTIFICIAL (type) = artificial_p;
2416 /* Add this decl to the current binding level. */
2417 gnat_pushdecl (type_decl, gnat_node);
2419 /* If we're naming the type, equate the TYPE_STUB_DECL to the name. This
2420 causes the name to be also viewed as a "tag" by the debug back-end, with
2421 the advantage that no DW_TAG_typedef is emitted for artificial "tagged"
2422 types in DWARF.
2424 Note that if "type" is used as a DECL_ORIGINAL_TYPE, it may be referenced
2425 from multiple contexts, and "type_decl" references a copy of it: in such a
2426 case, do not mess TYPE_STUB_DECL: we do not want to re-use the TYPE_DECL
2427 with the mechanism above. */
2428 if (!is_named && type != DECL_ORIGINAL_TYPE (type_decl))
2429 TYPE_STUB_DECL (type) = type_decl;
2431 /* Do not generate debug info for UNCONSTRAINED_ARRAY_TYPE that the
2432 back-end doesn't support, and for others if we don't need to. */
2433 if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p)
2434 DECL_IGNORED_P (type_decl) = 1;
2436 return type_decl;
2439 /* Return a VAR_DECL or CONST_DECL node.
2441 NAME gives the name of the variable. ASM_NAME is its assembler name
2442 (if provided). TYPE is its data type (a GCC ..._TYPE node). INIT is
2443 the GCC tree for an optional initial expression; NULL_TREE if none.
2445 CONST_FLAG is true if this variable is constant, in which case we might
2446 return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false.
2448 PUBLIC_FLAG is true if this is for a reference to a public entity or for a
2449 definition to be made visible outside of the current compilation unit, for
2450 instance variable definitions in a package specification.
2452 EXTERN_FLAG is true when processing an external variable declaration (as
2453 opposed to a definition: no storage is to be allocated for the variable).
2455 STATIC_FLAG is only relevant when not at top level and indicates whether
2456 to always allocate storage to the variable.
2458 VOLATILE_FLAG is true if this variable is declared as volatile.
2460 ARTIFICIAL_P is true if the variable was generated by the compiler.
2462 DEBUG_INFO_P is true if we need to write debug information for it.
2464 ATTR_LIST is the list of attributes to be attached to the variable.
2466 GNAT_NODE is used for the position of the decl. */
2468 tree
2469 create_var_decl (tree name, tree asm_name, tree type, tree init,
2470 bool const_flag, bool public_flag, bool extern_flag,
2471 bool static_flag, bool volatile_flag, bool artificial_p,
2472 bool debug_info_p, struct attrib *attr_list,
2473 Node_Id gnat_node, bool const_decl_allowed_p)
2475 /* Whether the object has static storage duration, either explicitly or by
2476 virtue of being declared at the global level. */
2477 const bool static_storage = static_flag || global_bindings_p ();
2479 /* Whether the initializer is constant: for an external object or an object
2480 with static storage duration, we check that the initializer is a valid
2481 constant expression for initializing a static variable; otherwise, we
2482 only check that it is constant. */
2483 const bool init_const
2484 = (init
2485 && gnat_types_compatible_p (type, TREE_TYPE (init))
2486 && (extern_flag || static_storage
2487 ? initializer_constant_valid_p (init, TREE_TYPE (init))
2488 != NULL_TREE
2489 : TREE_CONSTANT (init)));
2491 /* Whether we will make TREE_CONSTANT the DECL we produce here, in which
2492 case the initializer may be used in lieu of the DECL node (as done in
2493 Identifier_to_gnu). This is useful to prevent the need of elaboration
2494 code when an identifier for which such a DECL is made is in turn used
2495 as an initializer. We used to rely on CONST_DECL vs VAR_DECL for this,
2496 but extra constraints apply to this choice (see below) and they are not
2497 relevant to the distinction we wish to make. */
2498 const bool constant_p = const_flag && init_const;
2500 /* The actual DECL node. CONST_DECL was initially intended for enumerals
2501 and may be used for scalars in general but not for aggregates. */
2502 tree var_decl
2503 = build_decl (input_location,
2504 (constant_p
2505 && const_decl_allowed_p
2506 && !AGGREGATE_TYPE_P (type) ? CONST_DECL : VAR_DECL),
2507 name, type);
2509 /* Detect constants created by the front-end to hold 'reference to function
2510 calls for stabilization purposes. This is needed for renaming. */
2511 if (const_flag && init && POINTER_TYPE_P (type))
2513 tree inner = init;
2514 if (TREE_CODE (inner) == COMPOUND_EXPR)
2515 inner = TREE_OPERAND (inner, 1);
2516 inner = remove_conversions (inner, true);
2517 if (TREE_CODE (inner) == ADDR_EXPR
2518 && ((TREE_CODE (TREE_OPERAND (inner, 0)) == CALL_EXPR
2519 && !call_is_atomic_load (TREE_OPERAND (inner, 0)))
2520 || (TREE_CODE (TREE_OPERAND (inner, 0)) == VAR_DECL
2521 && DECL_RETURN_VALUE_P (TREE_OPERAND (inner, 0)))))
2522 DECL_RETURN_VALUE_P (var_decl) = 1;
2525 /* If this is external, throw away any initializations (they will be done
2526 elsewhere) unless this is a constant for which we would like to remain
2527 able to get the initializer. If we are defining a global here, leave a
2528 constant initialization and save any variable elaborations for the
2529 elaboration routine. If we are just annotating types, throw away the
2530 initialization if it isn't a constant. */
2531 if ((extern_flag && !constant_p)
2532 || (type_annotate_only && init && !TREE_CONSTANT (init)))
2533 init = NULL_TREE;
2535 /* At the global level, a non-constant initializer generates elaboration
2536 statements. Check that such statements are allowed, that is to say,
2537 not violating a No_Elaboration_Code restriction. */
2538 if (init && !init_const && global_bindings_p ())
2539 Check_Elaboration_Code_Allowed (gnat_node);
2541 /* Attach the initializer, if any. */
2542 DECL_INITIAL (var_decl) = init;
2544 /* Directly set some flags. */
2545 DECL_ARTIFICIAL (var_decl) = artificial_p;
2546 DECL_EXTERNAL (var_decl) = extern_flag;
2548 TREE_CONSTANT (var_decl) = constant_p;
2549 TREE_READONLY (var_decl) = const_flag;
2551 /* The object is public if it is external or if it is declared public
2552 and has static storage duration. */
2553 TREE_PUBLIC (var_decl) = extern_flag || (public_flag && static_storage);
2555 /* We need to allocate static storage for an object with static storage
2556 duration if it isn't external. */
2557 TREE_STATIC (var_decl) = !extern_flag && static_storage;
2559 TREE_SIDE_EFFECTS (var_decl)
2560 = TREE_THIS_VOLATILE (var_decl)
2561 = TYPE_VOLATILE (type) | volatile_flag;
2563 if (TREE_SIDE_EFFECTS (var_decl))
2564 TREE_ADDRESSABLE (var_decl) = 1;
2566 /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
2567 try to fiddle with DECL_COMMON. However, on platforms that don't
2568 support global BSS sections, uninitialized global variables would
2569 go in DATA instead, thus increasing the size of the executable. */
2570 if (!flag_no_common
2571 && TREE_CODE (var_decl) == VAR_DECL
2572 && TREE_PUBLIC (var_decl)
2573 && !have_global_bss_p ())
2574 DECL_COMMON (var_decl) = 1;
2576 /* Do not emit debug info for a CONST_DECL if optimization isn't enabled,
2577 since we will create an associated variable. Likewise for an external
2578 constant whose initializer is not absolute, because this would mean a
2579 global relocation in a read-only section which runs afoul of the PE-COFF
2580 run-time relocation mechanism. */
2581 if (!debug_info_p
2582 || (TREE_CODE (var_decl) == CONST_DECL && !optimize)
2583 || (extern_flag
2584 && constant_p
2585 && init
2586 && initializer_constant_valid_p (init, TREE_TYPE (init))
2587 != null_pointer_node))
2588 DECL_IGNORED_P (var_decl) = 1;
2590 /* ??? Some attributes cannot be applied to CONST_DECLs. */
2591 if (TREE_CODE (var_decl) == VAR_DECL)
2592 process_attributes (&var_decl, &attr_list, true, gnat_node);
2594 /* Add this decl to the current binding level. */
2595 gnat_pushdecl (var_decl, gnat_node);
2597 if (TREE_CODE (var_decl) == VAR_DECL && asm_name)
2599 /* Let the target mangle the name if this isn't a verbatim asm. */
2600 if (*IDENTIFIER_POINTER (asm_name) != '*')
2601 asm_name = targetm.mangle_decl_assembler_name (var_decl, asm_name);
2603 SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
2606 return var_decl;
2609 /* Return true if TYPE, an aggregate type, contains (or is) an array. */
2611 static bool
2612 aggregate_type_contains_array_p (tree type)
2614 switch (TREE_CODE (type))
2616 case RECORD_TYPE:
2617 case UNION_TYPE:
2618 case QUAL_UNION_TYPE:
2620 tree field;
2621 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
2622 if (AGGREGATE_TYPE_P (TREE_TYPE (field))
2623 && aggregate_type_contains_array_p (TREE_TYPE (field)))
2624 return true;
2625 return false;
2628 case ARRAY_TYPE:
2629 return true;
2631 default:
2632 gcc_unreachable ();
2636 /* Return a FIELD_DECL node. NAME is the field's name, TYPE is its type and
2637 RECORD_TYPE is the type of the enclosing record. If SIZE is nonzero, it
2638 is the specified size of the field. If POS is nonzero, it is the bit
2639 position. PACKED is 1 if the enclosing record is packed, -1 if it has
2640 Component_Alignment of Storage_Unit. If ADDRESSABLE is nonzero, it
2641 means we are allowed to take the address of the field; if it is negative,
2642 we should not make a bitfield, which is used by make_aligning_type. */
2644 tree
2645 create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
2646 int packed, int addressable)
2648 tree field_decl = build_decl (input_location, FIELD_DECL, name, type);
2650 DECL_CONTEXT (field_decl) = record_type;
2651 TREE_READONLY (field_decl) = TYPE_READONLY (type);
2653 /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
2654 byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
2655 Likewise for an aggregate without specified position that contains an
2656 array, because in this case slices of variable length of this array
2657 must be handled by GCC and variable-sized objects need to be aligned
2658 to at least a byte boundary. */
2659 if (packed && (TYPE_MODE (type) == BLKmode
2660 || (!pos
2661 && AGGREGATE_TYPE_P (type)
2662 && aggregate_type_contains_array_p (type))))
2663 SET_DECL_ALIGN (field_decl, BITS_PER_UNIT);
2665 /* If a size is specified, use it. Otherwise, if the record type is packed
2666 compute a size to use, which may differ from the object's natural size.
2667 We always set a size in this case to trigger the checks for bitfield
2668 creation below, which is typically required when no position has been
2669 specified. */
2670 if (size)
2671 size = convert (bitsizetype, size);
2672 else if (packed == 1)
2674 size = rm_size (type);
2675 if (TYPE_MODE (type) == BLKmode)
2676 size = round_up (size, BITS_PER_UNIT);
2679 /* If we may, according to ADDRESSABLE, make a bitfield if a size is
2680 specified for two reasons: first if the size differs from the natural
2681 size. Second, if the alignment is insufficient. There are a number of
2682 ways the latter can be true.
2684 We never make a bitfield if the type of the field has a nonconstant size,
2685 because no such entity requiring bitfield operations should reach here.
2687 We do *preventively* make a bitfield when there might be the need for it
2688 but we don't have all the necessary information to decide, as is the case
2689 of a field with no specified position in a packed record.
2691 We also don't look at STRICT_ALIGNMENT here, and rely on later processing
2692 in layout_decl or finish_record_type to clear the bit_field indication if
2693 it is in fact not needed. */
2694 if (addressable >= 0
2695 && size
2696 && TREE_CODE (size) == INTEGER_CST
2697 && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST
2698 && (!tree_int_cst_equal (size, TYPE_SIZE (type))
2699 || (pos && !value_factor_p (pos, TYPE_ALIGN (type)))
2700 || packed
2701 || (TYPE_ALIGN (record_type) != 0
2702 && TYPE_ALIGN (record_type) < TYPE_ALIGN (type))))
2704 DECL_BIT_FIELD (field_decl) = 1;
2705 DECL_SIZE (field_decl) = size;
2706 if (!packed && !pos)
2708 if (TYPE_ALIGN (record_type) != 0
2709 && TYPE_ALIGN (record_type) < TYPE_ALIGN (type))
2710 SET_DECL_ALIGN (field_decl, TYPE_ALIGN (record_type));
2711 else
2712 SET_DECL_ALIGN (field_decl, TYPE_ALIGN (type));
2716 DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
2718 /* Bump the alignment if need be, either for bitfield/packing purposes or
2719 to satisfy the type requirements if no such consideration applies. When
2720 we get the alignment from the type, indicate if this is from an explicit
2721 user request, which prevents stor-layout from lowering it later on. */
2723 unsigned int bit_align
2724 = (DECL_BIT_FIELD (field_decl) ? 1
2725 : packed && TYPE_MODE (type) != BLKmode ? BITS_PER_UNIT : 0);
2727 if (bit_align > DECL_ALIGN (field_decl))
2728 SET_DECL_ALIGN (field_decl, bit_align);
2729 else if (!bit_align && TYPE_ALIGN (type) > DECL_ALIGN (field_decl))
2731 SET_DECL_ALIGN (field_decl, TYPE_ALIGN (type));
2732 DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (type);
2736 if (pos)
2738 /* We need to pass in the alignment the DECL is known to have.
2739 This is the lowest-order bit set in POS, but no more than
2740 the alignment of the record, if one is specified. Note
2741 that an alignment of 0 is taken as infinite. */
2742 unsigned int known_align;
2744 if (tree_fits_uhwi_p (pos))
2745 known_align = tree_to_uhwi (pos) & - tree_to_uhwi (pos);
2746 else
2747 known_align = BITS_PER_UNIT;
2749 if (TYPE_ALIGN (record_type)
2750 && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
2751 known_align = TYPE_ALIGN (record_type);
2753 layout_decl (field_decl, known_align);
2754 SET_DECL_OFFSET_ALIGN (field_decl,
2755 tree_fits_uhwi_p (pos) ? BIGGEST_ALIGNMENT
2756 : BITS_PER_UNIT);
2757 pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
2758 &DECL_FIELD_BIT_OFFSET (field_decl),
2759 DECL_OFFSET_ALIGN (field_decl), pos);
2762 /* In addition to what our caller says, claim the field is addressable if we
2763 know that its type is not suitable.
2765 The field may also be "technically" nonaddressable, meaning that even if
2766 we attempt to take the field's address we will actually get the address
2767 of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD
2768 value we have at this point is not accurate enough, so we don't account
2769 for this here and let finish_record_type decide. */
2770 if (!addressable && !type_for_nonaliased_component_p (type))
2771 addressable = 1;
2773 DECL_NONADDRESSABLE_P (field_decl) = !addressable;
2775 return field_decl;
2778 /* Return a PARM_DECL node with NAME and TYPE. */
2780 tree
2781 create_param_decl (tree name, tree type)
2783 tree param_decl = build_decl (input_location, PARM_DECL, name, type);
2785 /* Honor TARGET_PROMOTE_PROTOTYPES like the C compiler, as not doing so
2786 can lead to various ABI violations. */
2787 if (targetm.calls.promote_prototypes (NULL_TREE)
2788 && INTEGRAL_TYPE_P (type)
2789 && TYPE_PRECISION (type) < TYPE_PRECISION (integer_type_node))
2791 /* We have to be careful about biased types here. Make a subtype
2792 of integer_type_node with the proper biasing. */
2793 if (TREE_CODE (type) == INTEGER_TYPE
2794 && TYPE_BIASED_REPRESENTATION_P (type))
2796 tree subtype
2797 = make_unsigned_type (TYPE_PRECISION (integer_type_node));
2798 TREE_TYPE (subtype) = integer_type_node;
2799 TYPE_BIASED_REPRESENTATION_P (subtype) = 1;
2800 SET_TYPE_RM_MIN_VALUE (subtype, TYPE_MIN_VALUE (type));
2801 SET_TYPE_RM_MAX_VALUE (subtype, TYPE_MAX_VALUE (type));
2802 type = subtype;
2804 else
2805 type = integer_type_node;
2808 DECL_ARG_TYPE (param_decl) = type;
2809 return param_decl;
2812 /* Process the attributes in ATTR_LIST for NODE, which is either a DECL or
2813 a TYPE. If IN_PLACE is true, the tree pointed to by NODE should not be
2814 changed. GNAT_NODE is used for the position of error messages. */
2816 void
2817 process_attributes (tree *node, struct attrib **attr_list, bool in_place,
2818 Node_Id gnat_node)
2820 struct attrib *attr;
2822 for (attr = *attr_list; attr; attr = attr->next)
2823 switch (attr->type)
2825 case ATTR_MACHINE_ATTRIBUTE:
2826 Sloc_to_locus (Sloc (gnat_node), &input_location);
2827 decl_attributes (node, tree_cons (attr->name, attr->args, NULL_TREE),
2828 in_place ? ATTR_FLAG_TYPE_IN_PLACE : 0);
2829 break;
2831 case ATTR_LINK_ALIAS:
2832 if (!DECL_EXTERNAL (*node))
2834 TREE_STATIC (*node) = 1;
2835 assemble_alias (*node, attr->name);
2837 break;
2839 case ATTR_WEAK_EXTERNAL:
2840 if (SUPPORTS_WEAK)
2841 declare_weak (*node);
2842 else
2843 post_error ("?weak declarations not supported on this target",
2844 attr->error_point);
2845 break;
2847 case ATTR_LINK_SECTION:
2848 if (targetm_common.have_named_sections)
2850 set_decl_section_name (*node, IDENTIFIER_POINTER (attr->name));
2851 DECL_COMMON (*node) = 0;
2853 else
2854 post_error ("?section attributes are not supported for this target",
2855 attr->error_point);
2856 break;
2858 case ATTR_LINK_CONSTRUCTOR:
2859 DECL_STATIC_CONSTRUCTOR (*node) = 1;
2860 TREE_USED (*node) = 1;
2861 break;
2863 case ATTR_LINK_DESTRUCTOR:
2864 DECL_STATIC_DESTRUCTOR (*node) = 1;
2865 TREE_USED (*node) = 1;
2866 break;
2868 case ATTR_THREAD_LOCAL_STORAGE:
2869 set_decl_tls_model (*node, decl_default_tls_model (*node));
2870 DECL_COMMON (*node) = 0;
2871 break;
2874 *attr_list = NULL;
2877 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
2878 a power of 2. */
2880 bool
2881 value_factor_p (tree value, HOST_WIDE_INT factor)
2883 if (tree_fits_uhwi_p (value))
2884 return tree_to_uhwi (value) % factor == 0;
2886 if (TREE_CODE (value) == MULT_EXPR)
2887 return (value_factor_p (TREE_OPERAND (value, 0), factor)
2888 || value_factor_p (TREE_OPERAND (value, 1), factor));
2890 return false;
2893 /* Return whether GNAT_NODE is a defining identifier for a renaming that comes
2894 from the parameter association for the instantiation of a generic. We do
2895 not want to emit source location for them: the code generated for their
2896 initialization is likely to disturb debugging. */
2898 bool
2899 renaming_from_instantiation_p (Node_Id gnat_node)
2901 if (Nkind (gnat_node) != N_Defining_Identifier
2902 || !Is_Object (gnat_node)
2903 || Comes_From_Source (gnat_node)
2904 || !Present (Renamed_Object (gnat_node)))
2905 return false;
2907 /* Get the object declaration of the renamed object, if any and if the
2908 renamed object is a mere identifier. */
2909 gnat_node = Renamed_Object (gnat_node);
2910 if (Nkind (gnat_node) != N_Identifier)
2911 return false;
2913 gnat_node = Entity (gnat_node);
2914 if (!Present (Parent (gnat_node)))
2915 return false;
2917 gnat_node = Parent (gnat_node);
2918 return
2919 (Present (gnat_node)
2920 && Nkind (gnat_node) == N_Object_Declaration
2921 && Present (Corresponding_Generic_Association (gnat_node)));
2924 /* Defer the initialization of DECL's DECL_CONTEXT attribute, scheduling to
2925 feed it with the elaboration of GNAT_SCOPE. */
2927 static struct deferred_decl_context_node *
2928 add_deferred_decl_context (tree decl, Entity_Id gnat_scope, int force_global)
2930 struct deferred_decl_context_node *new_node;
2932 new_node
2933 = (struct deferred_decl_context_node * ) xmalloc (sizeof (*new_node));
2934 new_node->decl = decl;
2935 new_node->gnat_scope = gnat_scope;
2936 new_node->force_global = force_global;
2937 new_node->types.create (1);
2938 new_node->next = deferred_decl_context_queue;
2939 deferred_decl_context_queue = new_node;
2940 return new_node;
2943 /* Defer the initialization of TYPE's TYPE_CONTEXT attribute, scheduling to
2944 feed it with the DECL_CONTEXT computed as part of N as soon as it is
2945 computed. */
2947 static void
2948 add_deferred_type_context (struct deferred_decl_context_node *n, tree type)
2950 n->types.safe_push (type);
2953 /* Get the GENERIC node corresponding to GNAT_SCOPE, if available. Return
2954 NULL_TREE if it is not available. */
2956 static tree
2957 compute_deferred_decl_context (Entity_Id gnat_scope)
2959 tree context;
2961 if (present_gnu_tree (gnat_scope))
2962 context = get_gnu_tree (gnat_scope);
2963 else
2964 return NULL_TREE;
2966 if (TREE_CODE (context) == TYPE_DECL)
2968 const tree context_type = TREE_TYPE (context);
2970 /* Skip dummy types: only the final ones can appear in the context
2971 chain. */
2972 if (TYPE_DUMMY_P (context_type))
2973 return NULL_TREE;
2975 /* ..._TYPE nodes are more useful than TYPE_DECL nodes in the context
2976 chain. */
2977 else
2978 context = context_type;
2981 return context;
2984 /* Try to process all deferred nodes in the queue. Keep in the queue the ones
2985 that cannot be processed yet, remove the other ones. If FORCE is true,
2986 force the processing for all nodes, use the global context when nodes don't
2987 have a GNU translation. */
2989 void
2990 process_deferred_decl_context (bool force)
2992 struct deferred_decl_context_node **it = &deferred_decl_context_queue;
2993 struct deferred_decl_context_node *node;
2995 while (*it)
2997 bool processed = false;
2998 tree context = NULL_TREE;
2999 Entity_Id gnat_scope;
3001 node = *it;
3003 /* If FORCE, get the innermost elaborated scope. Otherwise, just try to
3004 get the first scope. */
3005 gnat_scope = node->gnat_scope;
3006 while (Present (gnat_scope))
3008 context = compute_deferred_decl_context (gnat_scope);
3009 if (!force || context)
3010 break;
3011 gnat_scope = get_debug_scope (gnat_scope, NULL);
3014 /* Imported declarations must not be in a local context (i.e. not inside
3015 a function). */
3016 if (context && node->force_global > 0)
3018 tree ctx = context;
3020 while (ctx)
3022 gcc_assert (TREE_CODE (ctx) != FUNCTION_DECL);
3023 ctx = DECL_P (ctx) ? DECL_CONTEXT (ctx) : TYPE_CONTEXT (ctx);
3027 /* If FORCE, we want to get rid of all nodes in the queue: in case there
3028 was no elaborated scope, use the global context. */
3029 if (force && !context)
3030 context = get_global_context ();
3032 if (context)
3034 tree t;
3035 int i;
3037 DECL_CONTEXT (node->decl) = context;
3039 /* Propagate it to the TYPE_CONTEXT attributes of the requested
3040 ..._TYPE nodes. */
3041 FOR_EACH_VEC_ELT (node->types, i, t)
3043 gnat_set_type_context (t, context);
3045 processed = true;
3048 /* If this node has been successfuly processed, remove it from the
3049 queue. Then move to the next node. */
3050 if (processed)
3052 *it = node->next;
3053 node->types.release ();
3054 free (node);
3056 else
3057 it = &node->next;
3061 /* Return VALUE scaled by the biggest power-of-2 factor of EXPR. */
3063 static unsigned int
3064 scale_by_factor_of (tree expr, unsigned int value)
3066 unsigned HOST_WIDE_INT addend = 0;
3067 unsigned HOST_WIDE_INT factor = 1;
3069 /* Peel conversions around EXPR and try to extract bodies from function
3070 calls: it is possible to get the scale factor from size functions. */
3071 expr = remove_conversions (expr, true);
3072 if (TREE_CODE (expr) == CALL_EXPR)
3073 expr = maybe_inline_call_in_expr (expr);
3075 /* Sometimes we get PLUS_EXPR (BIT_AND_EXPR (..., X), Y), where Y is a
3076 multiple of the scale factor we are looking for. */
3077 if (TREE_CODE (expr) == PLUS_EXPR
3078 && TREE_CODE (TREE_OPERAND (expr, 1)) == INTEGER_CST
3079 && tree_fits_uhwi_p (TREE_OPERAND (expr, 1)))
3081 addend = TREE_INT_CST_LOW (TREE_OPERAND (expr, 1));
3082 expr = TREE_OPERAND (expr, 0);
3085 /* An expression which is a bitwise AND with a mask has a power-of-2 factor
3086 corresponding to the number of trailing zeros of the mask. */
3087 if (TREE_CODE (expr) == BIT_AND_EXPR
3088 && TREE_CODE (TREE_OPERAND (expr, 1)) == INTEGER_CST)
3090 unsigned HOST_WIDE_INT mask = TREE_INT_CST_LOW (TREE_OPERAND (expr, 1));
3091 unsigned int i = 0;
3093 while ((mask & 1) == 0 && i < HOST_BITS_PER_WIDE_INT)
3095 mask >>= 1;
3096 factor *= 2;
3097 i++;
3101 /* If the addend is not a multiple of the factor we found, give up. In
3102 theory we could find a smaller common factor but it's useless for our
3103 needs. This situation arises when dealing with a field F1 with no
3104 alignment requirement but that is following a field F2 with such
3105 requirements. As long as we have F2's offset, we don't need alignment
3106 information to compute F1's. */
3107 if (addend % factor != 0)
3108 factor = 1;
3110 return factor * value;
3113 /* Given two consecutive field decls PREV_FIELD and CURR_FIELD, return true
3114 unless we can prove these 2 fields are laid out in such a way that no gap
3115 exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET
3116 is the distance in bits between the end of PREV_FIELD and the starting
3117 position of CURR_FIELD. It is ignored if null. */
3119 static bool
3120 potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
3122 /* If this is the first field of the record, there cannot be any gap */
3123 if (!prev_field)
3124 return false;
3126 /* If the previous field is a union type, then return false: The only
3127 time when such a field is not the last field of the record is when
3128 there are other components at fixed positions after it (meaning there
3129 was a rep clause for every field), in which case we don't want the
3130 alignment constraint to override them. */
3131 if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
3132 return false;
3134 /* If the distance between the end of prev_field and the beginning of
3135 curr_field is constant, then there is a gap if the value of this
3136 constant is not null. */
3137 if (offset && tree_fits_uhwi_p (offset))
3138 return !integer_zerop (offset);
3140 /* If the size and position of the previous field are constant,
3141 then check the sum of this size and position. There will be a gap
3142 iff it is not multiple of the current field alignment. */
3143 if (tree_fits_uhwi_p (DECL_SIZE (prev_field))
3144 && tree_fits_uhwi_p (bit_position (prev_field)))
3145 return ((tree_to_uhwi (bit_position (prev_field))
3146 + tree_to_uhwi (DECL_SIZE (prev_field)))
3147 % DECL_ALIGN (curr_field) != 0);
3149 /* If both the position and size of the previous field are multiples
3150 of the current field alignment, there cannot be any gap. */
3151 if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
3152 && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
3153 return false;
3155 /* Fallback, return that there may be a potential gap */
3156 return true;
3159 /* Return a LABEL_DECL with NAME. GNAT_NODE is used for the position of
3160 the decl. */
3162 tree
3163 create_label_decl (tree name, Node_Id gnat_node)
3165 tree label_decl
3166 = build_decl (input_location, LABEL_DECL, name, void_type_node);
3168 SET_DECL_MODE (label_decl, VOIDmode);
3170 /* Add this decl to the current binding level. */
3171 gnat_pushdecl (label_decl, gnat_node);
3173 return label_decl;
3176 /* Return a FUNCTION_DECL node. NAME is the name of the subprogram, ASM_NAME
3177 its assembler name, TYPE its type (a FUNCTION_TYPE node), PARAM_DECL_LIST
3178 the list of its parameters (a list of PARM_DECL nodes chained through the
3179 DECL_CHAIN field).
3181 INLINE_STATUS describes the inline flags to be set on the FUNCTION_DECL.
3183 PUBLIC_FLAG is true if this is for a reference to a public entity or for a
3184 definition to be made visible outside of the current compilation unit.
3186 EXTERN_FLAG is true when processing an external subprogram declaration.
3188 ARTIFICIAL_P is true if the subprogram was generated by the compiler.
3190 DEBUG_INFO_P is true if we need to write debug information for it.
3192 DEFINITION is true if the subprogram is to be considered as a definition.
3194 ATTR_LIST is the list of attributes to be attached to the subprogram.
3196 GNAT_NODE is used for the position of the decl. */
3198 tree
3199 create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
3200 enum inline_status_t inline_status, bool public_flag,
3201 bool extern_flag, bool artificial_p, bool debug_info_p,
3202 bool definition, struct attrib *attr_list,
3203 Node_Id gnat_node)
3205 tree subprog_decl = build_decl (input_location, FUNCTION_DECL, name, type);
3206 DECL_ARGUMENTS (subprog_decl) = param_decl_list;
3208 DECL_ARTIFICIAL (subprog_decl) = artificial_p;
3209 DECL_EXTERNAL (subprog_decl) = extern_flag;
3210 TREE_PUBLIC (subprog_decl) = public_flag;
3212 if (!debug_info_p)
3213 DECL_IGNORED_P (subprog_decl) = 1;
3214 if (definition)
3215 DECL_FUNCTION_IS_DEF (subprog_decl) = 1;
3217 switch (inline_status)
3219 case is_suppressed:
3220 DECL_UNINLINABLE (subprog_decl) = 1;
3221 break;
3223 case is_disabled:
3224 break;
3226 case is_required:
3227 if (Back_End_Inlining)
3229 decl_attributes (&subprog_decl,
3230 tree_cons (get_identifier ("always_inline"),
3231 NULL_TREE, NULL_TREE),
3232 ATTR_FLAG_TYPE_IN_PLACE);
3234 /* Inline_Always guarantees that every direct call is inlined and
3235 that there is no indirect reference to the subprogram, so the
3236 instance in the original package (as well as its clones in the
3237 client packages created for inter-unit inlining) can be made
3238 private, which causes the out-of-line body to be eliminated. */
3239 TREE_PUBLIC (subprog_decl) = 0;
3242 /* ... fall through ... */
3244 case is_enabled:
3245 DECL_DECLARED_INLINE_P (subprog_decl) = 1;
3246 DECL_NO_INLINE_WARNING_P (subprog_decl) = artificial_p;
3247 break;
3249 default:
3250 gcc_unreachable ();
3253 process_attributes (&subprog_decl, &attr_list, true, gnat_node);
3255 /* Once everything is processed, finish the subprogram declaration. */
3256 finish_subprog_decl (subprog_decl, asm_name, type);
3258 /* Add this decl to the current binding level. */
3259 gnat_pushdecl (subprog_decl, gnat_node);
3261 /* Output the assembler code and/or RTL for the declaration. */
3262 rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
3264 return subprog_decl;
3267 /* Given a subprogram declaration DECL, its assembler name and its type,
3268 finish constructing the subprogram declaration from ASM_NAME and TYPE. */
3270 void
3271 finish_subprog_decl (tree decl, tree asm_name, tree type)
3273 tree result_decl
3274 = build_decl (DECL_SOURCE_LOCATION (decl), RESULT_DECL, NULL_TREE,
3275 TREE_TYPE (type));
3277 DECL_ARTIFICIAL (result_decl) = 1;
3278 DECL_IGNORED_P (result_decl) = 1;
3279 DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (type);
3280 DECL_RESULT (decl) = result_decl;
3282 TREE_READONLY (decl) = TYPE_READONLY (type);
3283 TREE_SIDE_EFFECTS (decl) = TREE_THIS_VOLATILE (decl) = TYPE_VOLATILE (type);
3285 if (asm_name)
3287 /* Let the target mangle the name if this isn't a verbatim asm. */
3288 if (*IDENTIFIER_POINTER (asm_name) != '*')
3289 asm_name = targetm.mangle_decl_assembler_name (decl, asm_name);
3291 SET_DECL_ASSEMBLER_NAME (decl, asm_name);
3293 /* The expand_main_function circuitry expects "main_identifier_node" to
3294 designate the DECL_NAME of the 'main' entry point, in turn expected
3295 to be declared as the "main" function literally by default. Ada
3296 program entry points are typically declared with a different name
3297 within the binder generated file, exported as 'main' to satisfy the
3298 system expectations. Force main_identifier_node in this case. */
3299 if (asm_name == main_identifier_node)
3300 DECL_NAME (decl) = main_identifier_node;
3304 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
3305 body. This routine needs to be invoked before processing the declarations
3306 appearing in the subprogram. */
3308 void
3309 begin_subprog_body (tree subprog_decl)
3311 tree param_decl;
3313 announce_function (subprog_decl);
3315 /* This function is being defined. */
3316 TREE_STATIC (subprog_decl) = 1;
3318 /* The failure of this assertion will likely come from a wrong context for
3319 the subprogram body, e.g. another procedure for a procedure declared at
3320 library level. */
3321 gcc_assert (current_function_decl == decl_function_context (subprog_decl));
3323 current_function_decl = subprog_decl;
3325 /* Enter a new binding level and show that all the parameters belong to
3326 this function. */
3327 gnat_pushlevel ();
3329 for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
3330 param_decl = DECL_CHAIN (param_decl))
3331 DECL_CONTEXT (param_decl) = subprog_decl;
3333 make_decl_rtl (subprog_decl);
3336 /* Finish translating the current subprogram and set its BODY. */
3338 void
3339 end_subprog_body (tree body)
3341 tree fndecl = current_function_decl;
3343 /* Attach the BLOCK for this level to the function and pop the level. */
3344 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
3345 DECL_INITIAL (fndecl) = current_binding_level->block;
3346 gnat_poplevel ();
3348 /* Mark the RESULT_DECL as being in this subprogram. */
3349 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
3351 /* The body should be a BIND_EXPR whose BLOCK is the top-level one. */
3352 if (TREE_CODE (body) == BIND_EXPR)
3354 BLOCK_SUPERCONTEXT (BIND_EXPR_BLOCK (body)) = fndecl;
3355 DECL_INITIAL (fndecl) = BIND_EXPR_BLOCK (body);
3358 DECL_SAVED_TREE (fndecl) = body;
3360 current_function_decl = decl_function_context (fndecl);
3363 /* Wrap up compilation of SUBPROG_DECL, a subprogram body. */
3365 void
3366 rest_of_subprog_body_compilation (tree subprog_decl)
3368 /* We cannot track the location of errors past this point. */
3369 error_gnat_node = Empty;
3371 /* If we're only annotating types, don't actually compile this function. */
3372 if (type_annotate_only)
3373 return;
3375 /* Dump functions before gimplification. */
3376 dump_function (TDI_original, subprog_decl);
3378 if (!decl_function_context (subprog_decl))
3379 cgraph_node::finalize_function (subprog_decl, false);
3380 else
3381 /* Register this function with cgraph just far enough to get it
3382 added to our parent's nested function list. */
3383 (void) cgraph_node::get_create (subprog_decl);
3386 tree
3387 gnat_builtin_function (tree decl)
3389 gnat_pushdecl (decl, Empty);
3390 return decl;
3393 /* Return an integer type with the number of bits of precision given by
3394 PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
3395 it is a signed type. */
3397 tree
3398 gnat_type_for_size (unsigned precision, int unsignedp)
3400 tree t;
3401 char type_name[20];
3403 if (precision <= 2 * MAX_BITS_PER_WORD
3404 && signed_and_unsigned_types[precision][unsignedp])
3405 return signed_and_unsigned_types[precision][unsignedp];
3407 if (unsignedp)
3408 t = make_unsigned_type (precision);
3409 else
3410 t = make_signed_type (precision);
3411 TYPE_ARTIFICIAL (t) = 1;
3413 if (precision <= 2 * MAX_BITS_PER_WORD)
3414 signed_and_unsigned_types[precision][unsignedp] = t;
3416 if (!TYPE_NAME (t))
3418 sprintf (type_name, "%sSIGNED_%u", unsignedp ? "UN" : "", precision);
3419 TYPE_NAME (t) = get_identifier (type_name);
3422 return t;
3425 /* Likewise for floating-point types. */
3427 static tree
3428 float_type_for_precision (int precision, machine_mode mode)
3430 tree t;
3431 char type_name[20];
3433 if (float_types[(int) mode])
3434 return float_types[(int) mode];
3436 float_types[(int) mode] = t = make_node (REAL_TYPE);
3437 TYPE_PRECISION (t) = precision;
3438 layout_type (t);
3440 gcc_assert (TYPE_MODE (t) == mode);
3441 if (!TYPE_NAME (t))
3443 sprintf (type_name, "FLOAT_%d", precision);
3444 TYPE_NAME (t) = get_identifier (type_name);
3447 return t;
3450 /* Return a data type that has machine mode MODE. UNSIGNEDP selects
3451 an unsigned type; otherwise a signed type is returned. */
3453 tree
3454 gnat_type_for_mode (machine_mode mode, int unsignedp)
3456 if (mode == BLKmode)
3457 return NULL_TREE;
3459 if (mode == VOIDmode)
3460 return void_type_node;
3462 if (COMPLEX_MODE_P (mode))
3463 return NULL_TREE;
3465 scalar_float_mode float_mode;
3466 if (is_a <scalar_float_mode> (mode, &float_mode))
3467 return float_type_for_precision (GET_MODE_PRECISION (float_mode),
3468 float_mode);
3470 scalar_int_mode int_mode;
3471 if (is_a <scalar_int_mode> (mode, &int_mode))
3472 return gnat_type_for_size (GET_MODE_BITSIZE (int_mode), unsignedp);
3474 if (VECTOR_MODE_P (mode))
3476 machine_mode inner_mode = GET_MODE_INNER (mode);
3477 tree inner_type = gnat_type_for_mode (inner_mode, unsignedp);
3478 if (inner_type)
3479 return build_vector_type_for_mode (inner_type, mode);
3482 return NULL_TREE;
3485 /* Return the signed or unsigned version of TYPE_NODE, a scalar type, the
3486 signedness being specified by UNSIGNEDP. */
3488 tree
3489 gnat_signed_or_unsigned_type_for (int unsignedp, tree type_node)
3491 if (type_node == char_type_node)
3492 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
3494 tree type = gnat_type_for_size (TYPE_PRECISION (type_node), unsignedp);
3496 if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
3498 type = copy_type (type);
3499 TREE_TYPE (type) = type_node;
3501 else if (TREE_TYPE (type_node)
3502 && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
3503 && TYPE_MODULAR_P (TREE_TYPE (type_node)))
3505 type = copy_type (type);
3506 TREE_TYPE (type) = TREE_TYPE (type_node);
3509 return type;
3512 /* Return 1 if the types T1 and T2 are compatible, i.e. if they can be
3513 transparently converted to each other. */
3516 gnat_types_compatible_p (tree t1, tree t2)
3518 enum tree_code code;
3520 /* This is the default criterion. */
3521 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
3522 return 1;
3524 /* We only check structural equivalence here. */
3525 if ((code = TREE_CODE (t1)) != TREE_CODE (t2))
3526 return 0;
3528 /* Vector types are also compatible if they have the same number of subparts
3529 and the same form of (scalar) element type. */
3530 if (code == VECTOR_TYPE
3531 && TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2)
3532 && TREE_CODE (TREE_TYPE (t1)) == TREE_CODE (TREE_TYPE (t2))
3533 && TYPE_PRECISION (TREE_TYPE (t1)) == TYPE_PRECISION (TREE_TYPE (t2)))
3534 return 1;
3536 /* Array types are also compatible if they are constrained and have the same
3537 domain(s), the same component type and the same scalar storage order. */
3538 if (code == ARRAY_TYPE
3539 && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2)
3540 || (TYPE_DOMAIN (t1)
3541 && TYPE_DOMAIN (t2)
3542 && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)),
3543 TYPE_MIN_VALUE (TYPE_DOMAIN (t2)))
3544 && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)),
3545 TYPE_MAX_VALUE (TYPE_DOMAIN (t2)))))
3546 && (TREE_TYPE (t1) == TREE_TYPE (t2)
3547 || (TREE_CODE (TREE_TYPE (t1)) == ARRAY_TYPE
3548 && gnat_types_compatible_p (TREE_TYPE (t1), TREE_TYPE (t2))))
3549 && TYPE_REVERSE_STORAGE_ORDER (t1) == TYPE_REVERSE_STORAGE_ORDER (t2))
3550 return 1;
3552 return 0;
3555 /* Return true if EXPR is a useless type conversion. */
3557 bool
3558 gnat_useless_type_conversion (tree expr)
3560 if (CONVERT_EXPR_P (expr)
3561 || TREE_CODE (expr) == VIEW_CONVERT_EXPR
3562 || TREE_CODE (expr) == NON_LVALUE_EXPR)
3563 return gnat_types_compatible_p (TREE_TYPE (expr),
3564 TREE_TYPE (TREE_OPERAND (expr, 0)));
3566 return false;
3569 /* Return true if T, a FUNCTION_TYPE, has the specified list of flags. */
3571 bool
3572 fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p,
3573 bool return_by_direct_ref_p, bool return_by_invisi_ref_p)
3575 return TYPE_CI_CO_LIST (t) == cico_list
3576 && TYPE_RETURN_UNCONSTRAINED_P (t) == return_unconstrained_p
3577 && TYPE_RETURN_BY_DIRECT_REF_P (t) == return_by_direct_ref_p
3578 && TREE_ADDRESSABLE (t) == return_by_invisi_ref_p;
3581 /* EXP is an expression for the size of an object. If this size contains
3582 discriminant references, replace them with the maximum (if MAX_P) or
3583 minimum (if !MAX_P) possible value of the discriminant. */
3585 tree
3586 max_size (tree exp, bool max_p)
3588 enum tree_code code = TREE_CODE (exp);
3589 tree type = TREE_TYPE (exp);
3590 tree op0, op1, op2;
3592 switch (TREE_CODE_CLASS (code))
3594 case tcc_declaration:
3595 case tcc_constant:
3596 return exp;
3598 case tcc_exceptional:
3599 gcc_assert (code == SSA_NAME);
3600 return exp;
3602 case tcc_vl_exp:
3603 if (code == CALL_EXPR)
3605 tree t, *argarray;
3606 int n, i;
3608 t = maybe_inline_call_in_expr (exp);
3609 if (t)
3610 return max_size (t, max_p);
3612 n = call_expr_nargs (exp);
3613 gcc_assert (n > 0);
3614 argarray = XALLOCAVEC (tree, n);
3615 for (i = 0; i < n; i++)
3616 argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p);
3617 return build_call_array (type, CALL_EXPR_FN (exp), n, argarray);
3619 break;
3621 case tcc_reference:
3622 /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
3623 modify. Otherwise, we treat it like a variable. */
3624 if (CONTAINS_PLACEHOLDER_P (exp))
3626 tree val_type = TREE_TYPE (TREE_OPERAND (exp, 1));
3627 tree val = (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
3628 return
3629 convert (type,
3630 max_size (convert (get_base_type (val_type), val), true));
3633 return exp;
3635 case tcc_comparison:
3636 return build_int_cst (type, max_p ? 1 : 0);
3638 case tcc_unary:
3639 if (code == NON_LVALUE_EXPR)
3640 return max_size (TREE_OPERAND (exp, 0), max_p);
3642 op0 = max_size (TREE_OPERAND (exp, 0),
3643 code == NEGATE_EXPR ? !max_p : max_p);
3645 if (op0 == TREE_OPERAND (exp, 0))
3646 return exp;
3648 return fold_build1 (code, type, op0);
3650 case tcc_binary:
3652 tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
3653 tree rhs = max_size (TREE_OPERAND (exp, 1),
3654 code == MINUS_EXPR ? !max_p : max_p);
3656 /* Special-case wanting the maximum value of a MIN_EXPR.
3657 In that case, if one side overflows, return the other. */
3658 if (max_p && code == MIN_EXPR)
3660 if (TREE_CODE (rhs) == INTEGER_CST && TREE_OVERFLOW (rhs))
3661 return lhs;
3663 if (TREE_CODE (lhs) == INTEGER_CST && TREE_OVERFLOW (lhs))
3664 return rhs;
3667 /* Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
3668 overflowing and the RHS a variable. */
3669 if ((code == MINUS_EXPR || code == PLUS_EXPR)
3670 && TREE_CODE (lhs) == INTEGER_CST
3671 && TREE_OVERFLOW (lhs)
3672 && TREE_CODE (rhs) != INTEGER_CST)
3673 return lhs;
3675 /* If we are going to subtract a "negative" value in an unsigned type,
3676 do the operation as an addition of the negated value, in order to
3677 avoid creating a spurious overflow below. */
3678 if (code == MINUS_EXPR
3679 && TYPE_UNSIGNED (type)
3680 && TREE_CODE (rhs) == INTEGER_CST
3681 && !TREE_OVERFLOW (rhs)
3682 && tree_int_cst_sign_bit (rhs) != 0)
3684 rhs = fold_build1 (NEGATE_EXPR, type, rhs);
3685 code = PLUS_EXPR;
3688 if (lhs == TREE_OPERAND (exp, 0) && rhs == TREE_OPERAND (exp, 1))
3689 return exp;
3691 /* We need to detect overflows so we call size_binop here. */
3692 return size_binop (code, lhs, rhs);
3695 case tcc_expression:
3696 switch (TREE_CODE_LENGTH (code))
3698 case 1:
3699 if (code == SAVE_EXPR)
3700 return exp;
3702 op0 = max_size (TREE_OPERAND (exp, 0),
3703 code == TRUTH_NOT_EXPR ? !max_p : max_p);
3705 if (op0 == TREE_OPERAND (exp, 0))
3706 return exp;
3708 return fold_build1 (code, type, op0);
3710 case 2:
3711 if (code == COMPOUND_EXPR)
3712 return max_size (TREE_OPERAND (exp, 1), max_p);
3714 op0 = max_size (TREE_OPERAND (exp, 0), max_p);
3715 op1 = max_size (TREE_OPERAND (exp, 1), max_p);
3717 if (op0 == TREE_OPERAND (exp, 0) && op1 == TREE_OPERAND (exp, 1))
3718 return exp;
3720 return fold_build2 (code, type, op0, op1);
3722 case 3:
3723 if (code == COND_EXPR)
3725 op1 = TREE_OPERAND (exp, 1);
3726 op2 = TREE_OPERAND (exp, 2);
3728 if (!op1 || !op2)
3729 return exp;
3731 return
3732 fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
3733 max_size (op1, max_p), max_size (op2, max_p));
3735 break;
3737 default:
3738 break;
3741 /* Other tree classes cannot happen. */
3742 default:
3743 break;
3746 gcc_unreachable ();
3749 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
3750 EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
3751 Return a constructor for the template. */
3753 tree
3754 build_template (tree template_type, tree array_type, tree expr)
3756 vec<constructor_elt, va_gc> *template_elts = NULL;
3757 tree bound_list = NULL_TREE;
3758 tree field;
3760 while (TREE_CODE (array_type) == RECORD_TYPE
3761 && (TYPE_PADDING_P (array_type)
3762 || TYPE_JUSTIFIED_MODULAR_P (array_type)))
3763 array_type = TREE_TYPE (TYPE_FIELDS (array_type));
3765 if (TREE_CODE (array_type) == ARRAY_TYPE
3766 || (TREE_CODE (array_type) == INTEGER_TYPE
3767 && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
3768 bound_list = TYPE_ACTUAL_BOUNDS (array_type);
3770 /* First make the list for a CONSTRUCTOR for the template. Go down the
3771 field list of the template instead of the type chain because this
3772 array might be an Ada array of arrays and we can't tell where the
3773 nested arrays stop being the underlying object. */
3775 for (field = TYPE_FIELDS (template_type); field;
3776 (bound_list
3777 ? (bound_list = TREE_CHAIN (bound_list))
3778 : (array_type = TREE_TYPE (array_type))),
3779 field = DECL_CHAIN (DECL_CHAIN (field)))
3781 tree bounds, min, max;
3783 /* If we have a bound list, get the bounds from there. Likewise
3784 for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
3785 DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
3786 This will give us a maximum range. */
3787 if (bound_list)
3788 bounds = TREE_VALUE (bound_list);
3789 else if (TREE_CODE (array_type) == ARRAY_TYPE)
3790 bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
3791 else if (expr && TREE_CODE (expr) == PARM_DECL
3792 && DECL_BY_COMPONENT_PTR_P (expr))
3793 bounds = TREE_TYPE (field);
3794 else
3795 gcc_unreachable ();
3797 min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds));
3798 max = convert (TREE_TYPE (DECL_CHAIN (field)), TYPE_MAX_VALUE (bounds));
3800 /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
3801 substitute it from OBJECT. */
3802 min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr);
3803 max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr);
3805 CONSTRUCTOR_APPEND_ELT (template_elts, field, min);
3806 CONSTRUCTOR_APPEND_ELT (template_elts, DECL_CHAIN (field), max);
3809 return gnat_build_constructor (template_type, template_elts);
3812 /* Return true if TYPE is suitable for the element type of a vector. */
3814 static bool
3815 type_for_vector_element_p (tree type)
3817 machine_mode mode;
3819 if (!INTEGRAL_TYPE_P (type)
3820 && !SCALAR_FLOAT_TYPE_P (type)
3821 && !FIXED_POINT_TYPE_P (type))
3822 return false;
3824 mode = TYPE_MODE (type);
3825 if (GET_MODE_CLASS (mode) != MODE_INT
3826 && !SCALAR_FLOAT_MODE_P (mode)
3827 && !ALL_SCALAR_FIXED_POINT_MODE_P (mode))
3828 return false;
3830 return true;
3833 /* Return a vector type given the SIZE and the INNER_TYPE, or NULL_TREE if
3834 this is not possible. If ATTRIBUTE is non-zero, we are processing the
3835 attribute declaration and want to issue error messages on failure. */
3837 static tree
3838 build_vector_type_for_size (tree inner_type, tree size, tree attribute)
3840 unsigned HOST_WIDE_INT size_int, inner_size_int;
3841 int nunits;
3843 /* Silently punt on variable sizes. We can't make vector types for them,
3844 need to ignore them on front-end generated subtypes of unconstrained
3845 base types, and this attribute is for binding implementors, not end
3846 users, so we should never get there from legitimate explicit uses. */
3847 if (!tree_fits_uhwi_p (size))
3848 return NULL_TREE;
3849 size_int = tree_to_uhwi (size);
3851 if (!type_for_vector_element_p (inner_type))
3853 if (attribute)
3854 error ("invalid element type for attribute %qs",
3855 IDENTIFIER_POINTER (attribute));
3856 return NULL_TREE;
3858 inner_size_int = tree_to_uhwi (TYPE_SIZE_UNIT (inner_type));
3860 if (size_int % inner_size_int)
3862 if (attribute)
3863 error ("vector size not an integral multiple of component size");
3864 return NULL_TREE;
3867 if (size_int == 0)
3869 if (attribute)
3870 error ("zero vector size");
3871 return NULL_TREE;
3874 nunits = size_int / inner_size_int;
3875 if (nunits & (nunits - 1))
3877 if (attribute)
3878 error ("number of components of vector not a power of two");
3879 return NULL_TREE;
3882 return build_vector_type (inner_type, nunits);
3885 /* Return a vector type whose representative array type is ARRAY_TYPE, or
3886 NULL_TREE if this is not possible. If ATTRIBUTE is non-zero, we are
3887 processing the attribute and want to issue error messages on failure. */
3889 static tree
3890 build_vector_type_for_array (tree array_type, tree attribute)
3892 tree vector_type = build_vector_type_for_size (TREE_TYPE (array_type),
3893 TYPE_SIZE_UNIT (array_type),
3894 attribute);
3895 if (!vector_type)
3896 return NULL_TREE;
3898 TYPE_REPRESENTATIVE_ARRAY (vector_type) = array_type;
3899 return vector_type;
3902 /* Build a type to be used to represent an aliased object whose nominal type
3903 is an unconstrained array. This consists of a RECORD_TYPE containing a
3904 field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE.
3905 If ARRAY_TYPE is that of an unconstrained array, this is used to represent
3906 an arbitrary unconstrained object. Use NAME as the name of the record.
3907 DEBUG_INFO_P is true if we need to write debug information for the type. */
3909 tree
3910 build_unc_object_type (tree template_type, tree object_type, tree name,
3911 bool debug_info_p)
3913 tree decl;
3914 tree type = make_node (RECORD_TYPE);
3915 tree template_field
3916 = create_field_decl (get_identifier ("BOUNDS"), template_type, type,
3917 NULL_TREE, NULL_TREE, 0, 1);
3918 tree array_field
3919 = create_field_decl (get_identifier ("ARRAY"), object_type, type,
3920 NULL_TREE, NULL_TREE, 0, 1);
3922 TYPE_NAME (type) = name;
3923 TYPE_CONTAINS_TEMPLATE_P (type) = 1;
3924 DECL_CHAIN (template_field) = array_field;
3925 finish_record_type (type, template_field, 0, true);
3927 /* Declare it now since it will never be declared otherwise. This is
3928 necessary to ensure that its subtrees are properly marked. */
3929 decl = create_type_decl (name, type, true, debug_info_p, Empty);
3931 /* template_type will not be used elsewhere than here, so to keep the debug
3932 info clean and in order to avoid scoping issues, make decl its
3933 context. */
3934 gnat_set_type_context (template_type, decl);
3936 return type;
3939 /* Same, taking a thin or fat pointer type instead of a template type. */
3941 tree
3942 build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
3943 tree name, bool debug_info_p)
3945 tree template_type;
3947 gcc_assert (TYPE_IS_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
3949 template_type
3950 = (TYPE_IS_FAT_POINTER_P (thin_fat_ptr_type)
3951 ? TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (thin_fat_ptr_type))))
3952 : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type))));
3954 return
3955 build_unc_object_type (template_type, object_type, name, debug_info_p);
3958 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.
3959 In the normal case this is just two adjustments, but we have more to
3960 do if NEW_TYPE is an UNCONSTRAINED_ARRAY_TYPE. */
3962 void
3963 update_pointer_to (tree old_type, tree new_type)
3965 tree ptr = TYPE_POINTER_TO (old_type);
3966 tree ref = TYPE_REFERENCE_TO (old_type);
3967 tree t;
3969 /* If this is the main variant, process all the other variants first. */
3970 if (TYPE_MAIN_VARIANT (old_type) == old_type)
3971 for (t = TYPE_NEXT_VARIANT (old_type); t; t = TYPE_NEXT_VARIANT (t))
3972 update_pointer_to (t, new_type);
3974 /* If no pointers and no references, we are done. */
3975 if (!ptr && !ref)
3976 return;
3978 /* Merge the old type qualifiers in the new type.
3980 Each old variant has qualifiers for specific reasons, and the new
3981 designated type as well. Each set of qualifiers represents useful
3982 information grabbed at some point, and merging the two simply unifies
3983 these inputs into the final type description.
3985 Consider for instance a volatile type frozen after an access to constant
3986 type designating it; after the designated type's freeze, we get here with
3987 a volatile NEW_TYPE and a dummy OLD_TYPE with a readonly variant, created
3988 when the access type was processed. We will make a volatile and readonly
3989 designated type, because that's what it really is.
3991 We might also get here for a non-dummy OLD_TYPE variant with different
3992 qualifiers than those of NEW_TYPE, for instance in some cases of pointers
3993 to private record type elaboration (see the comments around the call to
3994 this routine in gnat_to_gnu_entity <E_Access_Type>). We have to merge
3995 the qualifiers in those cases too, to avoid accidentally discarding the
3996 initial set, and will often end up with OLD_TYPE == NEW_TYPE then. */
3997 new_type
3998 = build_qualified_type (new_type,
3999 TYPE_QUALS (old_type) | TYPE_QUALS (new_type));
4001 /* If old type and new type are identical, there is nothing to do. */
4002 if (old_type == new_type)
4003 return;
4005 /* Otherwise, first handle the simple case. */
4006 if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
4008 tree new_ptr, new_ref;
4010 /* If pointer or reference already points to new type, nothing to do.
4011 This can happen as update_pointer_to can be invoked multiple times
4012 on the same couple of types because of the type variants. */
4013 if ((ptr && TREE_TYPE (ptr) == new_type)
4014 || (ref && TREE_TYPE (ref) == new_type))
4015 return;
4017 /* Chain PTR and its variants at the end. */
4018 new_ptr = TYPE_POINTER_TO (new_type);
4019 if (new_ptr)
4021 while (TYPE_NEXT_PTR_TO (new_ptr))
4022 new_ptr = TYPE_NEXT_PTR_TO (new_ptr);
4023 TYPE_NEXT_PTR_TO (new_ptr) = ptr;
4025 else
4026 TYPE_POINTER_TO (new_type) = ptr;
4028 /* Now adjust them. */
4029 for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr))
4030 for (t = TYPE_MAIN_VARIANT (ptr); t; t = TYPE_NEXT_VARIANT (t))
4032 TREE_TYPE (t) = new_type;
4033 if (TYPE_NULL_BOUNDS (t))
4034 TREE_TYPE (TREE_OPERAND (TYPE_NULL_BOUNDS (t), 0)) = new_type;
4037 /* Chain REF and its variants at the end. */
4038 new_ref = TYPE_REFERENCE_TO (new_type);
4039 if (new_ref)
4041 while (TYPE_NEXT_REF_TO (new_ref))
4042 new_ref = TYPE_NEXT_REF_TO (new_ref);
4043 TYPE_NEXT_REF_TO (new_ref) = ref;
4045 else
4046 TYPE_REFERENCE_TO (new_type) = ref;
4048 /* Now adjust them. */
4049 for (; ref; ref = TYPE_NEXT_REF_TO (ref))
4050 for (t = TYPE_MAIN_VARIANT (ref); t; t = TYPE_NEXT_VARIANT (t))
4051 TREE_TYPE (t) = new_type;
4053 TYPE_POINTER_TO (old_type) = NULL_TREE;
4054 TYPE_REFERENCE_TO (old_type) = NULL_TREE;
4057 /* Now deal with the unconstrained array case. In this case the pointer
4058 is actually a record where both fields are pointers to dummy nodes.
4059 Turn them into pointers to the correct types using update_pointer_to.
4060 Likewise for the pointer to the object record (thin pointer). */
4061 else
4063 tree new_ptr = TYPE_POINTER_TO (new_type);
4065 gcc_assert (TYPE_IS_FAT_POINTER_P (ptr));
4067 /* If PTR already points to NEW_TYPE, nothing to do. This can happen
4068 since update_pointer_to can be invoked multiple times on the same
4069 couple of types because of the type variants. */
4070 if (TYPE_UNCONSTRAINED_ARRAY (ptr) == new_type)
4071 return;
4073 update_pointer_to
4074 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
4075 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr))));
4077 update_pointer_to
4078 (TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (ptr)))),
4079 TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (new_ptr)))));
4081 update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type),
4082 TYPE_OBJECT_RECORD_TYPE (new_type));
4084 TYPE_POINTER_TO (old_type) = NULL_TREE;
4085 TYPE_REFERENCE_TO (old_type) = NULL_TREE;
4089 /* Convert EXPR, a pointer to a constrained array, into a pointer to an
4090 unconstrained one. This involves making or finding a template. */
4092 static tree
4093 convert_to_fat_pointer (tree type, tree expr)
4095 tree template_type = TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))));
4096 tree p_array_type = TREE_TYPE (TYPE_FIELDS (type));
4097 tree etype = TREE_TYPE (expr);
4098 tree template_addr;
4099 vec<constructor_elt, va_gc> *v;
4100 vec_alloc (v, 2);
4102 /* If EXPR is null, make a fat pointer that contains a null pointer to the
4103 array (compare_fat_pointers ensures that this is the full discriminant)
4104 and a valid pointer to the bounds. This latter property is necessary
4105 since the compiler can hoist the load of the bounds done through it. */
4106 if (integer_zerop (expr))
4108 tree ptr_template_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)));
4109 tree null_bounds, t;
4111 if (TYPE_NULL_BOUNDS (ptr_template_type))
4112 null_bounds = TYPE_NULL_BOUNDS (ptr_template_type);
4113 else
4115 /* The template type can still be dummy at this point so we build an
4116 empty constructor. The middle-end will fill it in with zeros. */
4117 t = build_constructor (template_type, NULL);
4118 TREE_CONSTANT (t) = TREE_STATIC (t) = 1;
4119 null_bounds = build_unary_op (ADDR_EXPR, NULL_TREE, t);
4120 SET_TYPE_NULL_BOUNDS (ptr_template_type, null_bounds);
4123 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
4124 fold_convert (p_array_type, null_pointer_node));
4125 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), null_bounds);
4126 t = build_constructor (type, v);
4127 /* Do not set TREE_CONSTANT so as to force T to static memory. */
4128 TREE_CONSTANT (t) = 0;
4129 TREE_STATIC (t) = 1;
4131 return t;
4134 /* If EXPR is a thin pointer, make template and data from the record. */
4135 if (TYPE_IS_THIN_POINTER_P (etype))
4137 tree field = TYPE_FIELDS (TREE_TYPE (etype));
4139 expr = gnat_protect_expr (expr);
4141 /* If we have a TYPE_UNCONSTRAINED_ARRAY attached to the RECORD_TYPE,
4142 the thin pointer value has been shifted so we shift it back to get
4143 the template address. */
4144 if (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (etype)))
4146 template_addr
4147 = build_binary_op (POINTER_PLUS_EXPR, etype, expr,
4148 fold_build1 (NEGATE_EXPR, sizetype,
4149 byte_position
4150 (DECL_CHAIN (field))));
4151 template_addr
4152 = fold_convert (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))),
4153 template_addr);
4156 /* Otherwise we explicitly take the address of the fields. */
4157 else
4159 expr = build_unary_op (INDIRECT_REF, NULL_TREE, expr);
4160 template_addr
4161 = build_unary_op (ADDR_EXPR, NULL_TREE,
4162 build_component_ref (expr, field, false));
4163 expr = build_unary_op (ADDR_EXPR, NULL_TREE,
4164 build_component_ref (expr, DECL_CHAIN (field),
4165 false));
4169 /* Otherwise, build the constructor for the template. */
4170 else
4171 template_addr
4172 = build_unary_op (ADDR_EXPR, NULL_TREE,
4173 build_template (template_type, TREE_TYPE (etype),
4174 expr));
4176 /* The final result is a constructor for the fat pointer.
4178 If EXPR is an argument of a foreign convention subprogram, the type it
4179 points to is directly the component type. In this case, the expression
4180 type may not match the corresponding FIELD_DECL type at this point, so we
4181 call "convert" here to fix that up if necessary. This type consistency is
4182 required, for instance because it ensures that possible later folding of
4183 COMPONENT_REFs against this constructor always yields something of the
4184 same type as the initial reference.
4186 Note that the call to "build_template" above is still fine because it
4187 will only refer to the provided TEMPLATE_TYPE in this case. */
4188 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), convert (p_array_type, expr));
4189 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), template_addr);
4190 return gnat_build_constructor (type, v);
4193 /* Create an expression whose value is that of EXPR,
4194 converted to type TYPE. The TREE_TYPE of the value
4195 is always TYPE. This function implements all reasonable
4196 conversions; callers should filter out those that are
4197 not permitted by the language being compiled. */
4199 tree
4200 convert (tree type, tree expr)
4202 tree etype = TREE_TYPE (expr);
4203 enum tree_code ecode = TREE_CODE (etype);
4204 enum tree_code code = TREE_CODE (type);
4206 /* If the expression is already of the right type, we are done. */
4207 if (etype == type)
4208 return expr;
4210 /* If both input and output have padding and are of variable size, do this
4211 as an unchecked conversion. Likewise if one is a mere variant of the
4212 other, so we avoid a pointless unpad/repad sequence. */
4213 else if (code == RECORD_TYPE && ecode == RECORD_TYPE
4214 && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype)
4215 && (!TREE_CONSTANT (TYPE_SIZE (type))
4216 || !TREE_CONSTANT (TYPE_SIZE (etype))
4217 || TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
4218 || TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type)))
4219 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (etype)))))
4222 /* If the output type has padding, convert to the inner type and make a
4223 constructor to build the record, unless a variable size is involved. */
4224 else if (code == RECORD_TYPE && TYPE_PADDING_P (type))
4226 /* If we previously converted from another type and our type is
4227 of variable size, remove the conversion to avoid the need for
4228 variable-sized temporaries. Likewise for a conversion between
4229 original and packable version. */
4230 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
4231 && (!TREE_CONSTANT (TYPE_SIZE (type))
4232 || (ecode == RECORD_TYPE
4233 && TYPE_NAME (etype)
4234 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (expr, 0))))))
4235 expr = TREE_OPERAND (expr, 0);
4237 /* If we are just removing the padding from expr, convert the original
4238 object if we have variable size in order to avoid the need for some
4239 variable-sized temporaries. Likewise if the padding is a variant
4240 of the other, so we avoid a pointless unpad/repad sequence. */
4241 if (TREE_CODE (expr) == COMPONENT_REF
4242 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
4243 && (!TREE_CONSTANT (TYPE_SIZE (type))
4244 || TYPE_MAIN_VARIANT (type)
4245 == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (expr, 0)))
4246 || (ecode == RECORD_TYPE
4247 && TYPE_NAME (etype)
4248 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type))))))
4249 return convert (type, TREE_OPERAND (expr, 0));
4251 /* If the inner type is of self-referential size and the expression type
4252 is a record, do this as an unchecked conversion. But first pad the
4253 expression if possible to have the same size on both sides. */
4254 if (ecode == RECORD_TYPE
4255 && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
4257 if (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST)
4258 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
4259 false, false, false, true),
4260 expr);
4261 return unchecked_convert (type, expr, false);
4264 /* If we are converting between array types with variable size, do the
4265 final conversion as an unchecked conversion, again to avoid the need
4266 for some variable-sized temporaries. If valid, this conversion is
4267 very likely purely technical and without real effects. */
4268 if (ecode == ARRAY_TYPE
4269 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == ARRAY_TYPE
4270 && !TREE_CONSTANT (TYPE_SIZE (etype))
4271 && !TREE_CONSTANT (TYPE_SIZE (type)))
4272 return unchecked_convert (type,
4273 convert (TREE_TYPE (TYPE_FIELDS (type)),
4274 expr),
4275 false);
4277 tree t = convert (TREE_TYPE (TYPE_FIELDS (type)), expr);
4279 /* If converting to the inner type has already created a CONSTRUCTOR with
4280 the right size, then reuse it instead of creating another one. This
4281 can happen for the padding type built to overalign local variables. */
4282 if (TREE_CODE (t) == VIEW_CONVERT_EXPR
4283 && TREE_CODE (TREE_OPERAND (t, 0)) == CONSTRUCTOR
4284 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (t, 0))))
4285 && tree_int_cst_equal (TYPE_SIZE (type),
4286 TYPE_SIZE (TREE_TYPE (TREE_OPERAND (t, 0)))))
4287 return build1 (VIEW_CONVERT_EXPR, type, TREE_OPERAND (t, 0));
4289 vec<constructor_elt, va_gc> *v;
4290 vec_alloc (v, 1);
4291 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), t);
4292 return gnat_build_constructor (type, v);
4295 /* If the input type has padding, remove it and convert to the output type.
4296 The conditions ordering is arranged to ensure that the output type is not
4297 a padding type here, as it is not clear whether the conversion would
4298 always be correct if this was to happen. */
4299 else if (ecode == RECORD_TYPE && TYPE_PADDING_P (etype))
4301 tree unpadded;
4303 /* If we have just converted to this padded type, just get the
4304 inner expression. */
4305 if (TREE_CODE (expr) == CONSTRUCTOR)
4306 unpadded = CONSTRUCTOR_ELT (expr, 0)->value;
4308 /* Otherwise, build an explicit component reference. */
4309 else
4310 unpadded = build_component_ref (expr, TYPE_FIELDS (etype), false);
4312 return convert (type, unpadded);
4315 /* If the input is a biased type, convert first to the base type and add
4316 the bias. Note that the bias must go through a full conversion to the
4317 base type, lest it is itself a biased value; this happens for subtypes
4318 of biased types. */
4319 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
4320 return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype),
4321 fold_convert (TREE_TYPE (etype), expr),
4322 convert (TREE_TYPE (etype),
4323 TYPE_MIN_VALUE (etype))));
4325 /* If the input is a justified modular type, we need to extract the actual
4326 object before converting it to any other type with the exceptions of an
4327 unconstrained array or of a mere type variant. It is useful to avoid the
4328 extraction and conversion in the type variant case because it could end
4329 up replacing a VAR_DECL expr by a constructor and we might be about the
4330 take the address of the result. */
4331 if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
4332 && code != UNCONSTRAINED_ARRAY_TYPE
4333 && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype))
4334 return
4335 convert (type, build_component_ref (expr, TYPE_FIELDS (etype), false));
4337 /* If converting to a type that contains a template, convert to the data
4338 type and then build the template. */
4339 if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type))
4341 tree obj_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)));
4342 vec<constructor_elt, va_gc> *v;
4343 vec_alloc (v, 2);
4345 /* If the source already has a template, get a reference to the
4346 associated array only, as we are going to rebuild a template
4347 for the target type anyway. */
4348 expr = maybe_unconstrained_array (expr);
4350 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
4351 build_template (TREE_TYPE (TYPE_FIELDS (type)),
4352 obj_type, NULL_TREE));
4353 if (expr)
4354 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
4355 convert (obj_type, expr));
4356 return gnat_build_constructor (type, v);
4359 /* There are some cases of expressions that we process specially. */
4360 switch (TREE_CODE (expr))
4362 case ERROR_MARK:
4363 return expr;
4365 case NULL_EXPR:
4366 /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
4367 conversion in gnat_expand_expr. NULL_EXPR does not represent
4368 and actual value, so no conversion is needed. */
4369 expr = copy_node (expr);
4370 TREE_TYPE (expr) = type;
4371 return expr;
4373 case STRING_CST:
4374 /* If we are converting a STRING_CST to another constrained array type,
4375 just make a new one in the proper type. */
4376 if (code == ecode && AGGREGATE_TYPE_P (etype)
4377 && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
4378 && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
4380 expr = copy_node (expr);
4381 TREE_TYPE (expr) = type;
4382 return expr;
4384 break;
4386 case VECTOR_CST:
4387 /* If we are converting a VECTOR_CST to a mere type variant, just make
4388 a new one in the proper type. */
4389 if (code == ecode && gnat_types_compatible_p (type, etype))
4391 expr = copy_node (expr);
4392 TREE_TYPE (expr) = type;
4393 return expr;
4395 break;
4397 case CONSTRUCTOR:
4398 /* If we are converting a CONSTRUCTOR to a mere type variant, or to
4399 another padding type around the same type, just make a new one in
4400 the proper type. */
4401 if (code == ecode
4402 && (gnat_types_compatible_p (type, etype)
4403 || (code == RECORD_TYPE
4404 && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype)
4405 && TREE_TYPE (TYPE_FIELDS (type))
4406 == TREE_TYPE (TYPE_FIELDS (etype)))))
4408 expr = copy_node (expr);
4409 TREE_TYPE (expr) = type;
4410 CONSTRUCTOR_ELTS (expr) = vec_safe_copy (CONSTRUCTOR_ELTS (expr));
4411 return expr;
4414 /* Likewise for a conversion between original and packable version, or
4415 conversion between types of the same size and with the same list of
4416 fields, but we have to work harder to preserve type consistency. */
4417 if (code == ecode
4418 && code == RECORD_TYPE
4419 && (TYPE_NAME (type) == TYPE_NAME (etype)
4420 || tree_int_cst_equal (TYPE_SIZE (type), TYPE_SIZE (etype))))
4423 vec<constructor_elt, va_gc> *e = CONSTRUCTOR_ELTS (expr);
4424 unsigned HOST_WIDE_INT len = vec_safe_length (e);
4425 vec<constructor_elt, va_gc> *v;
4426 vec_alloc (v, len);
4427 tree efield = TYPE_FIELDS (etype), field = TYPE_FIELDS (type);
4428 unsigned HOST_WIDE_INT idx;
4429 tree index, value;
4431 /* Whether we need to clear TREE_CONSTANT et al. on the output
4432 constructor when we convert in place. */
4433 bool clear_constant = false;
4435 FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value)
4437 /* Skip the missing fields in the CONSTRUCTOR. */
4438 while (efield && field && !SAME_FIELD_P (efield, index))
4440 efield = DECL_CHAIN (efield);
4441 field = DECL_CHAIN (field);
4443 /* The field must be the same. */
4444 if (!(efield && field && SAME_FIELD_P (efield, field)))
4445 break;
4446 constructor_elt elt
4447 = {field, convert (TREE_TYPE (field), value)};
4448 v->quick_push (elt);
4450 /* If packing has made this field a bitfield and the input
4451 value couldn't be emitted statically any more, we need to
4452 clear TREE_CONSTANT on our output. */
4453 if (!clear_constant
4454 && TREE_CONSTANT (expr)
4455 && !CONSTRUCTOR_BITFIELD_P (efield)
4456 && CONSTRUCTOR_BITFIELD_P (field)
4457 && !initializer_constant_valid_for_bitfield_p (value))
4458 clear_constant = true;
4460 efield = DECL_CHAIN (efield);
4461 field = DECL_CHAIN (field);
4464 /* If we have been able to match and convert all the input fields
4465 to their output type, convert in place now. We'll fallback to a
4466 view conversion downstream otherwise. */
4467 if (idx == len)
4469 expr = copy_node (expr);
4470 TREE_TYPE (expr) = type;
4471 CONSTRUCTOR_ELTS (expr) = v;
4472 if (clear_constant)
4473 TREE_CONSTANT (expr) = TREE_STATIC (expr) = 0;
4474 return expr;
4478 /* Likewise for a conversion between array type and vector type with a
4479 compatible representative array. */
4480 else if (code == VECTOR_TYPE
4481 && ecode == ARRAY_TYPE
4482 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
4483 etype))
4485 vec<constructor_elt, va_gc> *e = CONSTRUCTOR_ELTS (expr);
4486 unsigned HOST_WIDE_INT len = vec_safe_length (e);
4487 vec<constructor_elt, va_gc> *v;
4488 unsigned HOST_WIDE_INT ix;
4489 tree value;
4491 /* Build a VECTOR_CST from a *constant* array constructor. */
4492 if (TREE_CONSTANT (expr))
4494 bool constant_p = true;
4496 /* Iterate through elements and check if all constructor
4497 elements are *_CSTs. */
4498 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
4499 if (!CONSTANT_CLASS_P (value))
4501 constant_p = false;
4502 break;
4505 if (constant_p)
4506 return build_vector_from_ctor (type,
4507 CONSTRUCTOR_ELTS (expr));
4510 /* Otherwise, build a regular vector constructor. */
4511 vec_alloc (v, len);
4512 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
4514 constructor_elt elt = {NULL_TREE, value};
4515 v->quick_push (elt);
4517 expr = copy_node (expr);
4518 TREE_TYPE (expr) = type;
4519 CONSTRUCTOR_ELTS (expr) = v;
4520 return expr;
4522 break;
4524 case UNCONSTRAINED_ARRAY_REF:
4525 /* First retrieve the underlying array. */
4526 expr = maybe_unconstrained_array (expr);
4527 etype = TREE_TYPE (expr);
4528 ecode = TREE_CODE (etype);
4529 break;
4531 case VIEW_CONVERT_EXPR:
4533 /* GCC 4.x is very sensitive to type consistency overall, and view
4534 conversions thus are very frequent. Even though just "convert"ing
4535 the inner operand to the output type is fine in most cases, it
4536 might expose unexpected input/output type mismatches in special
4537 circumstances so we avoid such recursive calls when we can. */
4538 tree op0 = TREE_OPERAND (expr, 0);
4540 /* If we are converting back to the original type, we can just
4541 lift the input conversion. This is a common occurrence with
4542 switches back-and-forth amongst type variants. */
4543 if (type == TREE_TYPE (op0))
4544 return op0;
4546 /* Otherwise, if we're converting between two aggregate or vector
4547 types, we might be allowed to substitute the VIEW_CONVERT_EXPR
4548 target type in place or to just convert the inner expression. */
4549 if ((AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
4550 || (VECTOR_TYPE_P (type) && VECTOR_TYPE_P (etype)))
4552 /* If we are converting between mere variants, we can just
4553 substitute the VIEW_CONVERT_EXPR in place. */
4554 if (gnat_types_compatible_p (type, etype))
4555 return build1 (VIEW_CONVERT_EXPR, type, op0);
4557 /* Otherwise, we may just bypass the input view conversion unless
4558 one of the types is a fat pointer, which is handled by
4559 specialized code below which relies on exact type matching. */
4560 else if (!TYPE_IS_FAT_POINTER_P (type)
4561 && !TYPE_IS_FAT_POINTER_P (etype))
4562 return convert (type, op0);
4565 break;
4568 default:
4569 break;
4572 /* Check for converting to a pointer to an unconstrained array. */
4573 if (TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype))
4574 return convert_to_fat_pointer (type, expr);
4576 /* If we are converting between two aggregate or vector types that are mere
4577 variants, just make a VIEW_CONVERT_EXPR. Likewise when we are converting
4578 to a vector type from its representative array type. */
4579 else if ((code == ecode
4580 && (AGGREGATE_TYPE_P (type) || VECTOR_TYPE_P (type))
4581 && gnat_types_compatible_p (type, etype))
4582 || (code == VECTOR_TYPE
4583 && ecode == ARRAY_TYPE
4584 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
4585 etype)))
4586 return build1 (VIEW_CONVERT_EXPR, type, expr);
4588 /* If we are converting between tagged types, try to upcast properly. */
4589 else if (ecode == RECORD_TYPE && code == RECORD_TYPE
4590 && TYPE_ALIGN_OK (etype) && TYPE_ALIGN_OK (type))
4592 tree child_etype = etype;
4593 do {
4594 tree field = TYPE_FIELDS (child_etype);
4595 if (DECL_NAME (field) == parent_name_id && TREE_TYPE (field) == type)
4596 return build_component_ref (expr, field, false);
4597 child_etype = TREE_TYPE (field);
4598 } while (TREE_CODE (child_etype) == RECORD_TYPE);
4601 /* If we are converting from a smaller form of record type back to it, just
4602 make a VIEW_CONVERT_EXPR. But first pad the expression to have the same
4603 size on both sides. */
4604 else if (ecode == RECORD_TYPE && code == RECORD_TYPE
4605 && smaller_form_type_p (etype, type))
4607 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
4608 false, false, false, true),
4609 expr);
4610 return build1 (VIEW_CONVERT_EXPR, type, expr);
4613 /* In all other cases of related types, make a NOP_EXPR. */
4614 else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
4615 return fold_convert (type, expr);
4617 switch (code)
4619 case VOID_TYPE:
4620 return fold_build1 (CONVERT_EXPR, type, expr);
4622 case INTEGER_TYPE:
4623 if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
4624 && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
4625 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
4626 return unchecked_convert (type, expr, false);
4628 /* If the output is a biased type, convert first to the base type and
4629 subtract the bias. Note that the bias itself must go through a full
4630 conversion to the base type, lest it is a biased value; this happens
4631 for subtypes of biased types. */
4632 if (TYPE_BIASED_REPRESENTATION_P (type))
4633 return fold_convert (type,
4634 fold_build2 (MINUS_EXPR, TREE_TYPE (type),
4635 convert (TREE_TYPE (type), expr),
4636 convert (TREE_TYPE (type),
4637 TYPE_MIN_VALUE (type))));
4639 /* ... fall through ... */
4641 case ENUMERAL_TYPE:
4642 case BOOLEAN_TYPE:
4643 /* If we are converting an additive expression to an integer type
4644 with lower precision, be wary of the optimization that can be
4645 applied by convert_to_integer. There are 2 problematic cases:
4646 - if the first operand was originally of a biased type,
4647 because we could be recursively called to convert it
4648 to an intermediate type and thus rematerialize the
4649 additive operator endlessly,
4650 - if the expression contains a placeholder, because an
4651 intermediate conversion that changes the sign could
4652 be inserted and thus introduce an artificial overflow
4653 at compile time when the placeholder is substituted. */
4654 if (code == INTEGER_TYPE
4655 && ecode == INTEGER_TYPE
4656 && TYPE_PRECISION (type) < TYPE_PRECISION (etype)
4657 && (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR))
4659 tree op0 = get_unwidened (TREE_OPERAND (expr, 0), type);
4661 if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE
4662 && TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0)))
4663 || CONTAINS_PLACEHOLDER_P (expr))
4664 return build1 (NOP_EXPR, type, expr);
4667 return fold (convert_to_integer (type, expr));
4669 case POINTER_TYPE:
4670 case REFERENCE_TYPE:
4671 /* If converting between two thin pointers, adjust if needed to account
4672 for differing offsets from the base pointer, depending on whether
4673 there is a TYPE_UNCONSTRAINED_ARRAY attached to the record type. */
4674 if (TYPE_IS_THIN_POINTER_P (etype) && TYPE_IS_THIN_POINTER_P (type))
4676 tree etype_pos
4677 = TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (etype))
4678 ? byte_position (DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (etype))))
4679 : size_zero_node;
4680 tree type_pos
4681 = TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))
4682 ? byte_position (DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (type))))
4683 : size_zero_node;
4684 tree byte_diff = size_diffop (type_pos, etype_pos);
4686 expr = build1 (NOP_EXPR, type, expr);
4687 if (integer_zerop (byte_diff))
4688 return expr;
4690 return build_binary_op (POINTER_PLUS_EXPR, type, expr,
4691 fold_convert (sizetype, byte_diff));
4694 /* If converting fat pointer to normal or thin pointer, get the pointer
4695 to the array and then convert it. */
4696 if (TYPE_IS_FAT_POINTER_P (etype))
4697 expr = build_component_ref (expr, TYPE_FIELDS (etype), false);
4699 return fold (convert_to_pointer (type, expr));
4701 case REAL_TYPE:
4702 return fold (convert_to_real (type, expr));
4704 case RECORD_TYPE:
4705 if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype))
4707 vec<constructor_elt, va_gc> *v;
4708 vec_alloc (v, 1);
4710 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
4711 convert (TREE_TYPE (TYPE_FIELDS (type)),
4712 expr));
4713 return gnat_build_constructor (type, v);
4716 /* ... fall through ... */
4718 case ARRAY_TYPE:
4719 /* In these cases, assume the front-end has validated the conversion.
4720 If the conversion is valid, it will be a bit-wise conversion, so
4721 it can be viewed as an unchecked conversion. */
4722 return unchecked_convert (type, expr, false);
4724 case UNION_TYPE:
4725 /* This is a either a conversion between a tagged type and some
4726 subtype, which we have to mark as a UNION_TYPE because of
4727 overlapping fields or a conversion of an Unchecked_Union. */
4728 return unchecked_convert (type, expr, false);
4730 case UNCONSTRAINED_ARRAY_TYPE:
4731 /* If the input is a VECTOR_TYPE, convert to the representative
4732 array type first. */
4733 if (ecode == VECTOR_TYPE)
4735 expr = convert (TYPE_REPRESENTATIVE_ARRAY (etype), expr);
4736 etype = TREE_TYPE (expr);
4737 ecode = TREE_CODE (etype);
4740 /* If EXPR is a constrained array, take its address, convert it to a
4741 fat pointer, and then dereference it. Likewise if EXPR is a
4742 record containing both a template and a constrained array.
4743 Note that a record representing a justified modular type
4744 always represents a packed constrained array. */
4745 if (ecode == ARRAY_TYPE
4746 || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
4747 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
4748 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))
4749 return
4750 build_unary_op
4751 (INDIRECT_REF, NULL_TREE,
4752 convert_to_fat_pointer (TREE_TYPE (type),
4753 build_unary_op (ADDR_EXPR,
4754 NULL_TREE, expr)));
4756 /* Do something very similar for converting one unconstrained
4757 array to another. */
4758 else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
4759 return
4760 build_unary_op (INDIRECT_REF, NULL_TREE,
4761 convert (TREE_TYPE (type),
4762 build_unary_op (ADDR_EXPR,
4763 NULL_TREE, expr)));
4764 else
4765 gcc_unreachable ();
4767 case COMPLEX_TYPE:
4768 return fold (convert_to_complex (type, expr));
4770 default:
4771 gcc_unreachable ();
4775 /* Create an expression whose value is that of EXPR converted to the common
4776 index type, which is sizetype. EXPR is supposed to be in the base type
4777 of the GNAT index type. Calling it is equivalent to doing
4779 convert (sizetype, expr)
4781 but we try to distribute the type conversion with the knowledge that EXPR
4782 cannot overflow in its type. This is a best-effort approach and we fall
4783 back to the above expression as soon as difficulties are encountered.
4785 This is necessary to overcome issues that arise when the GNAT base index
4786 type and the GCC common index type (sizetype) don't have the same size,
4787 which is quite frequent on 64-bit architectures. In this case, and if
4788 the GNAT base index type is signed but the iteration type of the loop has
4789 been forced to unsigned, the loop scalar evolution engine cannot compute
4790 a simple evolution for the general induction variables associated with the
4791 array indices, because it will preserve the wrap-around semantics in the
4792 unsigned type of their "inner" part. As a result, many loop optimizations
4793 are blocked.
4795 The solution is to use a special (basic) induction variable that is at
4796 least as large as sizetype, and to express the aforementioned general
4797 induction variables in terms of this induction variable, eliminating
4798 the problematic intermediate truncation to the GNAT base index type.
4799 This is possible as long as the original expression doesn't overflow
4800 and if the middle-end hasn't introduced artificial overflows in the
4801 course of the various simplification it can make to the expression. */
4803 tree
4804 convert_to_index_type (tree expr)
4806 enum tree_code code = TREE_CODE (expr);
4807 tree type = TREE_TYPE (expr);
4809 /* If the type is unsigned, overflow is allowed so we cannot be sure that
4810 EXPR doesn't overflow. Keep it simple if optimization is disabled. */
4811 if (TYPE_UNSIGNED (type) || !optimize)
4812 return convert (sizetype, expr);
4814 switch (code)
4816 case VAR_DECL:
4817 /* The main effect of the function: replace a loop parameter with its
4818 associated special induction variable. */
4819 if (DECL_LOOP_PARM_P (expr) && DECL_INDUCTION_VAR (expr))
4820 expr = DECL_INDUCTION_VAR (expr);
4821 break;
4823 CASE_CONVERT:
4825 tree otype = TREE_TYPE (TREE_OPERAND (expr, 0));
4826 /* Bail out as soon as we suspect some sort of type frobbing. */
4827 if (TYPE_PRECISION (type) != TYPE_PRECISION (otype)
4828 || TYPE_UNSIGNED (type) != TYPE_UNSIGNED (otype))
4829 break;
4832 /* ... fall through ... */
4834 case NON_LVALUE_EXPR:
4835 return fold_build1 (code, sizetype,
4836 convert_to_index_type (TREE_OPERAND (expr, 0)));
4838 case PLUS_EXPR:
4839 case MINUS_EXPR:
4840 case MULT_EXPR:
4841 return fold_build2 (code, sizetype,
4842 convert_to_index_type (TREE_OPERAND (expr, 0)),
4843 convert_to_index_type (TREE_OPERAND (expr, 1)));
4845 case COMPOUND_EXPR:
4846 return fold_build2 (code, sizetype, TREE_OPERAND (expr, 0),
4847 convert_to_index_type (TREE_OPERAND (expr, 1)));
4849 case COND_EXPR:
4850 return fold_build3 (code, sizetype, TREE_OPERAND (expr, 0),
4851 convert_to_index_type (TREE_OPERAND (expr, 1)),
4852 convert_to_index_type (TREE_OPERAND (expr, 2)));
4854 default:
4855 break;
4858 return convert (sizetype, expr);
4861 /* Remove all conversions that are done in EXP. This includes converting
4862 from a padded type or to a justified modular type. If TRUE_ADDRESS
4863 is true, always return the address of the containing object even if
4864 the address is not bit-aligned. */
4866 tree
4867 remove_conversions (tree exp, bool true_address)
4869 switch (TREE_CODE (exp))
4871 case CONSTRUCTOR:
4872 if (true_address
4873 && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
4874 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
4875 return
4876 remove_conversions (CONSTRUCTOR_ELT (exp, 0)->value, true);
4877 break;
4879 case COMPONENT_REF:
4880 if (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
4881 return remove_conversions (TREE_OPERAND (exp, 0), true_address);
4882 break;
4884 CASE_CONVERT:
4885 case VIEW_CONVERT_EXPR:
4886 case NON_LVALUE_EXPR:
4887 return remove_conversions (TREE_OPERAND (exp, 0), true_address);
4889 default:
4890 break;
4893 return exp;
4896 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
4897 refers to the underlying array. If it has TYPE_CONTAINS_TEMPLATE_P,
4898 likewise return an expression pointing to the underlying array. */
4900 tree
4901 maybe_unconstrained_array (tree exp)
4903 enum tree_code code = TREE_CODE (exp);
4904 tree type = TREE_TYPE (exp);
4906 switch (TREE_CODE (type))
4908 case UNCONSTRAINED_ARRAY_TYPE:
4909 if (code == UNCONSTRAINED_ARRAY_REF)
4911 const bool read_only = TREE_READONLY (exp);
4912 const bool no_trap = TREE_THIS_NOTRAP (exp);
4914 exp = TREE_OPERAND (exp, 0);
4915 type = TREE_TYPE (exp);
4917 if (TREE_CODE (exp) == COND_EXPR)
4919 tree op1
4920 = build_unary_op (INDIRECT_REF, NULL_TREE,
4921 build_component_ref (TREE_OPERAND (exp, 1),
4922 TYPE_FIELDS (type),
4923 false));
4924 tree op2
4925 = build_unary_op (INDIRECT_REF, NULL_TREE,
4926 build_component_ref (TREE_OPERAND (exp, 2),
4927 TYPE_FIELDS (type),
4928 false));
4930 exp = build3 (COND_EXPR,
4931 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (type))),
4932 TREE_OPERAND (exp, 0), op1, op2);
4934 else
4936 exp = build_unary_op (INDIRECT_REF, NULL_TREE,
4937 build_component_ref (exp,
4938 TYPE_FIELDS (type),
4939 false));
4940 TREE_READONLY (exp) = read_only;
4941 TREE_THIS_NOTRAP (exp) = no_trap;
4945 else if (code == NULL_EXPR)
4946 exp = build1 (NULL_EXPR,
4947 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))),
4948 TREE_OPERAND (exp, 0));
4949 break;
4951 case RECORD_TYPE:
4952 /* If this is a padded type and it contains a template, convert to the
4953 unpadded type first. */
4954 if (TYPE_PADDING_P (type)
4955 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
4956 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
4958 exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
4959 code = TREE_CODE (exp);
4960 type = TREE_TYPE (exp);
4963 if (TYPE_CONTAINS_TEMPLATE_P (type))
4965 /* If the array initializer is a box, return NULL_TREE. */
4966 if (code == CONSTRUCTOR && CONSTRUCTOR_NELTS (exp) < 2)
4967 return NULL_TREE;
4969 exp = build_component_ref (exp, DECL_CHAIN (TYPE_FIELDS (type)),
4970 false);
4971 type = TREE_TYPE (exp);
4973 /* If the array type is padded, convert to the unpadded type. */
4974 if (TYPE_IS_PADDING_P (type))
4975 exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
4977 break;
4979 default:
4980 break;
4983 return exp;
4986 /* Return true if EXPR is an expression that can be folded as an operand
4987 of a VIEW_CONVERT_EXPR. See ada-tree.h for a complete rationale. */
4989 static bool
4990 can_fold_for_view_convert_p (tree expr)
4992 tree t1, t2;
4994 /* The folder will fold NOP_EXPRs between integral types with the same
4995 precision (in the middle-end's sense). We cannot allow it if the
4996 types don't have the same precision in the Ada sense as well. */
4997 if (TREE_CODE (expr) != NOP_EXPR)
4998 return true;
5000 t1 = TREE_TYPE (expr);
5001 t2 = TREE_TYPE (TREE_OPERAND (expr, 0));
5003 /* Defer to the folder for non-integral conversions. */
5004 if (!(INTEGRAL_TYPE_P (t1) && INTEGRAL_TYPE_P (t2)))
5005 return true;
5007 /* Only fold conversions that preserve both precisions. */
5008 if (TYPE_PRECISION (t1) == TYPE_PRECISION (t2)
5009 && operand_equal_p (rm_size (t1), rm_size (t2), 0))
5010 return true;
5012 return false;
5015 /* Return an expression that does an unchecked conversion of EXPR to TYPE.
5016 If NOTRUNC_P is true, truncation operations should be suppressed.
5018 Special care is required with (source or target) integral types whose
5019 precision is not equal to their size, to make sure we fetch or assign
5020 the value bits whose location might depend on the endianness, e.g.
5022 Rmsize : constant := 8;
5023 subtype Int is Integer range 0 .. 2 ** Rmsize - 1;
5025 type Bit_Array is array (1 .. Rmsize) of Boolean;
5026 pragma Pack (Bit_Array);
5028 function To_Bit_Array is new Unchecked_Conversion (Int, Bit_Array);
5030 Value : Int := 2#1000_0001#;
5031 Vbits : Bit_Array := To_Bit_Array (Value);
5033 we expect the 8 bits at Vbits'Address to always contain Value, while
5034 their original location depends on the endianness, at Value'Address
5035 on a little-endian architecture but not on a big-endian one.
5037 One pitfall is that we cannot use TYPE_UNSIGNED directly to decide how
5038 the bits between the precision and the size are filled, because of the
5039 trick used in the E_Signed_Integer_Subtype case of gnat_to_gnu_entity.
5040 So we use the special predicate type_unsigned_for_rm above. */
5042 tree
5043 unchecked_convert (tree type, tree expr, bool notrunc_p)
5045 tree etype = TREE_TYPE (expr);
5046 enum tree_code ecode = TREE_CODE (etype);
5047 enum tree_code code = TREE_CODE (type);
5048 tree tem;
5049 int c;
5051 /* If the expression is already of the right type, we are done. */
5052 if (etype == type)
5053 return expr;
5055 /* If both types are integral just do a normal conversion.
5056 Likewise for a conversion to an unconstrained array. */
5057 if (((INTEGRAL_TYPE_P (type)
5058 || (POINTER_TYPE_P (type) && !TYPE_IS_THIN_POINTER_P (type))
5059 || (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type)))
5060 && (INTEGRAL_TYPE_P (etype)
5061 || (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype))
5062 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))))
5063 || code == UNCONSTRAINED_ARRAY_TYPE)
5065 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
5067 tree ntype = copy_type (etype);
5068 TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
5069 TYPE_MAIN_VARIANT (ntype) = ntype;
5070 expr = build1 (NOP_EXPR, ntype, expr);
5073 if (code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
5075 tree rtype = copy_type (type);
5076 TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
5077 TYPE_MAIN_VARIANT (rtype) = rtype;
5078 expr = convert (rtype, expr);
5079 expr = build1 (NOP_EXPR, type, expr);
5081 else
5082 expr = convert (type, expr);
5085 /* If we are converting to an integral type whose precision is not equal
5086 to its size, first unchecked convert to a record type that contains a
5087 field of the given precision. Then extract the result from the field.
5089 There is a subtlety if the source type is an aggregate type with reverse
5090 storage order because its representation is not contiguous in the native
5091 storage order, i.e. a direct unchecked conversion to an integral type
5092 with N bits of precision cannot read the first N bits of the aggregate
5093 type. To overcome it, we do an unchecked conversion to an integral type
5094 with reverse storage order and return the resulting value. This also
5095 ensures that the result of the unchecked conversion doesn't depend on
5096 the endianness of the target machine, but only on the storage order of
5097 the aggregate type.
5099 Finally, for the sake of consistency, we do the unchecked conversion
5100 to an integral type with reverse storage order as soon as the source
5101 type is an aggregate type with reverse storage order, even if there
5102 are no considerations of precision or size involved. */
5103 else if (INTEGRAL_TYPE_P (type)
5104 && TYPE_RM_SIZE (type)
5105 && (tree_int_cst_compare (TYPE_RM_SIZE (type),
5106 TYPE_SIZE (type)) < 0
5107 || (AGGREGATE_TYPE_P (etype)
5108 && TYPE_REVERSE_STORAGE_ORDER (etype))))
5110 tree rec_type = make_node (RECORD_TYPE);
5111 unsigned HOST_WIDE_INT prec = TREE_INT_CST_LOW (TYPE_RM_SIZE (type));
5112 tree field_type, field;
5114 if (AGGREGATE_TYPE_P (etype))
5115 TYPE_REVERSE_STORAGE_ORDER (rec_type)
5116 = TYPE_REVERSE_STORAGE_ORDER (etype);
5118 if (type_unsigned_for_rm (type))
5119 field_type = make_unsigned_type (prec);
5120 else
5121 field_type = make_signed_type (prec);
5122 SET_TYPE_RM_SIZE (field_type, TYPE_RM_SIZE (type));
5124 field = create_field_decl (get_identifier ("OBJ"), field_type, rec_type,
5125 NULL_TREE, bitsize_zero_node, 1, 0);
5127 finish_record_type (rec_type, field, 1, false);
5129 expr = unchecked_convert (rec_type, expr, notrunc_p);
5130 expr = build_component_ref (expr, field, false);
5131 expr = fold_build1 (NOP_EXPR, type, expr);
5134 /* Similarly if we are converting from an integral type whose precision is
5135 not equal to its size, first copy into a field of the given precision
5136 and unchecked convert the record type.
5138 The same considerations as above apply if the target type is an aggregate
5139 type with reverse storage order and we also proceed similarly. */
5140 else if (INTEGRAL_TYPE_P (etype)
5141 && TYPE_RM_SIZE (etype)
5142 && (tree_int_cst_compare (TYPE_RM_SIZE (etype),
5143 TYPE_SIZE (etype)) < 0
5144 || (AGGREGATE_TYPE_P (type)
5145 && TYPE_REVERSE_STORAGE_ORDER (type))))
5147 tree rec_type = make_node (RECORD_TYPE);
5148 unsigned HOST_WIDE_INT prec = TREE_INT_CST_LOW (TYPE_RM_SIZE (etype));
5149 vec<constructor_elt, va_gc> *v;
5150 vec_alloc (v, 1);
5151 tree field_type, field;
5153 if (AGGREGATE_TYPE_P (type))
5154 TYPE_REVERSE_STORAGE_ORDER (rec_type)
5155 = TYPE_REVERSE_STORAGE_ORDER (type);
5157 if (type_unsigned_for_rm (etype))
5158 field_type = make_unsigned_type (prec);
5159 else
5160 field_type = make_signed_type (prec);
5161 SET_TYPE_RM_SIZE (field_type, TYPE_RM_SIZE (etype));
5163 field = create_field_decl (get_identifier ("OBJ"), field_type, rec_type,
5164 NULL_TREE, bitsize_zero_node, 1, 0);
5166 finish_record_type (rec_type, field, 1, false);
5168 expr = fold_build1 (NOP_EXPR, field_type, expr);
5169 CONSTRUCTOR_APPEND_ELT (v, field, expr);
5170 expr = gnat_build_constructor (rec_type, v);
5171 expr = unchecked_convert (type, expr, notrunc_p);
5174 /* If we are converting from a scalar type to a type with a different size,
5175 we need to pad to have the same size on both sides.
5177 ??? We cannot do it unconditionally because unchecked conversions are
5178 used liberally by the front-end to implement polymorphism, e.g. in:
5180 S191s : constant ada__tags__addr_ptr := ada__tags__addr_ptr!(S190s);
5181 return p___size__4 (p__object!(S191s.all));
5183 so we skip all expressions that are references. */
5184 else if (!REFERENCE_CLASS_P (expr)
5185 && !AGGREGATE_TYPE_P (etype)
5186 && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST
5187 && (c = tree_int_cst_compare (TYPE_SIZE (etype), TYPE_SIZE (type))))
5189 if (c < 0)
5191 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
5192 false, false, false, true),
5193 expr);
5194 expr = unchecked_convert (type, expr, notrunc_p);
5196 else
5198 tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty,
5199 false, false, false, true);
5200 expr = unchecked_convert (rec_type, expr, notrunc_p);
5201 expr = build_component_ref (expr, TYPE_FIELDS (rec_type), false);
5205 /* We have a special case when we are converting between two unconstrained
5206 array types. In that case, take the address, convert the fat pointer
5207 types, and dereference. */
5208 else if (ecode == code && code == UNCONSTRAINED_ARRAY_TYPE)
5209 expr = build_unary_op (INDIRECT_REF, NULL_TREE,
5210 build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type),
5211 build_unary_op (ADDR_EXPR, NULL_TREE,
5212 expr)));
5214 /* Another special case is when we are converting to a vector type from its
5215 representative array type; this a regular conversion. */
5216 else if (code == VECTOR_TYPE
5217 && ecode == ARRAY_TYPE
5218 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
5219 etype))
5220 expr = convert (type, expr);
5222 /* And, if the array type is not the representative, we try to build an
5223 intermediate vector type of which the array type is the representative
5224 and to do the unchecked conversion between the vector types, in order
5225 to enable further simplifications in the middle-end. */
5226 else if (code == VECTOR_TYPE
5227 && ecode == ARRAY_TYPE
5228 && (tem = build_vector_type_for_array (etype, NULL_TREE)))
5230 expr = convert (tem, expr);
5231 return unchecked_convert (type, expr, notrunc_p);
5234 /* If we are converting a CONSTRUCTOR to a more aligned RECORD_TYPE, bump
5235 the alignment of the CONSTRUCTOR to speed up the copy operation. */
5236 else if (TREE_CODE (expr) == CONSTRUCTOR
5237 && code == RECORD_TYPE
5238 && TYPE_ALIGN (etype) < TYPE_ALIGN (type))
5240 expr = convert (maybe_pad_type (etype, NULL_TREE, TYPE_ALIGN (type),
5241 Empty, false, false, false, true),
5242 expr);
5243 return unchecked_convert (type, expr, notrunc_p);
5246 /* Otherwise, just build a VIEW_CONVERT_EXPR of the expression. */
5247 else
5249 expr = maybe_unconstrained_array (expr);
5250 etype = TREE_TYPE (expr);
5251 ecode = TREE_CODE (etype);
5252 if (can_fold_for_view_convert_p (expr))
5253 expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr);
5254 else
5255 expr = build1 (VIEW_CONVERT_EXPR, type, expr);
5258 /* If the result is a non-biased integral type whose precision is not equal
5259 to its size, sign- or zero-extend the result. But we need not do this
5260 if the input is also an integral type and both are unsigned or both are
5261 signed and have the same precision. */
5262 if (!notrunc_p
5263 && INTEGRAL_TYPE_P (type)
5264 && !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
5265 && TYPE_RM_SIZE (type)
5266 && tree_int_cst_compare (TYPE_RM_SIZE (type), TYPE_SIZE (type)) < 0
5267 && !(INTEGRAL_TYPE_P (etype)
5268 && type_unsigned_for_rm (type) == type_unsigned_for_rm (etype)
5269 && (type_unsigned_for_rm (type)
5270 || tree_int_cst_compare (TYPE_RM_SIZE (type),
5271 TYPE_RM_SIZE (etype)
5272 ? TYPE_RM_SIZE (etype)
5273 : TYPE_SIZE (etype)) == 0)))
5275 if (integer_zerop (TYPE_RM_SIZE (type)))
5276 expr = build_int_cst (type, 0);
5277 else
5279 tree base_type
5280 = gnat_type_for_size (TREE_INT_CST_LOW (TYPE_SIZE (type)),
5281 type_unsigned_for_rm (type));
5282 tree shift_expr
5283 = convert (base_type,
5284 size_binop (MINUS_EXPR,
5285 TYPE_SIZE (type), TYPE_RM_SIZE (type)));
5286 expr
5287 = convert (type,
5288 build_binary_op (RSHIFT_EXPR, base_type,
5289 build_binary_op (LSHIFT_EXPR, base_type,
5290 convert (base_type,
5291 expr),
5292 shift_expr),
5293 shift_expr));
5297 /* An unchecked conversion should never raise Constraint_Error. The code
5298 below assumes that GCC's conversion routines overflow the same way that
5299 the underlying hardware does. This is probably true. In the rare case
5300 when it is false, we can rely on the fact that such conversions are
5301 erroneous anyway. */
5302 if (TREE_CODE (expr) == INTEGER_CST)
5303 TREE_OVERFLOW (expr) = 0;
5305 /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
5306 show no longer constant. */
5307 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
5308 && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype),
5309 OEP_ONLY_CONST))
5310 TREE_CONSTANT (expr) = 0;
5312 return expr;
5315 /* Return the appropriate GCC tree code for the specified GNAT_TYPE,
5316 the latter being a record type as predicated by Is_Record_Type. */
5318 enum tree_code
5319 tree_code_for_record_type (Entity_Id gnat_type)
5321 Node_Id component_list, component;
5323 /* Return UNION_TYPE if it's an Unchecked_Union whose non-discriminant
5324 fields are all in the variant part. Otherwise, return RECORD_TYPE. */
5325 if (!Is_Unchecked_Union (gnat_type))
5326 return RECORD_TYPE;
5328 gnat_type = Implementation_Base_Type (gnat_type);
5329 component_list
5330 = Component_List (Type_Definition (Declaration_Node (gnat_type)));
5332 for (component = First_Non_Pragma (Component_Items (component_list));
5333 Present (component);
5334 component = Next_Non_Pragma (component))
5335 if (Ekind (Defining_Entity (component)) == E_Component)
5336 return RECORD_TYPE;
5338 return UNION_TYPE;
5341 /* Return true if GNAT_TYPE is a "double" floating-point type, i.e. whose
5342 size is equal to 64 bits, or an array of such a type. Set ALIGN_CLAUSE
5343 according to the presence of an alignment clause on the type or, if it
5344 is an array, on the component type. */
5346 bool
5347 is_double_float_or_array (Entity_Id gnat_type, bool *align_clause)
5349 gnat_type = Underlying_Type (gnat_type);
5351 *align_clause = Present (Alignment_Clause (gnat_type));
5353 if (Is_Array_Type (gnat_type))
5355 gnat_type = Underlying_Type (Component_Type (gnat_type));
5356 if (Present (Alignment_Clause (gnat_type)))
5357 *align_clause = true;
5360 if (!Is_Floating_Point_Type (gnat_type))
5361 return false;
5363 if (UI_To_Int (Esize (gnat_type)) != 64)
5364 return false;
5366 return true;
5369 /* Return true if GNAT_TYPE is a "double" or larger scalar type, i.e. whose
5370 size is greater or equal to 64 bits, or an array of such a type. Set
5371 ALIGN_CLAUSE according to the presence of an alignment clause on the
5372 type or, if it is an array, on the component type. */
5374 bool
5375 is_double_scalar_or_array (Entity_Id gnat_type, bool *align_clause)
5377 gnat_type = Underlying_Type (gnat_type);
5379 *align_clause = Present (Alignment_Clause (gnat_type));
5381 if (Is_Array_Type (gnat_type))
5383 gnat_type = Underlying_Type (Component_Type (gnat_type));
5384 if (Present (Alignment_Clause (gnat_type)))
5385 *align_clause = true;
5388 if (!Is_Scalar_Type (gnat_type))
5389 return false;
5391 if (UI_To_Int (Esize (gnat_type)) < 64)
5392 return false;
5394 return true;
5397 /* Return true if GNU_TYPE is suitable as the type of a non-aliased
5398 component of an aggregate type. */
5400 bool
5401 type_for_nonaliased_component_p (tree gnu_type)
5403 /* If the type is passed by reference, we may have pointers to the
5404 component so it cannot be made non-aliased. */
5405 if (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type))
5406 return false;
5408 /* We used to say that any component of aggregate type is aliased
5409 because the front-end may take 'Reference of it. The front-end
5410 has been enhanced in the meantime so as to use a renaming instead
5411 in most cases, but the back-end can probably take the address of
5412 such a component too so we go for the conservative stance.
5414 For instance, we might need the address of any array type, even
5415 if normally passed by copy, to construct a fat pointer if the
5416 component is used as an actual for an unconstrained formal.
5418 Likewise for record types: even if a specific record subtype is
5419 passed by copy, the parent type might be passed by ref (e.g. if
5420 it's of variable size) and we might take the address of a child
5421 component to pass to a parent formal. We have no way to check
5422 for such conditions here. */
5423 if (AGGREGATE_TYPE_P (gnu_type))
5424 return false;
5426 return true;
5429 /* Return true if TYPE is a smaller form of ORIG_TYPE. */
5431 bool
5432 smaller_form_type_p (tree type, tree orig_type)
5434 tree size, osize;
5436 /* We're not interested in variants here. */
5437 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (orig_type))
5438 return false;
5440 /* Like a variant, a packable version keeps the original TYPE_NAME. */
5441 if (TYPE_NAME (type) != TYPE_NAME (orig_type))
5442 return false;
5444 size = TYPE_SIZE (type);
5445 osize = TYPE_SIZE (orig_type);
5447 if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (osize) == INTEGER_CST))
5448 return false;
5450 return tree_int_cst_lt (size, osize) != 0;
5453 /* Return whether EXPR, which is the renamed object in an object renaming
5454 declaration, can be materialized as a reference (with a REFERENCE_TYPE).
5455 This should be synchronized with Exp_Dbug.Debug_Renaming_Declaration. */
5457 bool
5458 can_materialize_object_renaming_p (Node_Id expr)
5460 while (true)
5462 expr = Original_Node (expr);
5464 switch Nkind (expr)
5466 case N_Identifier:
5467 case N_Expanded_Name:
5468 if (!Present (Renamed_Object (Entity (expr))))
5469 return true;
5470 expr = Renamed_Object (Entity (expr));
5471 break;
5473 case N_Selected_Component:
5475 if (Is_Packed (Underlying_Type (Etype (Prefix (expr)))))
5476 return false;
5478 const Uint bitpos
5479 = Normalized_First_Bit (Entity (Selector_Name (expr)));
5480 if (!UI_Is_In_Int_Range (bitpos)
5481 || (bitpos != UI_No_Uint && bitpos != UI_From_Int (0)))
5482 return false;
5484 expr = Prefix (expr);
5485 break;
5488 case N_Indexed_Component:
5489 case N_Slice:
5491 const Entity_Id t = Underlying_Type (Etype (Prefix (expr)));
5493 if (Is_Array_Type (t) && Present (Packed_Array_Impl_Type (t)))
5494 return false;
5496 expr = Prefix (expr);
5497 break;
5500 case N_Explicit_Dereference:
5501 expr = Prefix (expr);
5502 break;
5504 default:
5505 return true;
5510 /* Perform final processing on global declarations. */
5512 static GTY (()) tree dummy_global;
5514 void
5515 gnat_write_global_declarations (void)
5517 unsigned int i;
5518 tree iter;
5520 /* If we have declared types as used at the global level, insert them in
5521 the global hash table. We use a dummy variable for this purpose, but
5522 we need to build it unconditionally to avoid -fcompare-debug issues. */
5523 if (first_global_object_name)
5525 struct varpool_node *node;
5526 char *label;
5528 ASM_FORMAT_PRIVATE_NAME (label, first_global_object_name, 0);
5529 dummy_global
5530 = build_decl (BUILTINS_LOCATION, VAR_DECL, get_identifier (label),
5531 void_type_node);
5532 DECL_HARD_REGISTER (dummy_global) = 1;
5533 TREE_STATIC (dummy_global) = 1;
5534 node = varpool_node::get_create (dummy_global);
5535 node->definition = 1;
5536 node->force_output = 1;
5538 if (types_used_by_cur_var_decl)
5539 while (!types_used_by_cur_var_decl->is_empty ())
5541 tree t = types_used_by_cur_var_decl->pop ();
5542 types_used_by_var_decl_insert (t, dummy_global);
5546 /* Output debug information for all global type declarations first. This
5547 ensures that global types whose compilation hasn't been finalized yet,
5548 for example pointers to Taft amendment types, have their compilation
5549 finalized in the right context. */
5550 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
5551 if (TREE_CODE (iter) == TYPE_DECL && !DECL_IGNORED_P (iter))
5552 debug_hooks->type_decl (iter, false);
5554 /* Output imported functions. */
5555 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
5556 if (TREE_CODE (iter) == FUNCTION_DECL
5557 && DECL_EXTERNAL (iter)
5558 && DECL_INITIAL (iter) == NULL
5559 && !DECL_IGNORED_P (iter)
5560 && DECL_FUNCTION_IS_DEF (iter))
5561 debug_hooks->early_global_decl (iter);
5563 /* Then output the global variables. We need to do that after the debug
5564 information for global types is emitted so that they are finalized. Skip
5565 external global variables, unless we need to emit debug info for them:
5566 this is useful for imported variables, for instance. */
5567 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
5568 if (TREE_CODE (iter) == VAR_DECL
5569 && (!DECL_EXTERNAL (iter) || !DECL_IGNORED_P (iter)))
5570 rest_of_decl_compilation (iter, true, 0);
5572 /* Output the imported modules/declarations. In GNAT, these are only
5573 materializing subprogram. */
5574 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
5575 if (TREE_CODE (iter) == IMPORTED_DECL && !DECL_IGNORED_P (iter))
5576 debug_hooks->imported_module_or_decl (iter, DECL_NAME (iter),
5577 DECL_CONTEXT (iter), false, false);
5580 /* ************************************************************************
5581 * * GCC builtins support *
5582 * ************************************************************************ */
5584 /* The general scheme is fairly simple:
5586 For each builtin function/type to be declared, gnat_install_builtins calls
5587 internal facilities which eventually get to gnat_pushdecl, which in turn
5588 tracks the so declared builtin function decls in the 'builtin_decls' global
5589 datastructure. When an Intrinsic subprogram declaration is processed, we
5590 search this global datastructure to retrieve the associated BUILT_IN DECL
5591 node. */
5593 /* Search the chain of currently available builtin declarations for a node
5594 corresponding to function NAME (an IDENTIFIER_NODE). Return the first node
5595 found, if any, or NULL_TREE otherwise. */
5596 tree
5597 builtin_decl_for (tree name)
5599 unsigned i;
5600 tree decl;
5602 FOR_EACH_VEC_SAFE_ELT (builtin_decls, i, decl)
5603 if (DECL_NAME (decl) == name)
5604 return decl;
5606 return NULL_TREE;
5609 /* The code below eventually exposes gnat_install_builtins, which declares
5610 the builtin types and functions we might need, either internally or as
5611 user accessible facilities.
5613 ??? This is a first implementation shot, still in rough shape. It is
5614 heavily inspired from the "C" family implementation, with chunks copied
5615 verbatim from there.
5617 Two obvious improvement candidates are:
5618 o Use a more efficient name/decl mapping scheme
5619 o Devise a middle-end infrastructure to avoid having to copy
5620 pieces between front-ends. */
5622 /* ----------------------------------------------------------------------- *
5623 * BUILTIN ELEMENTARY TYPES *
5624 * ----------------------------------------------------------------------- */
5626 /* Standard data types to be used in builtin argument declarations. */
5628 enum c_tree_index
5630 CTI_SIGNED_SIZE_TYPE, /* For format checking only. */
5631 CTI_STRING_TYPE,
5632 CTI_CONST_STRING_TYPE,
5634 CTI_MAX
5637 static tree c_global_trees[CTI_MAX];
5639 #define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE]
5640 #define string_type_node c_global_trees[CTI_STRING_TYPE]
5641 #define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE]
5643 /* ??? In addition some attribute handlers, we currently don't support a
5644 (small) number of builtin-types, which in turns inhibits support for a
5645 number of builtin functions. */
5646 #define wint_type_node void_type_node
5647 #define intmax_type_node void_type_node
5648 #define uintmax_type_node void_type_node
5650 /* Used to help initialize the builtin-types.def table. When a type of
5651 the correct size doesn't exist, use error_mark_node instead of NULL.
5652 The later results in segfaults even when a decl using the type doesn't
5653 get invoked. */
5655 static tree
5656 builtin_type_for_size (int size, bool unsignedp)
5658 tree type = gnat_type_for_size (size, unsignedp);
5659 return type ? type : error_mark_node;
5662 /* Build/push the elementary type decls that builtin functions/types
5663 will need. */
5665 static void
5666 install_builtin_elementary_types (void)
5668 signed_size_type_node = gnat_signed_type_for (size_type_node);
5669 pid_type_node = integer_type_node;
5671 string_type_node = build_pointer_type (char_type_node);
5672 const_string_type_node
5673 = build_pointer_type (build_qualified_type
5674 (char_type_node, TYPE_QUAL_CONST));
5677 /* ----------------------------------------------------------------------- *
5678 * BUILTIN FUNCTION TYPES *
5679 * ----------------------------------------------------------------------- */
5681 /* Now, builtin function types per se. */
5683 enum c_builtin_type
5685 #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
5686 #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
5687 #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
5688 #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
5689 #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
5690 #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
5691 #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
5692 #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5693 ARG6) NAME,
5694 #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5695 ARG6, ARG7) NAME,
5696 #define DEF_FUNCTION_TYPE_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5697 ARG6, ARG7, ARG8) NAME,
5698 #define DEF_FUNCTION_TYPE_9(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5699 ARG6, ARG7, ARG8, ARG9) NAME,
5700 #define DEF_FUNCTION_TYPE_10(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5701 ARG6, ARG7, ARG8, ARG9, ARG10) NAME,
5702 #define DEF_FUNCTION_TYPE_11(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5703 ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) NAME,
5704 #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
5705 #define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME,
5706 #define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME,
5707 #define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
5708 #define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
5709 #define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5710 NAME,
5711 #define DEF_FUNCTION_TYPE_VAR_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5712 ARG6) NAME,
5713 #define DEF_FUNCTION_TYPE_VAR_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5714 ARG6, ARG7) NAME,
5715 #define DEF_POINTER_TYPE(NAME, TYPE) NAME,
5716 #include "builtin-types.def"
5717 #undef DEF_PRIMITIVE_TYPE
5718 #undef DEF_FUNCTION_TYPE_0
5719 #undef DEF_FUNCTION_TYPE_1
5720 #undef DEF_FUNCTION_TYPE_2
5721 #undef DEF_FUNCTION_TYPE_3
5722 #undef DEF_FUNCTION_TYPE_4
5723 #undef DEF_FUNCTION_TYPE_5
5724 #undef DEF_FUNCTION_TYPE_6
5725 #undef DEF_FUNCTION_TYPE_7
5726 #undef DEF_FUNCTION_TYPE_8
5727 #undef DEF_FUNCTION_TYPE_9
5728 #undef DEF_FUNCTION_TYPE_10
5729 #undef DEF_FUNCTION_TYPE_11
5730 #undef DEF_FUNCTION_TYPE_VAR_0
5731 #undef DEF_FUNCTION_TYPE_VAR_1
5732 #undef DEF_FUNCTION_TYPE_VAR_2
5733 #undef DEF_FUNCTION_TYPE_VAR_3
5734 #undef DEF_FUNCTION_TYPE_VAR_4
5735 #undef DEF_FUNCTION_TYPE_VAR_5
5736 #undef DEF_FUNCTION_TYPE_VAR_6
5737 #undef DEF_FUNCTION_TYPE_VAR_7
5738 #undef DEF_POINTER_TYPE
5739 BT_LAST
5742 typedef enum c_builtin_type builtin_type;
5744 /* A temporary array used in communication with def_fn_type. */
5745 static GTY(()) tree builtin_types[(int) BT_LAST + 1];
5747 /* A helper function for install_builtin_types. Build function type
5748 for DEF with return type RET and N arguments. If VAR is true, then the
5749 function should be variadic after those N arguments.
5751 Takes special care not to ICE if any of the types involved are
5752 error_mark_node, which indicates that said type is not in fact available
5753 (see builtin_type_for_size). In which case the function type as a whole
5754 should be error_mark_node. */
5756 static void
5757 def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...)
5759 tree t;
5760 tree *args = XALLOCAVEC (tree, n);
5761 va_list list;
5762 int i;
5764 va_start (list, n);
5765 for (i = 0; i < n; ++i)
5767 builtin_type a = (builtin_type) va_arg (list, int);
5768 t = builtin_types[a];
5769 if (t == error_mark_node)
5770 goto egress;
5771 args[i] = t;
5774 t = builtin_types[ret];
5775 if (t == error_mark_node)
5776 goto egress;
5777 if (var)
5778 t = build_varargs_function_type_array (t, n, args);
5779 else
5780 t = build_function_type_array (t, n, args);
5782 egress:
5783 builtin_types[def] = t;
5784 va_end (list);
5787 /* Build the builtin function types and install them in the builtin_types
5788 array for later use in builtin function decls. */
5790 static void
5791 install_builtin_function_types (void)
5793 tree va_list_ref_type_node;
5794 tree va_list_arg_type_node;
5796 if (TREE_CODE (va_list_type_node) == ARRAY_TYPE)
5798 va_list_arg_type_node = va_list_ref_type_node =
5799 build_pointer_type (TREE_TYPE (va_list_type_node));
5801 else
5803 va_list_arg_type_node = va_list_type_node;
5804 va_list_ref_type_node = build_reference_type (va_list_type_node);
5807 #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
5808 builtin_types[ENUM] = VALUE;
5809 #define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \
5810 def_fn_type (ENUM, RETURN, 0, 0);
5811 #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \
5812 def_fn_type (ENUM, RETURN, 0, 1, ARG1);
5813 #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \
5814 def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2);
5815 #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
5816 def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3);
5817 #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
5818 def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4);
5819 #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5820 def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
5821 #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5822 ARG6) \
5823 def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6);
5824 #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5825 ARG6, ARG7) \
5826 def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7);
5827 #define DEF_FUNCTION_TYPE_8(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5828 ARG6, ARG7, ARG8) \
5829 def_fn_type (ENUM, RETURN, 0, 8, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \
5830 ARG7, ARG8);
5831 #define DEF_FUNCTION_TYPE_9(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5832 ARG6, ARG7, ARG8, ARG9) \
5833 def_fn_type (ENUM, RETURN, 0, 9, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \
5834 ARG7, ARG8, ARG9);
5835 #define DEF_FUNCTION_TYPE_10(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5,\
5836 ARG6, ARG7, ARG8, ARG9, ARG10) \
5837 def_fn_type (ENUM, RETURN, 0, 10, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \
5838 ARG7, ARG8, ARG9, ARG10);
5839 #define DEF_FUNCTION_TYPE_11(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5,\
5840 ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) \
5841 def_fn_type (ENUM, RETURN, 0, 11, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \
5842 ARG7, ARG8, ARG9, ARG10, ARG11);
5843 #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \
5844 def_fn_type (ENUM, RETURN, 1, 0);
5845 #define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \
5846 def_fn_type (ENUM, RETURN, 1, 1, ARG1);
5847 #define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \
5848 def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2);
5849 #define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
5850 def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3);
5851 #define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
5852 def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4);
5853 #define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5854 def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
5855 #define DEF_FUNCTION_TYPE_VAR_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5856 ARG6) \
5857 def_fn_type (ENUM, RETURN, 1, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6);
5858 #define DEF_FUNCTION_TYPE_VAR_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5859 ARG6, ARG7) \
5860 def_fn_type (ENUM, RETURN, 1, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7);
5861 #define DEF_POINTER_TYPE(ENUM, TYPE) \
5862 builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]);
5864 #include "builtin-types.def"
5866 #undef DEF_PRIMITIVE_TYPE
5867 #undef DEF_FUNCTION_TYPE_0
5868 #undef DEF_FUNCTION_TYPE_1
5869 #undef DEF_FUNCTION_TYPE_2
5870 #undef DEF_FUNCTION_TYPE_3
5871 #undef DEF_FUNCTION_TYPE_4
5872 #undef DEF_FUNCTION_TYPE_5
5873 #undef DEF_FUNCTION_TYPE_6
5874 #undef DEF_FUNCTION_TYPE_7
5875 #undef DEF_FUNCTION_TYPE_8
5876 #undef DEF_FUNCTION_TYPE_9
5877 #undef DEF_FUNCTION_TYPE_10
5878 #undef DEF_FUNCTION_TYPE_11
5879 #undef DEF_FUNCTION_TYPE_VAR_0
5880 #undef DEF_FUNCTION_TYPE_VAR_1
5881 #undef DEF_FUNCTION_TYPE_VAR_2
5882 #undef DEF_FUNCTION_TYPE_VAR_3
5883 #undef DEF_FUNCTION_TYPE_VAR_4
5884 #undef DEF_FUNCTION_TYPE_VAR_5
5885 #undef DEF_FUNCTION_TYPE_VAR_6
5886 #undef DEF_FUNCTION_TYPE_VAR_7
5887 #undef DEF_POINTER_TYPE
5888 builtin_types[(int) BT_LAST] = NULL_TREE;
5891 /* ----------------------------------------------------------------------- *
5892 * BUILTIN ATTRIBUTES *
5893 * ----------------------------------------------------------------------- */
5895 enum built_in_attribute
5897 #define DEF_ATTR_NULL_TREE(ENUM) ENUM,
5898 #define DEF_ATTR_INT(ENUM, VALUE) ENUM,
5899 #define DEF_ATTR_STRING(ENUM, VALUE) ENUM,
5900 #define DEF_ATTR_IDENT(ENUM, STRING) ENUM,
5901 #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM,
5902 #include "builtin-attrs.def"
5903 #undef DEF_ATTR_NULL_TREE
5904 #undef DEF_ATTR_INT
5905 #undef DEF_ATTR_STRING
5906 #undef DEF_ATTR_IDENT
5907 #undef DEF_ATTR_TREE_LIST
5908 ATTR_LAST
5911 static GTY(()) tree built_in_attributes[(int) ATTR_LAST];
5913 static void
5914 install_builtin_attributes (void)
5916 /* Fill in the built_in_attributes array. */
5917 #define DEF_ATTR_NULL_TREE(ENUM) \
5918 built_in_attributes[(int) ENUM] = NULL_TREE;
5919 #define DEF_ATTR_INT(ENUM, VALUE) \
5920 built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE);
5921 #define DEF_ATTR_STRING(ENUM, VALUE) \
5922 built_in_attributes[(int) ENUM] = build_string (strlen (VALUE), VALUE);
5923 #define DEF_ATTR_IDENT(ENUM, STRING) \
5924 built_in_attributes[(int) ENUM] = get_identifier (STRING);
5925 #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \
5926 built_in_attributes[(int) ENUM] \
5927 = tree_cons (built_in_attributes[(int) PURPOSE], \
5928 built_in_attributes[(int) VALUE], \
5929 built_in_attributes[(int) CHAIN]);
5930 #include "builtin-attrs.def"
5931 #undef DEF_ATTR_NULL_TREE
5932 #undef DEF_ATTR_INT
5933 #undef DEF_ATTR_STRING
5934 #undef DEF_ATTR_IDENT
5935 #undef DEF_ATTR_TREE_LIST
5938 /* Handle a "const" attribute; arguments as in
5939 struct attribute_spec.handler. */
5941 static tree
5942 handle_const_attribute (tree *node, tree ARG_UNUSED (name),
5943 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5944 bool *no_add_attrs)
5946 if (TREE_CODE (*node) == FUNCTION_DECL)
5947 TREE_READONLY (*node) = 1;
5948 else
5949 *no_add_attrs = true;
5951 return NULL_TREE;
5954 /* Handle a "nothrow" attribute; arguments as in
5955 struct attribute_spec.handler. */
5957 static tree
5958 handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name),
5959 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5960 bool *no_add_attrs)
5962 if (TREE_CODE (*node) == FUNCTION_DECL)
5963 TREE_NOTHROW (*node) = 1;
5964 else
5965 *no_add_attrs = true;
5967 return NULL_TREE;
5970 /* Handle a "pure" attribute; arguments as in
5971 struct attribute_spec.handler. */
5973 static tree
5974 handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args),
5975 int ARG_UNUSED (flags), bool *no_add_attrs)
5977 if (TREE_CODE (*node) == FUNCTION_DECL)
5978 DECL_PURE_P (*node) = 1;
5979 /* TODO: support types. */
5980 else
5982 warning (OPT_Wattributes, "%qs attribute ignored",
5983 IDENTIFIER_POINTER (name));
5984 *no_add_attrs = true;
5987 return NULL_TREE;
5990 /* Handle a "no vops" attribute; arguments as in
5991 struct attribute_spec.handler. */
5993 static tree
5994 handle_novops_attribute (tree *node, tree ARG_UNUSED (name),
5995 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5996 bool *ARG_UNUSED (no_add_attrs))
5998 gcc_assert (TREE_CODE (*node) == FUNCTION_DECL);
5999 DECL_IS_NOVOPS (*node) = 1;
6000 return NULL_TREE;
6003 /* Helper for nonnull attribute handling; fetch the operand number
6004 from the attribute argument list. */
6006 static bool
6007 get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp)
6009 /* Verify the arg number is a constant. */
6010 if (!tree_fits_uhwi_p (arg_num_expr))
6011 return false;
6013 *valp = TREE_INT_CST_LOW (arg_num_expr);
6014 return true;
6017 /* Handle the "nonnull" attribute. */
6018 static tree
6019 handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name),
6020 tree args, int ARG_UNUSED (flags),
6021 bool *no_add_attrs)
6023 tree type = *node;
6024 unsigned HOST_WIDE_INT attr_arg_num;
6026 /* If no arguments are specified, all pointer arguments should be
6027 non-null. Verify a full prototype is given so that the arguments
6028 will have the correct types when we actually check them later.
6029 Avoid diagnosing type-generic built-ins since those have no
6030 prototype. */
6031 if (!args)
6033 if (!prototype_p (type)
6034 && (!TYPE_ATTRIBUTES (type)
6035 || !lookup_attribute ("type generic", TYPE_ATTRIBUTES (type))))
6037 error ("nonnull attribute without arguments on a non-prototype");
6038 *no_add_attrs = true;
6040 return NULL_TREE;
6043 /* Argument list specified. Verify that each argument number references
6044 a pointer argument. */
6045 for (attr_arg_num = 1; args; args = TREE_CHAIN (args))
6047 unsigned HOST_WIDE_INT arg_num = 0, ck_num;
6049 if (!get_nonnull_operand (TREE_VALUE (args), &arg_num))
6051 error ("nonnull argument has invalid operand number (argument %lu)",
6052 (unsigned long) attr_arg_num);
6053 *no_add_attrs = true;
6054 return NULL_TREE;
6057 if (prototype_p (type))
6059 function_args_iterator iter;
6060 tree argument;
6062 function_args_iter_init (&iter, type);
6063 for (ck_num = 1; ; ck_num++, function_args_iter_next (&iter))
6065 argument = function_args_iter_cond (&iter);
6066 if (!argument || ck_num == arg_num)
6067 break;
6070 if (!argument
6071 || TREE_CODE (argument) == VOID_TYPE)
6073 error ("nonnull argument with out-of-range operand number "
6074 "(argument %lu, operand %lu)",
6075 (unsigned long) attr_arg_num, (unsigned long) arg_num);
6076 *no_add_attrs = true;
6077 return NULL_TREE;
6080 if (TREE_CODE (argument) != POINTER_TYPE)
6082 error ("nonnull argument references non-pointer operand "
6083 "(argument %lu, operand %lu)",
6084 (unsigned long) attr_arg_num, (unsigned long) arg_num);
6085 *no_add_attrs = true;
6086 return NULL_TREE;
6091 return NULL_TREE;
6094 /* Handle a "sentinel" attribute. */
6096 static tree
6097 handle_sentinel_attribute (tree *node, tree name, tree args,
6098 int ARG_UNUSED (flags), bool *no_add_attrs)
6100 if (!prototype_p (*node))
6102 warning (OPT_Wattributes,
6103 "%qs attribute requires prototypes with named arguments",
6104 IDENTIFIER_POINTER (name));
6105 *no_add_attrs = true;
6107 else
6109 if (!stdarg_p (*node))
6111 warning (OPT_Wattributes,
6112 "%qs attribute only applies to variadic functions",
6113 IDENTIFIER_POINTER (name));
6114 *no_add_attrs = true;
6118 if (args)
6120 tree position = TREE_VALUE (args);
6122 if (TREE_CODE (position) != INTEGER_CST)
6124 warning (0, "requested position is not an integer constant");
6125 *no_add_attrs = true;
6127 else
6129 if (tree_int_cst_lt (position, integer_zero_node))
6131 warning (0, "requested position is less than zero");
6132 *no_add_attrs = true;
6137 return NULL_TREE;
6140 /* Handle a "noreturn" attribute; arguments as in
6141 struct attribute_spec.handler. */
6143 static tree
6144 handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6145 int ARG_UNUSED (flags), bool *no_add_attrs)
6147 tree type = TREE_TYPE (*node);
6149 /* See FIXME comment in c_common_attribute_table. */
6150 if (TREE_CODE (*node) == FUNCTION_DECL)
6151 TREE_THIS_VOLATILE (*node) = 1;
6152 else if (TREE_CODE (type) == POINTER_TYPE
6153 && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
6154 TREE_TYPE (*node)
6155 = build_pointer_type
6156 (build_type_variant (TREE_TYPE (type),
6157 TYPE_READONLY (TREE_TYPE (type)), 1));
6158 else
6160 warning (OPT_Wattributes, "%qs attribute ignored",
6161 IDENTIFIER_POINTER (name));
6162 *no_add_attrs = true;
6165 return NULL_TREE;
6168 /* Handle a "noinline" attribute; arguments as in
6169 struct attribute_spec.handler. */
6171 static tree
6172 handle_noinline_attribute (tree *node, tree name,
6173 tree ARG_UNUSED (args),
6174 int ARG_UNUSED (flags), bool *no_add_attrs)
6176 if (TREE_CODE (*node) == FUNCTION_DECL)
6178 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (*node)))
6180 warning (OPT_Wattributes, "%qE attribute ignored due to conflict "
6181 "with attribute %qs", name, "always_inline");
6182 *no_add_attrs = true;
6184 else
6185 DECL_UNINLINABLE (*node) = 1;
6187 else
6189 warning (OPT_Wattributes, "%qE attribute ignored", name);
6190 *no_add_attrs = true;
6193 return NULL_TREE;
6196 /* Handle a "noclone" attribute; arguments as in
6197 struct attribute_spec.handler. */
6199 static tree
6200 handle_noclone_attribute (tree *node, tree name,
6201 tree ARG_UNUSED (args),
6202 int ARG_UNUSED (flags), bool *no_add_attrs)
6204 if (TREE_CODE (*node) != FUNCTION_DECL)
6206 warning (OPT_Wattributes, "%qE attribute ignored", name);
6207 *no_add_attrs = true;
6210 return NULL_TREE;
6213 /* Handle a "leaf" attribute; arguments as in
6214 struct attribute_spec.handler. */
6216 static tree
6217 handle_leaf_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6218 int ARG_UNUSED (flags), bool *no_add_attrs)
6220 if (TREE_CODE (*node) != FUNCTION_DECL)
6222 warning (OPT_Wattributes, "%qE attribute ignored", name);
6223 *no_add_attrs = true;
6225 if (!TREE_PUBLIC (*node))
6227 warning (OPT_Wattributes, "%qE attribute has no effect", name);
6228 *no_add_attrs = true;
6231 return NULL_TREE;
6234 /* Handle a "always_inline" attribute; arguments as in
6235 struct attribute_spec.handler. */
6237 static tree
6238 handle_always_inline_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6239 int ARG_UNUSED (flags), bool *no_add_attrs)
6241 if (TREE_CODE (*node) == FUNCTION_DECL)
6243 /* Set the attribute and mark it for disregarding inline limits. */
6244 DECL_DISREGARD_INLINE_LIMITS (*node) = 1;
6246 else
6248 warning (OPT_Wattributes, "%qE attribute ignored", name);
6249 *no_add_attrs = true;
6252 return NULL_TREE;
6255 /* Handle a "malloc" attribute; arguments as in
6256 struct attribute_spec.handler. */
6258 static tree
6259 handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6260 int ARG_UNUSED (flags), bool *no_add_attrs)
6262 if (TREE_CODE (*node) == FUNCTION_DECL
6263 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node))))
6264 DECL_IS_MALLOC (*node) = 1;
6265 else
6267 warning (OPT_Wattributes, "%qs attribute ignored",
6268 IDENTIFIER_POINTER (name));
6269 *no_add_attrs = true;
6272 return NULL_TREE;
6275 /* Fake handler for attributes we don't properly support. */
6277 tree
6278 fake_attribute_handler (tree * ARG_UNUSED (node),
6279 tree ARG_UNUSED (name),
6280 tree ARG_UNUSED (args),
6281 int ARG_UNUSED (flags),
6282 bool * ARG_UNUSED (no_add_attrs))
6284 return NULL_TREE;
6287 /* Handle a "type_generic" attribute. */
6289 static tree
6290 handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name),
6291 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
6292 bool * ARG_UNUSED (no_add_attrs))
6294 /* Ensure we have a function type. */
6295 gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE);
6297 /* Ensure we have a variadic function. */
6298 gcc_assert (!prototype_p (*node) || stdarg_p (*node));
6300 return NULL_TREE;
6303 /* Handle a "vector_size" attribute; arguments as in
6304 struct attribute_spec.handler. */
6306 static tree
6307 handle_vector_size_attribute (tree *node, tree name, tree args,
6308 int ARG_UNUSED (flags), bool *no_add_attrs)
6310 tree type = *node;
6311 tree vector_type;
6313 *no_add_attrs = true;
6315 /* We need to provide for vector pointers, vector arrays, and
6316 functions returning vectors. For example:
6318 __attribute__((vector_size(16))) short *foo;
6320 In this case, the mode is SI, but the type being modified is
6321 HI, so we need to look further. */
6322 while (POINTER_TYPE_P (type)
6323 || TREE_CODE (type) == FUNCTION_TYPE
6324 || TREE_CODE (type) == ARRAY_TYPE)
6325 type = TREE_TYPE (type);
6327 vector_type = build_vector_type_for_size (type, TREE_VALUE (args), name);
6328 if (!vector_type)
6329 return NULL_TREE;
6331 /* Build back pointers if needed. */
6332 *node = reconstruct_complex_type (*node, vector_type);
6334 return NULL_TREE;
6337 /* Handle a "vector_type" attribute; arguments as in
6338 struct attribute_spec.handler. */
6340 static tree
6341 handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args),
6342 int ARG_UNUSED (flags), bool *no_add_attrs)
6344 tree type = *node;
6345 tree vector_type;
6347 *no_add_attrs = true;
6349 if (TREE_CODE (type) != ARRAY_TYPE)
6351 error ("attribute %qs applies to array types only",
6352 IDENTIFIER_POINTER (name));
6353 return NULL_TREE;
6356 vector_type = build_vector_type_for_array (type, name);
6357 if (!vector_type)
6358 return NULL_TREE;
6360 TYPE_REPRESENTATIVE_ARRAY (vector_type) = type;
6361 *node = vector_type;
6363 return NULL_TREE;
6366 /* ----------------------------------------------------------------------- *
6367 * BUILTIN FUNCTIONS *
6368 * ----------------------------------------------------------------------- */
6370 /* Worker for DEF_BUILTIN. Possibly define a builtin function with one or two
6371 names. Does not declare a non-__builtin_ function if flag_no_builtin, or
6372 if nonansi_p and flag_no_nonansi_builtin. */
6374 static void
6375 def_builtin_1 (enum built_in_function fncode,
6376 const char *name,
6377 enum built_in_class fnclass,
6378 tree fntype, tree libtype,
6379 bool both_p, bool fallback_p,
6380 bool nonansi_p ATTRIBUTE_UNUSED,
6381 tree fnattrs, bool implicit_p)
6383 tree decl;
6384 const char *libname;
6386 /* Preserve an already installed decl. It most likely was setup in advance
6387 (e.g. as part of the internal builtins) for specific reasons. */
6388 if (builtin_decl_explicit (fncode))
6389 return;
6391 gcc_assert ((!both_p && !fallback_p)
6392 || !strncmp (name, "__builtin_",
6393 strlen ("__builtin_")));
6395 libname = name + strlen ("__builtin_");
6396 decl = add_builtin_function (name, fntype, fncode, fnclass,
6397 (fallback_p ? libname : NULL),
6398 fnattrs);
6399 if (both_p)
6400 /* ??? This is normally further controlled by command-line options
6401 like -fno-builtin, but we don't have them for Ada. */
6402 add_builtin_function (libname, libtype, fncode, fnclass,
6403 NULL, fnattrs);
6405 set_builtin_decl (fncode, decl, implicit_p);
6408 static int flag_isoc94 = 0;
6409 static int flag_isoc99 = 0;
6410 static int flag_isoc11 = 0;
6412 /* Install what the common builtins.def offers. */
6414 static void
6415 install_builtin_functions (void)
6417 #define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \
6418 NONANSI_P, ATTRS, IMPLICIT, COND) \
6419 if (NAME && COND) \
6420 def_builtin_1 (ENUM, NAME, CLASS, \
6421 builtin_types[(int) TYPE], \
6422 builtin_types[(int) LIBTYPE], \
6423 BOTH_P, FALLBACK_P, NONANSI_P, \
6424 built_in_attributes[(int) ATTRS], IMPLICIT);
6425 #include "builtins.def"
6428 /* ----------------------------------------------------------------------- *
6429 * BUILTIN FUNCTIONS *
6430 * ----------------------------------------------------------------------- */
6432 /* Install the builtin functions we might need. */
6434 void
6435 gnat_install_builtins (void)
6437 install_builtin_elementary_types ();
6438 install_builtin_function_types ();
6439 install_builtin_attributes ();
6441 /* Install builtins used by generic middle-end pieces first. Some of these
6442 know about internal specificities and control attributes accordingly, for
6443 instance __builtin_alloca vs no-throw and -fstack-check. We will ignore
6444 the generic definition from builtins.def. */
6445 build_common_builtin_nodes ();
6447 /* Now, install the target specific builtins, such as the AltiVec family on
6448 ppc, and the common set as exposed by builtins.def. */
6449 targetm.init_builtins ();
6450 install_builtin_functions ();
6453 #include "gt-ada-utils.h"
6454 #include "gtype-ada.h"