1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2012, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License along with GCC; see the file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
33 #include "diagnostic-core.h"
39 #include "common/common-target.h"
40 #include "langhooks.h"
42 #include "diagnostic.h"
43 #include "tree-dump.h"
44 #include "tree-inline.h"
45 #include "tree-iterator.h"
61 #ifndef MAX_BITS_PER_WORD
62 #define MAX_BITS_PER_WORD BITS_PER_WORD
65 /* If nonzero, pretend we are allocating at global level. */
68 /* The default alignment of "double" floating-point types, i.e. floating
69 point types whose size is equal to 64 bits, or 0 if this alignment is
70 not specifically capped. */
71 int double_float_alignment;
73 /* The default alignment of "double" or larger scalar types, i.e. scalar
74 types whose size is greater or equal to 64 bits, or 0 if this alignment
75 is not specifically capped. */
76 int double_scalar_alignment;
78 /* Tree nodes for the various types and decls we create. */
79 tree gnat_std_decls[(int) ADT_LAST];
81 /* Functions to call for each of the possible raise reasons. */
82 tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
84 /* Likewise, but with extra info for each of the possible raise reasons. */
85 tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1];
87 /* Forward declarations for handlers of attributes. */
88 static tree handle_const_attribute (tree *, tree, tree, int, bool *);
89 static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *);
90 static tree handle_pure_attribute (tree *, tree, tree, int, bool *);
91 static tree handle_novops_attribute (tree *, tree, tree, int, bool *);
92 static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *);
93 static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *);
94 static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *);
95 static tree handle_leaf_attribute (tree *, tree, tree, int, bool *);
96 static tree handle_malloc_attribute (tree *, tree, tree, int, bool *);
97 static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *);
98 static tree handle_vector_size_attribute (tree *, tree, tree, int, bool *);
99 static tree handle_vector_type_attribute (tree *, tree, tree, int, bool *);
101 /* Fake handler for attributes we don't properly support, typically because
102 they'd require dragging a lot of the common-c front-end circuitry. */
103 static tree fake_attribute_handler (tree *, tree, tree, int, bool *);
105 /* Table of machine-independent internal attributes for Ada. We support
106 this minimal set of attributes to accommodate the needs of builtins. */
107 const struct attribute_spec gnat_internal_attribute_table[] =
109 /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler,
110 affects_type_identity } */
111 { "const", 0, 0, true, false, false, handle_const_attribute,
113 { "nothrow", 0, 0, true, false, false, handle_nothrow_attribute,
115 { "pure", 0, 0, true, false, false, handle_pure_attribute,
117 { "no vops", 0, 0, true, false, false, handle_novops_attribute,
119 { "nonnull", 0, -1, false, true, true, handle_nonnull_attribute,
121 { "sentinel", 0, 1, false, true, true, handle_sentinel_attribute,
123 { "noreturn", 0, 0, true, false, false, handle_noreturn_attribute,
125 { "leaf", 0, 0, true, false, false, handle_leaf_attribute,
127 { "malloc", 0, 0, true, false, false, handle_malloc_attribute,
129 { "type generic", 0, 0, false, true, true, handle_type_generic_attribute,
132 { "vector_size", 1, 1, false, true, false, handle_vector_size_attribute,
134 { "vector_type", 0, 0, false, true, false, handle_vector_type_attribute,
136 { "may_alias", 0, 0, false, true, false, NULL, false },
138 /* ??? format and format_arg are heavy and not supported, which actually
139 prevents support for stdio builtins, which we however declare as part
140 of the common builtins.def contents. */
141 { "format", 3, 3, false, true, true, fake_attribute_handler, false },
142 { "format_arg", 1, 1, false, true, true, fake_attribute_handler, false },
144 { NULL, 0, 0, false, false, false, NULL, false }
147 /* Associates a GNAT tree node to a GCC tree node. It is used in
148 `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
149 of `save_gnu_tree' for more info. */
150 static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
152 #define GET_GNU_TREE(GNAT_ENTITY) \
153 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id]
155 #define SET_GNU_TREE(GNAT_ENTITY,VAL) \
156 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL)
158 #define PRESENT_GNU_TREE(GNAT_ENTITY) \
159 (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
161 /* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */
162 static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table;
164 #define GET_DUMMY_NODE(GNAT_ENTITY) \
165 dummy_node_table[(GNAT_ENTITY) - First_Node_Id]
167 #define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \
168 dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL)
170 #define PRESENT_DUMMY_NODE(GNAT_ENTITY) \
171 (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
173 /* This variable keeps a table for types for each precision so that we only
174 allocate each of them once. Signed and unsigned types are kept separate.
176 Note that these types are only used when fold-const requests something
177 special. Perhaps we should NOT share these types; we'll see how it
179 static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
181 /* Likewise for float types, but record these by mode. */
182 static GTY(()) tree float_types[NUM_MACHINE_MODES];
184 /* For each binding contour we allocate a binding_level structure to indicate
185 the binding depth. */
187 struct GTY((chain_next ("%h.chain"))) gnat_binding_level {
188 /* The binding level containing this one (the enclosing binding level). */
189 struct gnat_binding_level *chain;
190 /* The BLOCK node for this level. */
192 /* If nonzero, the setjmp buffer that needs to be updated for any
193 variable-sized definition within this context. */
197 /* The binding level currently in effect. */
198 static GTY(()) struct gnat_binding_level *current_binding_level;
200 /* A chain of gnat_binding_level structures awaiting reuse. */
201 static GTY((deletable)) struct gnat_binding_level *free_binding_level;
203 /* The context to be used for global declarations. */
204 static GTY(()) tree global_context;
206 /* An array of global declarations. */
207 static GTY(()) VEC(tree,gc) *global_decls;
209 /* An array of builtin function declarations. */
210 static GTY(()) VEC(tree,gc) *builtin_decls;
212 /* An array of global renaming pointers. */
213 static GTY(()) VEC(tree,gc) *global_renaming_pointers;
215 /* A chain of unused BLOCK nodes. */
216 static GTY((deletable)) tree free_block_chain;
218 static tree merge_sizes (tree, tree, tree, bool, bool);
219 static tree compute_related_constant (tree, tree);
220 static tree split_plus (tree, tree *);
221 static tree float_type_for_precision (int, enum machine_mode);
222 static tree convert_to_fat_pointer (tree, tree);
223 static tree convert_to_thin_pointer (tree, tree);
224 static bool potential_alignment_gap (tree, tree, tree);
225 static void process_attributes (tree, struct attrib *);
227 /* Initialize the association of GNAT nodes to GCC trees. */
230 init_gnat_to_gnu (void)
232 associate_gnat_to_gnu = ggc_alloc_cleared_vec_tree (max_gnat_nodes);
235 /* GNAT_ENTITY is a GNAT tree node for an entity. Associate GNU_DECL, a GCC
236 tree node, with GNAT_ENTITY. If GNU_DECL is not a ..._DECL node, abort.
237 If NO_CHECK is true, the latter check is suppressed.
239 If GNU_DECL is zero, reset a previous association. */
242 save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check)
244 /* Check that GNAT_ENTITY is not already defined and that it is being set
245 to something which is a decl. If that is not the case, this usually
246 means GNAT_ENTITY is defined twice, but occasionally is due to some
248 gcc_assert (!(gnu_decl
249 && (PRESENT_GNU_TREE (gnat_entity)
250 || (!no_check && !DECL_P (gnu_decl)))));
252 SET_GNU_TREE (gnat_entity, gnu_decl);
255 /* GNAT_ENTITY is a GNAT tree node for an entity. Return the GCC tree node
256 that was associated with it. If there is no such tree node, abort.
258 In some cases, such as delayed elaboration or expressions that need to
259 be elaborated only once, GNAT_ENTITY is really not an entity. */
262 get_gnu_tree (Entity_Id gnat_entity)
264 gcc_assert (PRESENT_GNU_TREE (gnat_entity));
265 return GET_GNU_TREE (gnat_entity);
268 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
271 present_gnu_tree (Entity_Id gnat_entity)
273 return PRESENT_GNU_TREE (gnat_entity);
276 /* Initialize the association of GNAT nodes to GCC trees as dummies. */
279 init_dummy_type (void)
281 dummy_node_table = ggc_alloc_cleared_vec_tree (max_gnat_nodes);
284 /* Make a dummy type corresponding to GNAT_TYPE. */
287 make_dummy_type (Entity_Id gnat_type)
289 Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type);
292 /* If there is an equivalent type, get its underlying type. */
293 if (Present (gnat_underlying))
294 gnat_underlying = Underlying_Type (gnat_underlying);
296 /* If there was no equivalent type (can only happen when just annotating
297 types) or underlying type, go back to the original type. */
298 if (No (gnat_underlying))
299 gnat_underlying = gnat_type;
301 /* If it there already a dummy type, use that one. Else make one. */
302 if (PRESENT_DUMMY_NODE (gnat_underlying))
303 return GET_DUMMY_NODE (gnat_underlying);
305 /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make
307 gnu_type = make_node (Is_Record_Type (gnat_underlying)
308 ? tree_code_for_record_type (gnat_underlying)
310 TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
311 TYPE_DUMMY_P (gnu_type) = 1;
312 TYPE_STUB_DECL (gnu_type)
313 = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
314 if (Is_By_Reference_Type (gnat_type))
315 TREE_ADDRESSABLE (gnu_type) = 1;
317 SET_DUMMY_NODE (gnat_underlying, gnu_type);
322 /* Return the dummy type that was made for GNAT_TYPE, if any. */
325 get_dummy_type (Entity_Id gnat_type)
327 return GET_DUMMY_NODE (gnat_type);
330 /* Build dummy fat and thin pointer types whose designated type is specified
331 by GNAT_DESIG_TYPE/GNU_DESIG_TYPE and attach them to the latter. */
334 build_dummy_unc_pointer_types (Entity_Id gnat_desig_type, tree gnu_desig_type)
336 tree gnu_template_type, gnu_ptr_template, gnu_array_type, gnu_ptr_array;
337 tree gnu_fat_type, fields, gnu_object_type;
339 gnu_template_type = make_node (RECORD_TYPE);
340 TYPE_NAME (gnu_template_type) = create_concat_name (gnat_desig_type, "XUB");
341 TYPE_DUMMY_P (gnu_template_type) = 1;
342 gnu_ptr_template = build_pointer_type (gnu_template_type);
344 gnu_array_type = make_node (ENUMERAL_TYPE);
345 TYPE_NAME (gnu_array_type) = create_concat_name (gnat_desig_type, "XUA");
346 TYPE_DUMMY_P (gnu_array_type) = 1;
347 gnu_ptr_array = build_pointer_type (gnu_array_type);
349 gnu_fat_type = make_node (RECORD_TYPE);
350 /* Build a stub DECL to trigger the special processing for fat pointer types
352 TYPE_NAME (gnu_fat_type)
353 = create_type_stub_decl (create_concat_name (gnat_desig_type, "XUP"),
355 fields = create_field_decl (get_identifier ("P_ARRAY"), gnu_ptr_array,
356 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
358 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
359 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
360 finish_fat_pointer_type (gnu_fat_type, fields);
361 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_desig_type);
362 /* Suppress debug info until after the type is completed. */
363 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 1;
365 gnu_object_type = make_node (RECORD_TYPE);
366 TYPE_NAME (gnu_object_type) = create_concat_name (gnat_desig_type, "XUT");
367 TYPE_DUMMY_P (gnu_object_type) = 1;
369 TYPE_POINTER_TO (gnu_desig_type) = gnu_fat_type;
370 TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type;
373 /* Return true if we are in the global binding level. */
376 global_bindings_p (void)
378 return force_global || current_function_decl == NULL_TREE;
381 /* Enter a new binding level. */
384 gnat_pushlevel (void)
386 struct gnat_binding_level *newlevel = NULL;
388 /* Reuse a struct for this binding level, if there is one. */
389 if (free_binding_level)
391 newlevel = free_binding_level;
392 free_binding_level = free_binding_level->chain;
395 newlevel = ggc_alloc_gnat_binding_level ();
397 /* Use a free BLOCK, if any; otherwise, allocate one. */
398 if (free_block_chain)
400 newlevel->block = free_block_chain;
401 free_block_chain = BLOCK_CHAIN (free_block_chain);
402 BLOCK_CHAIN (newlevel->block) = NULL_TREE;
405 newlevel->block = make_node (BLOCK);
407 /* Point the BLOCK we just made to its parent. */
408 if (current_binding_level)
409 BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
411 BLOCK_VARS (newlevel->block) = NULL_TREE;
412 BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
413 TREE_USED (newlevel->block) = 1;
415 /* Add this level to the front of the chain (stack) of active levels. */
416 newlevel->chain = current_binding_level;
417 newlevel->jmpbuf_decl = NULL_TREE;
418 current_binding_level = newlevel;
421 /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
422 and point FNDECL to this BLOCK. */
425 set_current_block_context (tree fndecl)
427 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
428 DECL_INITIAL (fndecl) = current_binding_level->block;
429 set_block_for_group (current_binding_level->block);
432 /* Set the jmpbuf_decl for the current binding level to DECL. */
435 set_block_jmpbuf_decl (tree decl)
437 current_binding_level->jmpbuf_decl = decl;
440 /* Get the jmpbuf_decl, if any, for the current binding level. */
443 get_block_jmpbuf_decl (void)
445 return current_binding_level->jmpbuf_decl;
448 /* Exit a binding level. Set any BLOCK into the current code group. */
453 struct gnat_binding_level *level = current_binding_level;
454 tree block = level->block;
456 BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
457 BLOCK_SUBBLOCKS (block) = blocks_nreverse (BLOCK_SUBBLOCKS (block));
459 /* If this is a function-level BLOCK don't do anything. Otherwise, if there
460 are no variables free the block and merge its subblocks into those of its
461 parent block. Otherwise, add it to the list of its parent. */
462 if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
464 else if (BLOCK_VARS (block) == NULL_TREE)
466 BLOCK_SUBBLOCKS (level->chain->block)
467 = block_chainon (BLOCK_SUBBLOCKS (block),
468 BLOCK_SUBBLOCKS (level->chain->block));
469 BLOCK_CHAIN (block) = free_block_chain;
470 free_block_chain = block;
474 BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block);
475 BLOCK_SUBBLOCKS (level->chain->block) = block;
476 TREE_USED (block) = 1;
477 set_block_for_group (block);
480 /* Free this binding structure. */
481 current_binding_level = level->chain;
482 level->chain = free_binding_level;
483 free_binding_level = level;
486 /* Exit a binding level and discard the associated BLOCK. */
491 struct gnat_binding_level *level = current_binding_level;
492 tree block = level->block;
494 BLOCK_CHAIN (block) = free_block_chain;
495 free_block_chain = block;
497 /* Free this binding structure. */
498 current_binding_level = level->chain;
499 level->chain = free_binding_level;
500 free_binding_level = level;
503 /* Record DECL as belonging to the current lexical scope and use GNAT_NODE
504 for location information and flag propagation. */
507 gnat_pushdecl (tree decl, Node_Id gnat_node)
509 /* If DECL is public external or at top level, it has global context. */
510 if ((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || global_bindings_p ())
513 global_context = build_translation_unit_decl (NULL_TREE);
514 DECL_CONTEXT (decl) = global_context;
518 DECL_CONTEXT (decl) = current_function_decl;
520 /* Functions imported in another function are not really nested.
521 For really nested functions mark them initially as needing
522 a static chain for uses of that flag before unnesting;
523 lower_nested_functions will then recompute it. */
524 if (TREE_CODE (decl) == FUNCTION_DECL && !TREE_PUBLIC (decl))
525 DECL_STATIC_CHAIN (decl) = 1;
528 TREE_NO_WARNING (decl) = (No (gnat_node) || Warnings_Off (gnat_node));
530 /* Set the location of DECL and emit a declaration for it. */
531 if (Present (gnat_node))
532 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl));
534 add_decl_expr (decl, gnat_node);
536 /* Put the declaration on the list. The list of declarations is in reverse
537 order. The list will be reversed later. Put global declarations in the
538 globals list and local ones in the current block. But skip TYPE_DECLs
539 for UNCONSTRAINED_ARRAY_TYPE in both cases, as they will cause trouble
540 with the debugger and aren't needed anyway. */
541 if (!(TREE_CODE (decl) == TYPE_DECL
542 && TREE_CODE (TREE_TYPE (decl)) == UNCONSTRAINED_ARRAY_TYPE))
544 if (global_bindings_p ())
546 VEC_safe_push (tree, gc, global_decls, decl);
548 if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl))
549 VEC_safe_push (tree, gc, builtin_decls, decl);
551 else if (!DECL_EXTERNAL (decl))
553 DECL_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
554 BLOCK_VARS (current_binding_level->block) = decl;
558 /* For the declaration of a type, set its name if it either is not already
559 set or if the previous type name was not derived from a source name.
560 We'd rather have the type named with a real name and all the pointer
561 types to the same object have the same POINTER_TYPE node. Code in the
562 equivalent function of c-decl.c makes a copy of the type node here, but
563 that may cause us trouble with incomplete types. We make an exception
564 for fat pointer types because the compiler automatically builds them
565 for unconstrained array types and the debugger uses them to represent
566 both these and pointers to these. */
567 if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl))
569 tree t = TREE_TYPE (decl);
571 if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
573 /* Array and pointer types aren't "tagged" types so we force the
574 type to be associated with its typedef in the DWARF back-end,
575 in order to make sure that the latter is always preserved. */
576 if (!DECL_ARTIFICIAL (decl)
577 && (TREE_CODE (t) == ARRAY_TYPE
578 || TREE_CODE (t) == POINTER_TYPE))
580 tree tt = build_distinct_type_copy (t);
581 if (TREE_CODE (t) == POINTER_TYPE)
582 TYPE_NEXT_PTR_TO (t) = tt;
583 TYPE_NAME (tt) = DECL_NAME (decl);
584 TYPE_STUB_DECL (tt) = TYPE_STUB_DECL (t);
585 DECL_ORIGINAL_TYPE (decl) = tt;
588 else if (TYPE_IS_FAT_POINTER_P (t))
590 /* We need a variant for the placeholder machinery to work. */
591 tree tt = build_variant_type_copy (t);
592 TYPE_NAME (tt) = decl;
593 TREE_USED (tt) = TREE_USED (t);
594 TREE_TYPE (decl) = tt;
595 if (DECL_ORIGINAL_TYPE (TYPE_NAME (t)))
596 DECL_ORIGINAL_TYPE (decl) = DECL_ORIGINAL_TYPE (TYPE_NAME (t));
598 DECL_ORIGINAL_TYPE (decl) = t;
599 DECL_ARTIFICIAL (decl) = 0;
602 else if (DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl))
607 /* Propagate the name to all the anonymous variants. This is needed
608 for the type qualifiers machinery to work properly. */
610 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
611 if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
612 TYPE_NAME (t) = decl;
616 /* Record TYPE as a builtin type for Ada. NAME is the name of the type.
617 ARTIFICIAL_P is true if it's a type that was generated by the compiler. */
620 record_builtin_type (const char *name, tree type, bool artificial_p)
622 tree type_decl = build_decl (input_location,
623 TYPE_DECL, get_identifier (name), type);
624 DECL_ARTIFICIAL (type_decl) = artificial_p;
625 TYPE_ARTIFICIAL (type) = artificial_p;
626 gnat_pushdecl (type_decl, Empty);
628 if (debug_hooks->type_decl)
629 debug_hooks->type_decl (type_decl, false);
632 /* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
633 finish constructing the record type as a fat pointer type. */
636 finish_fat_pointer_type (tree record_type, tree field_list)
638 /* Make sure we can put it into a register. */
639 TYPE_ALIGN (record_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
641 /* Show what it really is. */
642 TYPE_FAT_POINTER_P (record_type) = 1;
644 /* Do not emit debug info for it since the types of its fields may still be
645 incomplete at this point. */
646 finish_record_type (record_type, field_list, 0, false);
648 /* Force type_contains_placeholder_p to return true on it. Although the
649 PLACEHOLDER_EXPRs are referenced only indirectly, this isn't a pointer
650 type but the representation of the unconstrained array. */
651 TYPE_CONTAINS_PLACEHOLDER_INTERNAL (record_type) = 2;
654 /* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
655 finish constructing the record or union type. If REP_LEVEL is zero, this
656 record has no representation clause and so will be entirely laid out here.
657 If REP_LEVEL is one, this record has a representation clause and has been
658 laid out already; only set the sizes and alignment. If REP_LEVEL is two,
659 this record is derived from a parent record and thus inherits its layout;
660 only make a pass on the fields to finalize them. DEBUG_INFO_P is true if
661 we need to write debug information about this type. */
664 finish_record_type (tree record_type, tree field_list, int rep_level,
667 enum tree_code code = TREE_CODE (record_type);
668 tree name = TYPE_NAME (record_type);
669 tree ada_size = bitsize_zero_node;
670 tree size = bitsize_zero_node;
671 bool had_size = TYPE_SIZE (record_type) != 0;
672 bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0;
673 bool had_align = TYPE_ALIGN (record_type) != 0;
676 TYPE_FIELDS (record_type) = field_list;
678 /* Always attach the TYPE_STUB_DECL for a record type. It is required to
679 generate debug info and have a parallel type. */
680 if (name && TREE_CODE (name) == TYPE_DECL)
681 name = DECL_NAME (name);
682 TYPE_STUB_DECL (record_type) = create_type_stub_decl (name, record_type);
684 /* Globally initialize the record first. If this is a rep'ed record,
685 that just means some initializations; otherwise, layout the record. */
688 TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
691 TYPE_SIZE_UNIT (record_type) = size_zero_node;
694 TYPE_SIZE (record_type) = bitsize_zero_node;
696 /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
697 out just like a UNION_TYPE, since the size will be fixed. */
698 else if (code == QUAL_UNION_TYPE)
703 /* Ensure there isn't a size already set. There can be in an error
704 case where there is a rep clause but all fields have errors and
705 no longer have a position. */
706 TYPE_SIZE (record_type) = 0;
707 layout_type (record_type);
710 /* At this point, the position and size of each field is known. It was
711 either set before entry by a rep clause, or by laying out the type above.
713 We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs)
714 to compute the Ada size; the GCC size and alignment (for rep'ed records
715 that are not padding types); and the mode (for rep'ed records). We also
716 clear the DECL_BIT_FIELD indication for the cases we know have not been
717 handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */
719 if (code == QUAL_UNION_TYPE)
720 field_list = nreverse (field_list);
722 for (field = field_list; field; field = DECL_CHAIN (field))
724 tree type = TREE_TYPE (field);
725 tree pos = bit_position (field);
726 tree this_size = DECL_SIZE (field);
729 if (RECORD_OR_UNION_TYPE_P (type)
730 && !TYPE_FAT_POINTER_P (type)
731 && !TYPE_CONTAINS_TEMPLATE_P (type)
732 && TYPE_ADA_SIZE (type))
733 this_ada_size = TYPE_ADA_SIZE (type);
735 this_ada_size = this_size;
737 /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */
738 if (DECL_BIT_FIELD (field)
739 && operand_equal_p (this_size, TYPE_SIZE (type), 0))
741 unsigned int align = TYPE_ALIGN (type);
743 /* In the general case, type alignment is required. */
744 if (value_factor_p (pos, align))
746 /* The enclosing record type must be sufficiently aligned.
747 Otherwise, if no alignment was specified for it and it
748 has been laid out already, bump its alignment to the
749 desired one if this is compatible with its size. */
750 if (TYPE_ALIGN (record_type) >= align)
752 DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
753 DECL_BIT_FIELD (field) = 0;
757 && value_factor_p (TYPE_SIZE (record_type), align))
759 TYPE_ALIGN (record_type) = align;
760 DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
761 DECL_BIT_FIELD (field) = 0;
765 /* In the non-strict alignment case, only byte alignment is. */
766 if (!STRICT_ALIGNMENT
767 && DECL_BIT_FIELD (field)
768 && value_factor_p (pos, BITS_PER_UNIT))
769 DECL_BIT_FIELD (field) = 0;
772 /* If we still have DECL_BIT_FIELD set at this point, we know that the
773 field is technically not addressable. Except that it can actually
774 be addressed if it is BLKmode and happens to be properly aligned. */
775 if (DECL_BIT_FIELD (field)
776 && !(DECL_MODE (field) == BLKmode
777 && value_factor_p (pos, BITS_PER_UNIT)))
778 DECL_NONADDRESSABLE_P (field) = 1;
780 /* A type must be as aligned as its most aligned field that is not
781 a bit-field. But this is already enforced by layout_type. */
782 if (rep_level > 0 && !DECL_BIT_FIELD (field))
783 TYPE_ALIGN (record_type)
784 = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
789 ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size);
790 size = size_binop (MAX_EXPR, size, this_size);
793 case QUAL_UNION_TYPE:
795 = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
796 this_ada_size, ada_size);
797 size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
802 /* Since we know here that all fields are sorted in order of
803 increasing bit position, the size of the record is one
804 higher than the ending bit of the last field processed
805 unless we have a rep clause, since in that case we might
806 have a field outside a QUAL_UNION_TYPE that has a higher ending
807 position. So use a MAX in that case. Also, if this field is a
808 QUAL_UNION_TYPE, we need to take into account the previous size in
809 the case of empty variants. */
811 = merge_sizes (ada_size, pos, this_ada_size,
812 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
814 = merge_sizes (size, pos, this_size,
815 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
823 if (code == QUAL_UNION_TYPE)
824 nreverse (field_list);
828 /* If this is a padding record, we never want to make the size smaller
829 than what was specified in it, if any. */
830 if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
831 size = TYPE_SIZE (record_type);
833 /* Now set any of the values we've just computed that apply. */
834 if (!TYPE_FAT_POINTER_P (record_type)
835 && !TYPE_CONTAINS_TEMPLATE_P (record_type))
836 SET_TYPE_ADA_SIZE (record_type, ada_size);
840 tree size_unit = had_size_unit
841 ? TYPE_SIZE_UNIT (record_type)
843 size_binop (CEIL_DIV_EXPR, size,
845 unsigned int align = TYPE_ALIGN (record_type);
847 TYPE_SIZE (record_type) = variable_size (round_up (size, align));
848 TYPE_SIZE_UNIT (record_type)
849 = variable_size (round_up (size_unit, align / BITS_PER_UNIT));
851 compute_record_mode (record_type);
856 rest_of_record_type_compilation (record_type);
859 /* Wrap up compilation of RECORD_TYPE, i.e. output all the debug information
860 associated with it. It need not be invoked directly in most cases since
861 finish_record_type takes care of doing so, but this can be necessary if
862 a parallel type is to be attached to the record type. */
865 rest_of_record_type_compilation (tree record_type)
867 tree field_list = TYPE_FIELDS (record_type);
869 enum tree_code code = TREE_CODE (record_type);
870 bool var_size = false;
872 for (field = field_list; field; field = DECL_CHAIN (field))
874 /* We need to make an XVE/XVU record if any field has variable size,
875 whether or not the record does. For example, if we have a union,
876 it may be that all fields, rounded up to the alignment, have the
877 same size, in which case we'll use that size. But the debug
878 output routines (except Dwarf2) won't be able to output the fields,
879 so we need to make the special record. */
880 if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST
881 /* If a field has a non-constant qualifier, the record will have
882 variable size too. */
883 || (code == QUAL_UNION_TYPE
884 && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST))
891 /* If this record is of variable size, rename it so that the
892 debugger knows it is and make a new, parallel, record
893 that tells the debugger how the record is laid out. See
894 exp_dbug.ads. But don't do this for records that are padding
895 since they confuse GDB. */
896 if (var_size && !TYPE_IS_PADDING_P (record_type))
899 = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
900 ? UNION_TYPE : TREE_CODE (record_type));
901 tree orig_name = TYPE_NAME (record_type), new_name;
902 tree last_pos = bitsize_zero_node;
903 tree old_field, prev_old_field = NULL_TREE;
905 if (TREE_CODE (orig_name) == TYPE_DECL)
906 orig_name = DECL_NAME (orig_name);
909 = concat_name (orig_name, TREE_CODE (record_type) == QUAL_UNION_TYPE
911 TYPE_NAME (new_record_type) = new_name;
912 TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
913 TYPE_STUB_DECL (new_record_type)
914 = create_type_stub_decl (new_name, new_record_type);
915 DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
916 = DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
917 TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
918 TYPE_SIZE_UNIT (new_record_type)
919 = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT);
921 add_parallel_type (TYPE_STUB_DECL (record_type), new_record_type);
923 /* Now scan all the fields, replacing each field with a new
924 field corresponding to the new encoding. */
925 for (old_field = TYPE_FIELDS (record_type); old_field;
926 old_field = DECL_CHAIN (old_field))
928 tree field_type = TREE_TYPE (old_field);
929 tree field_name = DECL_NAME (old_field);
931 tree curpos = bit_position (old_field);
933 unsigned int align = 0;
936 /* See how the position was modified from the last position.
938 There are two basic cases we support: a value was added
939 to the last position or the last position was rounded to
940 a boundary and they something was added. Check for the
941 first case first. If not, see if there is any evidence
942 of rounding. If so, round the last position and try
945 If this is a union, the position can be taken as zero. */
947 /* Some computations depend on the shape of the position expression,
948 so strip conversions to make sure it's exposed. */
949 curpos = remove_conversions (curpos, true);
951 if (TREE_CODE (new_record_type) == UNION_TYPE)
952 pos = bitsize_zero_node, align = 0;
954 pos = compute_related_constant (curpos, last_pos);
956 if (!pos && TREE_CODE (curpos) == MULT_EXPR
957 && host_integerp (TREE_OPERAND (curpos, 1), 1))
959 tree offset = TREE_OPERAND (curpos, 0);
960 align = tree_low_cst (TREE_OPERAND (curpos, 1), 1);
962 /* An offset which is a bitwise AND with a negative power of 2
963 means an alignment corresponding to this power of 2. Note
964 that, as sizetype is sign-extended but nonetheless unsigned,
965 we don't directly use tree_int_cst_sgn. */
966 offset = remove_conversions (offset, true);
967 if (TREE_CODE (offset) == BIT_AND_EXPR
968 && host_integerp (TREE_OPERAND (offset, 1), 0)
969 && TREE_INT_CST_HIGH (TREE_OPERAND (offset, 1)) < 0)
972 = - tree_low_cst (TREE_OPERAND (offset, 1), 0);
973 if (exact_log2 (pow) > 0)
977 pos = compute_related_constant (curpos,
978 round_up (last_pos, align));
980 else if (!pos && TREE_CODE (curpos) == PLUS_EXPR
981 && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST
982 && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR
983 && host_integerp (TREE_OPERAND
984 (TREE_OPERAND (curpos, 0), 1),
989 (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1);
990 pos = compute_related_constant (curpos,
991 round_up (last_pos, align));
993 else if (potential_alignment_gap (prev_old_field, old_field,
996 align = TYPE_ALIGN (field_type);
997 pos = compute_related_constant (curpos,
998 round_up (last_pos, align));
1001 /* If we can't compute a position, set it to zero.
1003 ??? We really should abort here, but it's too much work
1004 to get this correct for all cases. */
1007 pos = bitsize_zero_node;
1009 /* See if this type is variable-sized and make a pointer type
1010 and indicate the indirection if so. Beware that the debug
1011 back-end may adjust the position computed above according
1012 to the alignment of the field type, i.e. the pointer type
1013 in this case, if we don't preventively counter that. */
1014 if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
1016 field_type = build_pointer_type (field_type);
1017 if (align != 0 && TYPE_ALIGN (field_type) > align)
1019 field_type = copy_node (field_type);
1020 TYPE_ALIGN (field_type) = align;
1025 /* Make a new field name, if necessary. */
1026 if (var || align != 0)
1031 sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
1032 align / BITS_PER_UNIT);
1034 strcpy (suffix, "XVL");
1036 field_name = concat_name (field_name, suffix);
1040 = create_field_decl (field_name, field_type, new_record_type,
1041 DECL_SIZE (old_field), pos, 0, 0);
1042 DECL_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
1043 TYPE_FIELDS (new_record_type) = new_field;
1045 /* If old_field is a QUAL_UNION_TYPE, take its size as being
1046 zero. The only time it's not the last field of the record
1047 is when there are other components at fixed positions after
1048 it (meaning there was a rep clause for every field) and we
1049 want to be able to encode them. */
1050 last_pos = size_binop (PLUS_EXPR, bit_position (old_field),
1051 (TREE_CODE (TREE_TYPE (old_field))
1054 : DECL_SIZE (old_field));
1055 prev_old_field = old_field;
1058 TYPE_FIELDS (new_record_type)
1059 = nreverse (TYPE_FIELDS (new_record_type));
1061 rest_of_type_decl_compilation (TYPE_STUB_DECL (new_record_type));
1064 rest_of_type_decl_compilation (TYPE_STUB_DECL (record_type));
1067 /* Append PARALLEL_TYPE on the chain of parallel types for decl. */
1070 add_parallel_type (tree decl, tree parallel_type)
1074 while (DECL_PARALLEL_TYPE (d))
1075 d = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (d));
1077 SET_DECL_PARALLEL_TYPE (d, parallel_type);
1080 /* Utility function of above to merge LAST_SIZE, the previous size of a record
1081 with FIRST_BIT and SIZE that describe a field. SPECIAL is true if this
1082 represents a QUAL_UNION_TYPE in which case we must look for COND_EXPRs and
1083 replace a value of zero with the old size. If HAS_REP is true, we take the
1084 MAX of the end position of this field with LAST_SIZE. In all other cases,
1085 we use FIRST_BIT plus SIZE. Return an expression for the size. */
1088 merge_sizes (tree last_size, tree first_bit, tree size, bool special,
1091 tree type = TREE_TYPE (last_size);
1094 if (!special || TREE_CODE (size) != COND_EXPR)
1096 new_size = size_binop (PLUS_EXPR, first_bit, size);
1098 new_size = size_binop (MAX_EXPR, last_size, new_size);
1102 new_size = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
1103 integer_zerop (TREE_OPERAND (size, 1))
1104 ? last_size : merge_sizes (last_size, first_bit,
1105 TREE_OPERAND (size, 1),
1107 integer_zerop (TREE_OPERAND (size, 2))
1108 ? last_size : merge_sizes (last_size, first_bit,
1109 TREE_OPERAND (size, 2),
1112 /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
1113 when fed through substitute_in_expr) into thinking that a constant
1114 size is not constant. */
1115 while (TREE_CODE (new_size) == NON_LVALUE_EXPR)
1116 new_size = TREE_OPERAND (new_size, 0);
1121 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
1122 related by the addition of a constant. Return that constant if so. */
1125 compute_related_constant (tree op0, tree op1)
1127 tree op0_var, op1_var;
1128 tree op0_con = split_plus (op0, &op0_var);
1129 tree op1_con = split_plus (op1, &op1_var);
1130 tree result = size_binop (MINUS_EXPR, op0_con, op1_con);
1132 if (operand_equal_p (op0_var, op1_var, 0))
1134 else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0))
1140 /* Utility function of above to split a tree OP which may be a sum, into a
1141 constant part, which is returned, and a variable part, which is stored
1142 in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of
1146 split_plus (tree in, tree *pvar)
1148 /* Strip conversions in order to ease the tree traversal and maximize the
1149 potential for constant or plus/minus discovery. We need to be careful
1150 to always return and set *pvar to bitsizetype trees, but it's worth
1152 in = remove_conversions (in, false);
1154 *pvar = convert (bitsizetype, in);
1156 if (TREE_CODE (in) == INTEGER_CST)
1158 *pvar = bitsize_zero_node;
1159 return convert (bitsizetype, in);
1161 else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
1163 tree lhs_var, rhs_var;
1164 tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
1165 tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
1167 if (lhs_var == TREE_OPERAND (in, 0)
1168 && rhs_var == TREE_OPERAND (in, 1))
1169 return bitsize_zero_node;
1171 *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
1172 return size_binop (TREE_CODE (in), lhs_con, rhs_con);
1175 return bitsize_zero_node;
1178 /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
1179 subprogram. If it is VOID_TYPE, then we are dealing with a procedure,
1180 otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
1181 PARM_DECL nodes that are the subprogram parameters. CICO_LIST is the
1182 copy-in/copy-out list to be stored into the TYPE_CICO_LIST field.
1183 RETURN_UNCONSTRAINED_P is true if the function returns an unconstrained
1184 object. RETURN_BY_DIRECT_REF_P is true if the function returns by direct
1185 reference. RETURN_BY_INVISI_REF_P is true if the function returns by
1186 invisible reference. */
1189 create_subprog_type (tree return_type, tree param_decl_list, tree cico_list,
1190 bool return_unconstrained_p, bool return_by_direct_ref_p,
1191 bool return_by_invisi_ref_p)
1193 /* A list of the data type nodes of the subprogram formal parameters.
1194 This list is generated by traversing the input list of PARM_DECL
1196 VEC(tree,gc) *param_type_list = NULL;
1199 for (t = param_decl_list; t; t = DECL_CHAIN (t))
1200 VEC_safe_push (tree, gc, param_type_list, TREE_TYPE (t));
1202 type = build_function_type_vec (return_type, param_type_list);
1204 /* TYPE may have been shared since GCC hashes types. If it has a different
1205 CICO_LIST, make a copy. Likewise for the various flags. */
1206 if (!fntype_same_flags_p (type, cico_list, return_unconstrained_p,
1207 return_by_direct_ref_p, return_by_invisi_ref_p))
1209 type = copy_type (type);
1210 TYPE_CI_CO_LIST (type) = cico_list;
1211 TYPE_RETURN_UNCONSTRAINED_P (type) = return_unconstrained_p;
1212 TYPE_RETURN_BY_DIRECT_REF_P (type) = return_by_direct_ref_p;
1213 TREE_ADDRESSABLE (type) = return_by_invisi_ref_p;
1219 /* Return a copy of TYPE but safe to modify in any way. */
1222 copy_type (tree type)
1224 tree new_type = copy_node (type);
1226 /* Unshare the language-specific data. */
1227 if (TYPE_LANG_SPECIFIC (type))
1229 TYPE_LANG_SPECIFIC (new_type) = NULL;
1230 SET_TYPE_LANG_SPECIFIC (new_type, GET_TYPE_LANG_SPECIFIC (type));
1233 /* And the contents of the language-specific slot if needed. */
1234 if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE)
1235 && TYPE_RM_VALUES (type))
1237 TYPE_RM_VALUES (new_type) = NULL_TREE;
1238 SET_TYPE_RM_SIZE (new_type, TYPE_RM_SIZE (type));
1239 SET_TYPE_RM_MIN_VALUE (new_type, TYPE_RM_MIN_VALUE (type));
1240 SET_TYPE_RM_MAX_VALUE (new_type, TYPE_RM_MAX_VALUE (type));
1243 /* copy_node clears this field instead of copying it, because it is
1244 aliased with TREE_CHAIN. */
1245 TYPE_STUB_DECL (new_type) = TYPE_STUB_DECL (type);
1247 TYPE_POINTER_TO (new_type) = 0;
1248 TYPE_REFERENCE_TO (new_type) = 0;
1249 TYPE_MAIN_VARIANT (new_type) = new_type;
1250 TYPE_NEXT_VARIANT (new_type) = 0;
1255 /* Return a subtype of sizetype with range MIN to MAX and whose
1256 TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position
1257 of the associated TYPE_DECL. */
1260 create_index_type (tree min, tree max, tree index, Node_Id gnat_node)
1262 /* First build a type for the desired range. */
1263 tree type = build_nonshared_range_type (sizetype, min, max);
1265 /* Then set the index type. */
1266 SET_TYPE_INDEX_TYPE (type, index);
1267 create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node);
1272 /* Return a subtype of TYPE with range MIN to MAX. If TYPE is NULL,
1273 sizetype is used. */
1276 create_range_type (tree type, tree min, tree max)
1280 if (type == NULL_TREE)
1283 /* First build a type with the base range. */
1284 range_type = build_nonshared_range_type (type, TYPE_MIN_VALUE (type),
1285 TYPE_MAX_VALUE (type));
1287 /* Then set the actual range. */
1288 SET_TYPE_RM_MIN_VALUE (range_type, convert (type, min));
1289 SET_TYPE_RM_MAX_VALUE (range_type, convert (type, max));
1294 /* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of a type.
1295 TYPE_NAME gives the name of the type and TYPE is a ..._TYPE node giving
1299 create_type_stub_decl (tree type_name, tree type)
1301 /* Using a named TYPE_DECL ensures that a type name marker is emitted in
1302 STABS while setting DECL_ARTIFICIAL ensures that no DW_TAG_typedef is
1303 emitted in DWARF. */
1304 tree type_decl = build_decl (input_location,
1305 TYPE_DECL, type_name, type);
1306 DECL_ARTIFICIAL (type_decl) = 1;
1307 TYPE_ARTIFICIAL (type) = 1;
1311 /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type and TYPE
1312 is a ..._TYPE node giving its data type. ARTIFICIAL_P is true if this
1313 is a declaration that was generated by the compiler. DEBUG_INFO_P is
1314 true if we need to write debug information about this type. GNAT_NODE
1315 is used for the position of the decl. */
1318 create_type_decl (tree type_name, tree type, struct attrib *attr_list,
1319 bool artificial_p, bool debug_info_p, Node_Id gnat_node)
1321 enum tree_code code = TREE_CODE (type);
1322 bool named = TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL;
1325 /* Only the builtin TYPE_STUB_DECL should be used for dummy types. */
1326 gcc_assert (!TYPE_IS_DUMMY_P (type));
1328 /* If the type hasn't been named yet, we're naming it; preserve an existing
1329 TYPE_STUB_DECL that has been attached to it for some purpose. */
1330 if (!named && TYPE_STUB_DECL (type))
1332 type_decl = TYPE_STUB_DECL (type);
1333 DECL_NAME (type_decl) = type_name;
1336 type_decl = build_decl (input_location,
1337 TYPE_DECL, type_name, type);
1339 DECL_ARTIFICIAL (type_decl) = artificial_p;
1340 TYPE_ARTIFICIAL (type) = artificial_p;
1342 /* Add this decl to the current binding level. */
1343 gnat_pushdecl (type_decl, gnat_node);
1345 process_attributes (type_decl, attr_list);
1347 /* If we're naming the type, equate the TYPE_STUB_DECL to the name.
1348 This causes the name to be also viewed as a "tag" by the debug
1349 back-end, with the advantage that no DW_TAG_typedef is emitted
1350 for artificial "tagged" types in DWARF. */
1352 TYPE_STUB_DECL (type) = type_decl;
1354 /* Pass the type declaration to the debug back-end unless this is an
1355 UNCONSTRAINED_ARRAY_TYPE that the back-end does not support, or a
1356 type for which debugging information was not requested, or else an
1357 ENUMERAL_TYPE or RECORD_TYPE (except for fat pointers) which are
1358 handled separately. And do not pass dummy types either. */
1359 if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p)
1360 DECL_IGNORED_P (type_decl) = 1;
1361 else if (code != ENUMERAL_TYPE
1362 && (code != RECORD_TYPE || TYPE_FAT_POINTER_P (type))
1363 && !((code == POINTER_TYPE || code == REFERENCE_TYPE)
1364 && TYPE_IS_DUMMY_P (TREE_TYPE (type)))
1365 && !(code == RECORD_TYPE
1367 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (type))))))
1368 rest_of_type_decl_compilation (type_decl);
1373 /* Return a VAR_DECL or CONST_DECL node.
1375 VAR_NAME gives the name of the variable. ASM_NAME is its assembler name
1376 (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is
1377 the GCC tree for an optional initial expression; NULL_TREE if none.
1379 CONST_FLAG is true if this variable is constant, in which case we might
1380 return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false.
1382 PUBLIC_FLAG is true if this is for a reference to a public entity or for a
1383 definition to be made visible outside of the current compilation unit, for
1384 instance variable definitions in a package specification.
1386 EXTERN_FLAG is true when processing an external variable declaration (as
1387 opposed to a definition: no storage is to be allocated for the variable).
1389 STATIC_FLAG is only relevant when not at top level. In that case
1390 it indicates whether to always allocate storage to the variable.
1392 GNAT_NODE is used for the position of the decl. */
1395 create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
1396 bool const_flag, bool public_flag, bool extern_flag,
1397 bool static_flag, bool const_decl_allowed_p,
1398 struct attrib *attr_list, Node_Id gnat_node)
1400 /* Whether the initializer is a constant initializer. At the global level
1401 or for an external object or an object to be allocated in static memory,
1402 we check that it is a valid constant expression for use in initializing
1403 a static variable; otherwise, we only check that it is constant. */
1406 && gnat_types_compatible_p (type, TREE_TYPE (var_init))
1407 && (global_bindings_p () || extern_flag || static_flag
1408 ? initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) != 0
1409 : TREE_CONSTANT (var_init)));
1411 /* Whether we will make TREE_CONSTANT the DECL we produce here, in which
1412 case the initializer may be used in-lieu of the DECL node (as done in
1413 Identifier_to_gnu). This is useful to prevent the need of elaboration
1414 code when an identifier for which such a decl is made is in turn used as
1415 an initializer. We used to rely on CONST vs VAR_DECL for this purpose,
1416 but extra constraints apply to this choice (see below) and are not
1417 relevant to the distinction we wish to make. */
1418 bool constant_p = const_flag && init_const;
1420 /* The actual DECL node. CONST_DECL was initially intended for enumerals
1421 and may be used for scalars in general but not for aggregates. */
1423 = build_decl (input_location,
1424 (constant_p && const_decl_allowed_p
1425 && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL,
1428 /* If this is external, throw away any initializations (they will be done
1429 elsewhere) unless this is a constant for which we would like to remain
1430 able to get the initializer. If we are defining a global here, leave a
1431 constant initialization and save any variable elaborations for the
1432 elaboration routine. If we are just annotating types, throw away the
1433 initialization if it isn't a constant. */
1434 if ((extern_flag && !constant_p)
1435 || (type_annotate_only && var_init && !TREE_CONSTANT (var_init)))
1436 var_init = NULL_TREE;
1438 /* At the global level, an initializer requiring code to be generated
1439 produces elaboration statements. Check that such statements are allowed,
1440 that is, not violating a No_Elaboration_Code restriction. */
1441 if (global_bindings_p () && var_init != 0 && !init_const)
1442 Check_Elaboration_Code_Allowed (gnat_node);
1444 DECL_INITIAL (var_decl) = var_init;
1445 TREE_READONLY (var_decl) = const_flag;
1446 DECL_EXTERNAL (var_decl) = extern_flag;
1447 TREE_PUBLIC (var_decl) = public_flag || extern_flag;
1448 TREE_CONSTANT (var_decl) = constant_p;
1449 TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
1450 = TYPE_VOLATILE (type);
1452 /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
1453 try to fiddle with DECL_COMMON. However, on platforms that don't
1454 support global BSS sections, uninitialized global variables would
1455 go in DATA instead, thus increasing the size of the executable. */
1457 && TREE_CODE (var_decl) == VAR_DECL
1458 && TREE_PUBLIC (var_decl)
1459 && !have_global_bss_p ())
1460 DECL_COMMON (var_decl) = 1;
1462 /* At the global binding level, we need to allocate static storage for the
1463 variable if it isn't external. Otherwise, we allocate automatic storage
1464 unless requested not to. */
1465 TREE_STATIC (var_decl)
1466 = !extern_flag && (static_flag || global_bindings_p ());
1468 /* For an external constant whose initializer is not absolute, do not emit
1469 debug info. In DWARF this would mean a global relocation in a read-only
1470 section which runs afoul of the PE-COFF run-time relocation mechanism. */
1474 && initializer_constant_valid_p (var_init, TREE_TYPE (var_init))
1475 != null_pointer_node)
1476 DECL_IGNORED_P (var_decl) = 1;
1478 /* Add this decl to the current binding level. */
1479 gnat_pushdecl (var_decl, gnat_node);
1481 if (TREE_SIDE_EFFECTS (var_decl))
1482 TREE_ADDRESSABLE (var_decl) = 1;
1484 if (TREE_CODE (var_decl) == VAR_DECL)
1487 SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
1488 process_attributes (var_decl, attr_list);
1489 if (global_bindings_p ())
1490 rest_of_decl_compilation (var_decl, true, 0);
1493 expand_decl (var_decl);
1498 /* Return true if TYPE, an aggregate type, contains (or is) an array. */
1501 aggregate_type_contains_array_p (tree type)
1503 switch (TREE_CODE (type))
1507 case QUAL_UNION_TYPE:
1510 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
1511 if (AGGREGATE_TYPE_P (TREE_TYPE (field))
1512 && aggregate_type_contains_array_p (TREE_TYPE (field)))
1525 /* Return a FIELD_DECL node. FIELD_NAME is the field's name, FIELD_TYPE is
1526 its type and RECORD_TYPE is the type of the enclosing record. If SIZE is
1527 nonzero, it is the specified size of the field. If POS is nonzero, it is
1528 the bit position. PACKED is 1 if the enclosing record is packed, -1 if it
1529 has Component_Alignment of Storage_Unit. If ADDRESSABLE is nonzero, it
1530 means we are allowed to take the address of the field; if it is negative,
1531 we should not make a bitfield, which is used by make_aligning_type. */
1534 create_field_decl (tree field_name, tree field_type, tree record_type,
1535 tree size, tree pos, int packed, int addressable)
1537 tree field_decl = build_decl (input_location,
1538 FIELD_DECL, field_name, field_type);
1540 DECL_CONTEXT (field_decl) = record_type;
1541 TREE_READONLY (field_decl) = TYPE_READONLY (field_type);
1543 /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1544 byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
1545 Likewise for an aggregate without specified position that contains an
1546 array, because in this case slices of variable length of this array
1547 must be handled by GCC and variable-sized objects need to be aligned
1548 to at least a byte boundary. */
1549 if (packed && (TYPE_MODE (field_type) == BLKmode
1551 && AGGREGATE_TYPE_P (field_type)
1552 && aggregate_type_contains_array_p (field_type))))
1553 DECL_ALIGN (field_decl) = BITS_PER_UNIT;
1555 /* If a size is specified, use it. Otherwise, if the record type is packed
1556 compute a size to use, which may differ from the object's natural size.
1557 We always set a size in this case to trigger the checks for bitfield
1558 creation below, which is typically required when no position has been
1561 size = convert (bitsizetype, size);
1562 else if (packed == 1)
1564 size = rm_size (field_type);
1565 if (TYPE_MODE (field_type) == BLKmode)
1566 size = round_up (size, BITS_PER_UNIT);
1569 /* If we may, according to ADDRESSABLE, make a bitfield if a size is
1570 specified for two reasons: first if the size differs from the natural
1571 size. Second, if the alignment is insufficient. There are a number of
1572 ways the latter can be true.
1574 We never make a bitfield if the type of the field has a nonconstant size,
1575 because no such entity requiring bitfield operations should reach here.
1577 We do *preventively* make a bitfield when there might be the need for it
1578 but we don't have all the necessary information to decide, as is the case
1579 of a field with no specified position in a packed record.
1581 We also don't look at STRICT_ALIGNMENT here, and rely on later processing
1582 in layout_decl or finish_record_type to clear the bit_field indication if
1583 it is in fact not needed. */
1584 if (addressable >= 0
1586 && TREE_CODE (size) == INTEGER_CST
1587 && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
1588 && (!tree_int_cst_equal (size, TYPE_SIZE (field_type))
1589 || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type)))
1591 || (TYPE_ALIGN (record_type) != 0
1592 && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))))
1594 DECL_BIT_FIELD (field_decl) = 1;
1595 DECL_SIZE (field_decl) = size;
1596 if (!packed && !pos)
1598 if (TYPE_ALIGN (record_type) != 0
1599 && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))
1600 DECL_ALIGN (field_decl) = TYPE_ALIGN (record_type);
1602 DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
1606 DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
1608 /* Bump the alignment if need be, either for bitfield/packing purposes or
1609 to satisfy the type requirements if no such consideration applies. When
1610 we get the alignment from the type, indicate if this is from an explicit
1611 user request, which prevents stor-layout from lowering it later on. */
1613 unsigned int bit_align
1614 = (DECL_BIT_FIELD (field_decl) ? 1
1615 : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0);
1617 if (bit_align > DECL_ALIGN (field_decl))
1618 DECL_ALIGN (field_decl) = bit_align;
1619 else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl))
1621 DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
1622 DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type);
1628 /* We need to pass in the alignment the DECL is known to have.
1629 This is the lowest-order bit set in POS, but no more than
1630 the alignment of the record, if one is specified. Note
1631 that an alignment of 0 is taken as infinite. */
1632 unsigned int known_align;
1634 if (host_integerp (pos, 1))
1635 known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1);
1637 known_align = BITS_PER_UNIT;
1639 if (TYPE_ALIGN (record_type)
1640 && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
1641 known_align = TYPE_ALIGN (record_type);
1643 layout_decl (field_decl, known_align);
1644 SET_DECL_OFFSET_ALIGN (field_decl,
1645 host_integerp (pos, 1) ? BIGGEST_ALIGNMENT
1647 pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
1648 &DECL_FIELD_BIT_OFFSET (field_decl),
1649 DECL_OFFSET_ALIGN (field_decl), pos);
1652 /* In addition to what our caller says, claim the field is addressable if we
1653 know that its type is not suitable.
1655 The field may also be "technically" nonaddressable, meaning that even if
1656 we attempt to take the field's address we will actually get the address
1657 of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD
1658 value we have at this point is not accurate enough, so we don't account
1659 for this here and let finish_record_type decide. */
1660 if (!addressable && !type_for_nonaliased_component_p (field_type))
1663 DECL_NONADDRESSABLE_P (field_decl) = !addressable;
1668 /* Return a PARM_DECL node. PARAM_NAME is the name of the parameter and
1669 PARAM_TYPE is its type. READONLY is true if the parameter is readonly
1670 (either an In parameter or an address of a pass-by-ref parameter). */
1673 create_param_decl (tree param_name, tree param_type, bool readonly)
1675 tree param_decl = build_decl (input_location,
1676 PARM_DECL, param_name, param_type);
1678 /* Honor TARGET_PROMOTE_PROTOTYPES like the C compiler, as not doing so
1679 can lead to various ABI violations. */
1680 if (targetm.calls.promote_prototypes (NULL_TREE)
1681 && INTEGRAL_TYPE_P (param_type)
1682 && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
1684 /* We have to be careful about biased types here. Make a subtype
1685 of integer_type_node with the proper biasing. */
1686 if (TREE_CODE (param_type) == INTEGER_TYPE
1687 && TYPE_BIASED_REPRESENTATION_P (param_type))
1690 = make_unsigned_type (TYPE_PRECISION (integer_type_node));
1691 TREE_TYPE (subtype) = integer_type_node;
1692 TYPE_BIASED_REPRESENTATION_P (subtype) = 1;
1693 SET_TYPE_RM_MIN_VALUE (subtype, TYPE_MIN_VALUE (param_type));
1694 SET_TYPE_RM_MAX_VALUE (subtype, TYPE_MAX_VALUE (param_type));
1695 param_type = subtype;
1698 param_type = integer_type_node;
1701 DECL_ARG_TYPE (param_decl) = param_type;
1702 TREE_READONLY (param_decl) = readonly;
1706 /* Given a DECL and ATTR_LIST, process the listed attributes. */
1709 process_attributes (tree decl, struct attrib *attr_list)
1711 for (; attr_list; attr_list = attr_list->next)
1712 switch (attr_list->type)
1714 case ATTR_MACHINE_ATTRIBUTE:
1715 input_location = DECL_SOURCE_LOCATION (decl);
1716 decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args,
1718 ATTR_FLAG_TYPE_IN_PLACE);
1721 case ATTR_LINK_ALIAS:
1722 if (! DECL_EXTERNAL (decl))
1724 TREE_STATIC (decl) = 1;
1725 assemble_alias (decl, attr_list->name);
1729 case ATTR_WEAK_EXTERNAL:
1731 declare_weak (decl);
1733 post_error ("?weak declarations not supported on this target",
1734 attr_list->error_point);
1737 case ATTR_LINK_SECTION:
1738 if (targetm_common.have_named_sections)
1740 DECL_SECTION_NAME (decl)
1741 = build_string (IDENTIFIER_LENGTH (attr_list->name),
1742 IDENTIFIER_POINTER (attr_list->name));
1743 DECL_COMMON (decl) = 0;
1746 post_error ("?section attributes are not supported for this target",
1747 attr_list->error_point);
1750 case ATTR_LINK_CONSTRUCTOR:
1751 DECL_STATIC_CONSTRUCTOR (decl) = 1;
1752 TREE_USED (decl) = 1;
1755 case ATTR_LINK_DESTRUCTOR:
1756 DECL_STATIC_DESTRUCTOR (decl) = 1;
1757 TREE_USED (decl) = 1;
1760 case ATTR_THREAD_LOCAL_STORAGE:
1761 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
1762 DECL_COMMON (decl) = 0;
1767 /* Record DECL as a global renaming pointer. */
1770 record_global_renaming_pointer (tree decl)
1772 gcc_assert (!DECL_LOOP_PARM_P (decl) && DECL_RENAMED_OBJECT (decl));
1773 VEC_safe_push (tree, gc, global_renaming_pointers, decl);
1776 /* Invalidate the global renaming pointers. */
1779 invalidate_global_renaming_pointers (void)
1784 FOR_EACH_VEC_ELT (tree, global_renaming_pointers, i, iter)
1785 SET_DECL_RENAMED_OBJECT (iter, NULL_TREE);
1787 VEC_free (tree, gc, global_renaming_pointers);
1790 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
1794 value_factor_p (tree value, HOST_WIDE_INT factor)
1796 if (host_integerp (value, 1))
1797 return tree_low_cst (value, 1) % factor == 0;
1799 if (TREE_CODE (value) == MULT_EXPR)
1800 return (value_factor_p (TREE_OPERAND (value, 0), factor)
1801 || value_factor_p (TREE_OPERAND (value, 1), factor));
1806 /* Given two consecutive field decls PREV_FIELD and CURR_FIELD, return true
1807 unless we can prove these 2 fields are laid out in such a way that no gap
1808 exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET
1809 is the distance in bits between the end of PREV_FIELD and the starting
1810 position of CURR_FIELD. It is ignored if null. */
1813 potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
1815 /* If this is the first field of the record, there cannot be any gap */
1819 /* If the previous field is a union type, then return False: The only
1820 time when such a field is not the last field of the record is when
1821 there are other components at fixed positions after it (meaning there
1822 was a rep clause for every field), in which case we don't want the
1823 alignment constraint to override them. */
1824 if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
1827 /* If the distance between the end of prev_field and the beginning of
1828 curr_field is constant, then there is a gap if the value of this
1829 constant is not null. */
1830 if (offset && host_integerp (offset, 1))
1831 return !integer_zerop (offset);
1833 /* If the size and position of the previous field are constant,
1834 then check the sum of this size and position. There will be a gap
1835 iff it is not multiple of the current field alignment. */
1836 if (host_integerp (DECL_SIZE (prev_field), 1)
1837 && host_integerp (bit_position (prev_field), 1))
1838 return ((tree_low_cst (bit_position (prev_field), 1)
1839 + tree_low_cst (DECL_SIZE (prev_field), 1))
1840 % DECL_ALIGN (curr_field) != 0);
1842 /* If both the position and size of the previous field are multiples
1843 of the current field alignment, there cannot be any gap. */
1844 if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
1845 && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
1848 /* Fallback, return that there may be a potential gap */
1852 /* Return a LABEL_DECL with LABEL_NAME. GNAT_NODE is used for the position
1856 create_label_decl (tree label_name, Node_Id gnat_node)
1859 = build_decl (input_location, LABEL_DECL, label_name, void_type_node);
1861 DECL_MODE (label_decl) = VOIDmode;
1863 /* Add this decl to the current binding level. */
1864 gnat_pushdecl (label_decl, gnat_node);
1869 /* Return a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram,
1870 ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1871 node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1872 PARM_DECL nodes chained through the DECL_CHAIN field).
1874 INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, ARTIFICIAL_FLAG and ATTR_LIST are
1875 used to set the appropriate fields in the FUNCTION_DECL. GNAT_NODE is
1876 used for the position of the decl. */
1879 create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type,
1880 tree param_decl_list, bool inline_flag, bool public_flag,
1881 bool extern_flag, bool artificial_flag,
1882 struct attrib *attr_list, Node_Id gnat_node)
1884 tree subprog_decl = build_decl (input_location, FUNCTION_DECL, subprog_name,
1886 tree result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
1887 TREE_TYPE (subprog_type));
1888 DECL_ARGUMENTS (subprog_decl) = param_decl_list;
1890 /* If this is a non-inline function nested inside an inlined external
1891 function, we cannot honor both requests without cloning the nested
1892 function in the current unit since it is private to the other unit.
1893 We could inline the nested function as well but it's probably better
1894 to err on the side of too little inlining. */
1897 && current_function_decl
1898 && DECL_DECLARED_INLINE_P (current_function_decl)
1899 && DECL_EXTERNAL (current_function_decl))
1900 DECL_DECLARED_INLINE_P (current_function_decl) = 0;
1902 DECL_ARTIFICIAL (subprog_decl) = artificial_flag;
1903 DECL_EXTERNAL (subprog_decl) = extern_flag;
1904 DECL_DECLARED_INLINE_P (subprog_decl) = inline_flag;
1905 DECL_NO_INLINE_WARNING_P (subprog_decl) = inline_flag && artificial_flag;
1907 TREE_PUBLIC (subprog_decl) = public_flag;
1908 TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type);
1909 TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
1910 TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
1912 DECL_ARTIFICIAL (result_decl) = 1;
1913 DECL_IGNORED_P (result_decl) = 1;
1914 DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (subprog_type);
1915 DECL_RESULT (subprog_decl) = result_decl;
1919 SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
1921 /* The expand_main_function circuitry expects "main_identifier_node" to
1922 designate the DECL_NAME of the 'main' entry point, in turn expected
1923 to be declared as the "main" function literally by default. Ada
1924 program entry points are typically declared with a different name
1925 within the binder generated file, exported as 'main' to satisfy the
1926 system expectations. Force main_identifier_node in this case. */
1927 if (asm_name == main_identifier_node)
1928 DECL_NAME (subprog_decl) = main_identifier_node;
1931 /* Add this decl to the current binding level. */
1932 gnat_pushdecl (subprog_decl, gnat_node);
1934 process_attributes (subprog_decl, attr_list);
1936 /* Output the assembler code and/or RTL for the declaration. */
1937 rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
1939 return subprog_decl;
1942 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
1943 body. This routine needs to be invoked before processing the declarations
1944 appearing in the subprogram. */
1947 begin_subprog_body (tree subprog_decl)
1951 announce_function (subprog_decl);
1953 /* This function is being defined. */
1954 TREE_STATIC (subprog_decl) = 1;
1956 current_function_decl = subprog_decl;
1958 /* Enter a new binding level and show that all the parameters belong to
1962 for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
1963 param_decl = DECL_CHAIN (param_decl))
1964 DECL_CONTEXT (param_decl) = subprog_decl;
1966 make_decl_rtl (subprog_decl);
1969 /* Finish translating the current subprogram and set its BODY. */
1972 end_subprog_body (tree body)
1974 tree fndecl = current_function_decl;
1976 /* Attach the BLOCK for this level to the function and pop the level. */
1977 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
1978 DECL_INITIAL (fndecl) = current_binding_level->block;
1981 /* Mark the RESULT_DECL as being in this subprogram. */
1982 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
1984 /* The body should be a BIND_EXPR whose BLOCK is the top-level one. */
1985 if (TREE_CODE (body) == BIND_EXPR)
1987 BLOCK_SUPERCONTEXT (BIND_EXPR_BLOCK (body)) = fndecl;
1988 DECL_INITIAL (fndecl) = BIND_EXPR_BLOCK (body);
1991 DECL_SAVED_TREE (fndecl) = body;
1993 current_function_decl = decl_function_context (fndecl);
1996 /* Wrap up compilation of SUBPROG_DECL, a subprogram body. */
1999 rest_of_subprog_body_compilation (tree subprog_decl)
2001 /* We cannot track the location of errors past this point. */
2002 error_gnat_node = Empty;
2004 /* If we're only annotating types, don't actually compile this function. */
2005 if (type_annotate_only)
2008 /* Dump functions before gimplification. */
2009 dump_function (TDI_original, subprog_decl);
2011 /* ??? This special handling of nested functions is probably obsolete. */
2012 if (!decl_function_context (subprog_decl))
2013 cgraph_finalize_function (subprog_decl, false);
2015 /* Register this function with cgraph just far enough to get it
2016 added to our parent's nested function list. */
2017 (void) cgraph_get_create_node (subprog_decl);
2021 gnat_builtin_function (tree decl)
2023 gnat_pushdecl (decl, Empty);
2027 /* Return an integer type with the number of bits of precision given by
2028 PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
2029 it is a signed type. */
2032 gnat_type_for_size (unsigned precision, int unsignedp)
2037 if (precision <= 2 * MAX_BITS_PER_WORD
2038 && signed_and_unsigned_types[precision][unsignedp])
2039 return signed_and_unsigned_types[precision][unsignedp];
2042 t = make_unsigned_type (precision);
2044 t = make_signed_type (precision);
2046 if (precision <= 2 * MAX_BITS_PER_WORD)
2047 signed_and_unsigned_types[precision][unsignedp] = t;
2051 sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision);
2052 TYPE_NAME (t) = get_identifier (type_name);
2058 /* Likewise for floating-point types. */
2061 float_type_for_precision (int precision, enum machine_mode mode)
2066 if (float_types[(int) mode])
2067 return float_types[(int) mode];
2069 float_types[(int) mode] = t = make_node (REAL_TYPE);
2070 TYPE_PRECISION (t) = precision;
2073 gcc_assert (TYPE_MODE (t) == mode);
2076 sprintf (type_name, "FLOAT_%d", precision);
2077 TYPE_NAME (t) = get_identifier (type_name);
2083 /* Return a data type that has machine mode MODE. UNSIGNEDP selects
2084 an unsigned type; otherwise a signed type is returned. */
2087 gnat_type_for_mode (enum machine_mode mode, int unsignedp)
2089 if (mode == BLKmode)
2092 if (mode == VOIDmode)
2093 return void_type_node;
2095 if (COMPLEX_MODE_P (mode))
2098 if (SCALAR_FLOAT_MODE_P (mode))
2099 return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
2101 if (SCALAR_INT_MODE_P (mode))
2102 return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
2104 if (VECTOR_MODE_P (mode))
2106 enum machine_mode inner_mode = GET_MODE_INNER (mode);
2107 tree inner_type = gnat_type_for_mode (inner_mode, unsignedp);
2109 return build_vector_type_for_mode (inner_type, mode);
2115 /* Return the unsigned version of a TYPE_NODE, a scalar type. */
2118 gnat_unsigned_type (tree type_node)
2120 tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1);
2122 if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2124 type = copy_node (type);
2125 TREE_TYPE (type) = type_node;
2127 else if (TREE_TYPE (type_node)
2128 && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2129 && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2131 type = copy_node (type);
2132 TREE_TYPE (type) = TREE_TYPE (type_node);
2138 /* Return the signed version of a TYPE_NODE, a scalar type. */
2141 gnat_signed_type (tree type_node)
2143 tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0);
2145 if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2147 type = copy_node (type);
2148 TREE_TYPE (type) = type_node;
2150 else if (TREE_TYPE (type_node)
2151 && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2152 && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2154 type = copy_node (type);
2155 TREE_TYPE (type) = TREE_TYPE (type_node);
2161 /* Return 1 if the types T1 and T2 are compatible, i.e. if they can be
2162 transparently converted to each other. */
2165 gnat_types_compatible_p (tree t1, tree t2)
2167 enum tree_code code;
2169 /* This is the default criterion. */
2170 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
2173 /* We only check structural equivalence here. */
2174 if ((code = TREE_CODE (t1)) != TREE_CODE (t2))
2177 /* Vector types are also compatible if they have the same number of subparts
2178 and the same form of (scalar) element type. */
2179 if (code == VECTOR_TYPE
2180 && TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2)
2181 && TREE_CODE (TREE_TYPE (t1)) == TREE_CODE (TREE_TYPE (t2))
2182 && TYPE_PRECISION (TREE_TYPE (t1)) == TYPE_PRECISION (TREE_TYPE (t2)))
2185 /* Array types are also compatible if they are constrained and have the same
2186 domain(s) and the same component type. */
2187 if (code == ARRAY_TYPE
2188 && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2)
2189 || (TYPE_DOMAIN (t1)
2191 && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)),
2192 TYPE_MIN_VALUE (TYPE_DOMAIN (t2)))
2193 && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)),
2194 TYPE_MAX_VALUE (TYPE_DOMAIN (t2)))))
2195 && (TREE_TYPE (t1) == TREE_TYPE (t2)
2196 || (TREE_CODE (TREE_TYPE (t1)) == ARRAY_TYPE
2197 && gnat_types_compatible_p (TREE_TYPE (t1), TREE_TYPE (t2)))))
2200 /* Padding record types are also compatible if they pad the same
2201 type and have the same constant size. */
2202 if (code == RECORD_TYPE
2203 && TYPE_PADDING_P (t1) && TYPE_PADDING_P (t2)
2204 && TREE_TYPE (TYPE_FIELDS (t1)) == TREE_TYPE (TYPE_FIELDS (t2))
2205 && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2)))
2211 /* Return true if EXPR is a useless type conversion. */
2214 gnat_useless_type_conversion (tree expr)
2216 if (CONVERT_EXPR_P (expr)
2217 || TREE_CODE (expr) == VIEW_CONVERT_EXPR
2218 || TREE_CODE (expr) == NON_LVALUE_EXPR)
2219 return gnat_types_compatible_p (TREE_TYPE (expr),
2220 TREE_TYPE (TREE_OPERAND (expr, 0)));
2225 /* Return true if T, a FUNCTION_TYPE, has the specified list of flags. */
2228 fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p,
2229 bool return_by_direct_ref_p, bool return_by_invisi_ref_p)
2231 return TYPE_CI_CO_LIST (t) == cico_list
2232 && TYPE_RETURN_UNCONSTRAINED_P (t) == return_unconstrained_p
2233 && TYPE_RETURN_BY_DIRECT_REF_P (t) == return_by_direct_ref_p
2234 && TREE_ADDRESSABLE (t) == return_by_invisi_ref_p;
2237 /* EXP is an expression for the size of an object. If this size contains
2238 discriminant references, replace them with the maximum (if MAX_P) or
2239 minimum (if !MAX_P) possible value of the discriminant. */
2242 max_size (tree exp, bool max_p)
2244 enum tree_code code = TREE_CODE (exp);
2245 tree type = TREE_TYPE (exp);
2247 switch (TREE_CODE_CLASS (code))
2249 case tcc_declaration:
2254 if (code == CALL_EXPR)
2259 t = maybe_inline_call_in_expr (exp);
2261 return max_size (t, max_p);
2263 n = call_expr_nargs (exp);
2265 argarray = XALLOCAVEC (tree, n);
2266 for (i = 0; i < n; i++)
2267 argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p);
2268 return build_call_array (type, CALL_EXPR_FN (exp), n, argarray);
2273 /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
2274 modify. Otherwise, we treat it like a variable. */
2275 if (!CONTAINS_PLACEHOLDER_P (exp))
2278 type = TREE_TYPE (TREE_OPERAND (exp, 1));
2280 max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true);
2282 case tcc_comparison:
2283 return max_p ? size_one_node : size_zero_node;
2287 case tcc_expression:
2288 switch (TREE_CODE_LENGTH (code))
2291 if (code == SAVE_EXPR)
2293 else if (code == NON_LVALUE_EXPR)
2294 return max_size (TREE_OPERAND (exp, 0), max_p);
2297 fold_build1 (code, type,
2298 max_size (TREE_OPERAND (exp, 0),
2299 code == NEGATE_EXPR ? !max_p : max_p));
2302 if (code == COMPOUND_EXPR)
2303 return max_size (TREE_OPERAND (exp, 1), max_p);
2306 tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
2307 tree rhs = max_size (TREE_OPERAND (exp, 1),
2308 code == MINUS_EXPR ? !max_p : max_p);
2310 /* Special-case wanting the maximum value of a MIN_EXPR.
2311 In that case, if one side overflows, return the other.
2312 sizetype is signed, but we know sizes are non-negative.
2313 Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2314 overflowing and the RHS a variable. */
2317 && TREE_CODE (rhs) == INTEGER_CST
2318 && TREE_OVERFLOW (rhs))
2322 && TREE_CODE (lhs) == INTEGER_CST
2323 && TREE_OVERFLOW (lhs))
2325 else if ((code == MINUS_EXPR || code == PLUS_EXPR)
2326 && TREE_CODE (lhs) == INTEGER_CST
2327 && TREE_OVERFLOW (lhs)
2328 && !TREE_CONSTANT (rhs))
2331 return fold_build2 (code, type, lhs, rhs);
2335 if (code == COND_EXPR)
2336 return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
2337 max_size (TREE_OPERAND (exp, 1), max_p),
2338 max_size (TREE_OPERAND (exp, 2), max_p));
2341 /* Other tree classes cannot happen. */
2349 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2350 EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2351 Return a constructor for the template. */
2354 build_template (tree template_type, tree array_type, tree expr)
2356 VEC(constructor_elt,gc) *template_elts = NULL;
2357 tree bound_list = NULL_TREE;
2360 while (TREE_CODE (array_type) == RECORD_TYPE
2361 && (TYPE_PADDING_P (array_type)
2362 || TYPE_JUSTIFIED_MODULAR_P (array_type)))
2363 array_type = TREE_TYPE (TYPE_FIELDS (array_type));
2365 if (TREE_CODE (array_type) == ARRAY_TYPE
2366 || (TREE_CODE (array_type) == INTEGER_TYPE
2367 && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
2368 bound_list = TYPE_ACTUAL_BOUNDS (array_type);
2370 /* First make the list for a CONSTRUCTOR for the template. Go down the
2371 field list of the template instead of the type chain because this
2372 array might be an Ada array of arrays and we can't tell where the
2373 nested arrays stop being the underlying object. */
2375 for (field = TYPE_FIELDS (template_type); field;
2377 ? (bound_list = TREE_CHAIN (bound_list))
2378 : (array_type = TREE_TYPE (array_type))),
2379 field = DECL_CHAIN (DECL_CHAIN (field)))
2381 tree bounds, min, max;
2383 /* If we have a bound list, get the bounds from there. Likewise
2384 for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
2385 DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2386 This will give us a maximum range. */
2388 bounds = TREE_VALUE (bound_list);
2389 else if (TREE_CODE (array_type) == ARRAY_TYPE)
2390 bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
2391 else if (expr && TREE_CODE (expr) == PARM_DECL
2392 && DECL_BY_COMPONENT_PTR_P (expr))
2393 bounds = TREE_TYPE (field);
2397 min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds));
2398 max = convert (TREE_TYPE (DECL_CHAIN (field)), TYPE_MAX_VALUE (bounds));
2400 /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2401 substitute it from OBJECT. */
2402 min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr);
2403 max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr);
2405 CONSTRUCTOR_APPEND_ELT (template_elts, field, min);
2406 CONSTRUCTOR_APPEND_ELT (template_elts, DECL_CHAIN (field), max);
2409 return gnat_build_constructor (template_type, template_elts);
2412 /* Helper routine to make a descriptor field. FIELD_LIST is the list of decls
2413 being built; the new decl is chained on to the front of the list. */
2416 make_descriptor_field (const char *name, tree type, tree rec_type,
2417 tree initial, tree field_list)
2420 = create_field_decl (get_identifier (name), type, rec_type, NULL_TREE,
2423 DECL_INITIAL (field) = initial;
2424 DECL_CHAIN (field) = field_list;
2428 /* Build a 32-bit VMS descriptor from a Mechanism_Type, which must specify a
2429 descriptor type, and the GCC type of an object. Each FIELD_DECL in the
2430 type contains in its DECL_INITIAL the expression to use when a constructor
2431 is made for the type. GNAT_ENTITY is an entity used to print out an error
2432 message if the mechanism cannot be applied to an object of that type and
2433 also for the name. */
2436 build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
2438 tree record_type = make_node (RECORD_TYPE);
2439 tree pointer32_type, pointer64_type;
2440 tree field_list = NULL_TREE;
2441 int klass, ndim, i, dtype = 0;
2442 tree inner_type, tem;
2445 /* If TYPE is an unconstrained array, use the underlying array type. */
2446 if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2447 type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2449 /* If this is an array, compute the number of dimensions in the array,
2450 get the index types, and point to the inner type. */
2451 if (TREE_CODE (type) != ARRAY_TYPE)
2454 for (ndim = 1, inner_type = type;
2455 TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
2456 && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
2457 ndim++, inner_type = TREE_TYPE (inner_type))
2460 idx_arr = XALLOCAVEC (tree, ndim);
2462 if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA
2463 && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
2464 for (i = ndim - 1, inner_type = type;
2466 i--, inner_type = TREE_TYPE (inner_type))
2467 idx_arr[i] = TYPE_DOMAIN (inner_type);
2469 for (i = 0, inner_type = type;
2471 i++, inner_type = TREE_TYPE (inner_type))
2472 idx_arr[i] = TYPE_DOMAIN (inner_type);
2474 /* Now get the DTYPE value. */
2475 switch (TREE_CODE (type))
2480 if (TYPE_VAX_FLOATING_POINT_P (type))
2481 switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2494 switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
2497 dtype = TYPE_UNSIGNED (type) ? 2 : 6;
2500 dtype = TYPE_UNSIGNED (type) ? 3 : 7;
2503 dtype = TYPE_UNSIGNED (type) ? 4 : 8;
2506 dtype = TYPE_UNSIGNED (type) ? 5 : 9;
2509 dtype = TYPE_UNSIGNED (type) ? 25 : 26;
2515 dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
2519 if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
2520 && TYPE_VAX_FLOATING_POINT_P (type))
2521 switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2533 dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
2544 /* Get the CLASS value. */
2547 case By_Descriptor_A:
2548 case By_Short_Descriptor_A:
2551 case By_Descriptor_NCA:
2552 case By_Short_Descriptor_NCA:
2555 case By_Descriptor_SB:
2556 case By_Short_Descriptor_SB:
2560 case By_Short_Descriptor:
2561 case By_Descriptor_S:
2562 case By_Short_Descriptor_S:
2568 /* Make the type for a descriptor for VMS. The first four fields are the
2569 same for all types. */
2571 = make_descriptor_field ("LENGTH", gnat_type_for_size (16, 1), record_type,
2572 size_in_bytes ((mech == By_Descriptor_A
2573 || mech == By_Short_Descriptor_A)
2574 ? inner_type : type),
2577 = make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1), record_type,
2578 size_int (dtype), field_list);
2580 = make_descriptor_field ("CLASS", gnat_type_for_size (8, 1), record_type,
2581 size_int (klass), field_list);
2583 pointer32_type = build_pointer_type_for_mode (type, SImode, false);
2584 pointer64_type = build_pointer_type_for_mode (type, DImode, false);
2586 /* Ensure that only 32-bit pointers are passed in 32-bit descriptors. Note
2587 that we cannot build a template call to the CE routine as it would get a
2588 wrong source location; instead we use a second placeholder for it. */
2589 tem = build_unary_op (ADDR_EXPR, pointer64_type,
2590 build0 (PLACEHOLDER_EXPR, type));
2591 tem = build3 (COND_EXPR, pointer32_type,
2593 ? build_binary_op (GE_EXPR, boolean_type_node, tem,
2594 build_int_cstu (pointer64_type, 0x80000000))
2595 : boolean_false_node,
2596 build0 (PLACEHOLDER_EXPR, void_type_node),
2597 convert (pointer32_type, tem));
2600 = make_descriptor_field ("POINTER", pointer32_type, record_type, tem,
2606 case By_Short_Descriptor:
2607 case By_Descriptor_S:
2608 case By_Short_Descriptor_S:
2611 case By_Descriptor_SB:
2612 case By_Short_Descriptor_SB:
2614 = make_descriptor_field ("SB_L1", gnat_type_for_size (32, 1),
2616 (TREE_CODE (type) == ARRAY_TYPE
2617 ? TYPE_MIN_VALUE (TYPE_DOMAIN (type))
2621 = make_descriptor_field ("SB_U1", gnat_type_for_size (32, 1),
2623 (TREE_CODE (type) == ARRAY_TYPE
2624 ? TYPE_MAX_VALUE (TYPE_DOMAIN (type))
2629 case By_Descriptor_A:
2630 case By_Short_Descriptor_A:
2631 case By_Descriptor_NCA:
2632 case By_Short_Descriptor_NCA:
2634 = make_descriptor_field ("SCALE", gnat_type_for_size (8, 1),
2635 record_type, size_zero_node, field_list);
2638 = make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1),
2639 record_type, size_zero_node, field_list);
2642 = make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1),
2644 size_int ((mech == By_Descriptor_NCA
2645 || mech == By_Short_Descriptor_NCA)
2647 /* Set FL_COLUMN, FL_COEFF, and
2649 : (TREE_CODE (type) == ARRAY_TYPE
2650 && TYPE_CONVENTION_FORTRAN_P
2656 = make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1),
2657 record_type, size_int (ndim), field_list);
2660 = make_descriptor_field ("ARSIZE", gnat_type_for_size (32, 1),
2661 record_type, size_in_bytes (type),
2664 /* Now build a pointer to the 0,0,0... element. */
2665 tem = build0 (PLACEHOLDER_EXPR, type);
2666 for (i = 0, inner_type = type; i < ndim;
2667 i++, inner_type = TREE_TYPE (inner_type))
2668 tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
2669 convert (TYPE_DOMAIN (inner_type), size_zero_node),
2670 NULL_TREE, NULL_TREE);
2673 = make_descriptor_field ("A0", pointer32_type, record_type,
2674 build1 (ADDR_EXPR, pointer32_type, tem),
2677 /* Next come the addressing coefficients. */
2678 tem = size_one_node;
2679 for (i = 0; i < ndim; i++)
2683 = size_binop (MULT_EXPR, tem,
2684 size_binop (PLUS_EXPR,
2685 size_binop (MINUS_EXPR,
2686 TYPE_MAX_VALUE (idx_arr[i]),
2687 TYPE_MIN_VALUE (idx_arr[i])),
2690 fname[0] = ((mech == By_Descriptor_NCA ||
2691 mech == By_Short_Descriptor_NCA) ? 'S' : 'M');
2692 fname[1] = '0' + i, fname[2] = 0;
2694 = make_descriptor_field (fname, gnat_type_for_size (32, 1),
2695 record_type, idx_length, field_list);
2697 if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA)
2701 /* Finally here are the bounds. */
2702 for (i = 0; i < ndim; i++)
2706 fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
2708 = make_descriptor_field (fname, gnat_type_for_size (32, 1),
2709 record_type, TYPE_MIN_VALUE (idx_arr[i]),
2714 = make_descriptor_field (fname, gnat_type_for_size (32, 1),
2715 record_type, TYPE_MAX_VALUE (idx_arr[i]),
2721 post_error ("unsupported descriptor type for &", gnat_entity);
2724 TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC");
2725 finish_record_type (record_type, nreverse (field_list), 0, false);
2729 /* Build a 64-bit VMS descriptor from a Mechanism_Type, which must specify a
2730 descriptor type, and the GCC type of an object. Each FIELD_DECL in the
2731 type contains in its DECL_INITIAL the expression to use when a constructor
2732 is made for the type. GNAT_ENTITY is an entity used to print out an error
2733 message if the mechanism cannot be applied to an object of that type and
2734 also for the name. */
2737 build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
2739 tree record_type = make_node (RECORD_TYPE);
2740 tree pointer64_type;
2741 tree field_list = NULL_TREE;
2742 int klass, ndim, i, dtype = 0;
2743 tree inner_type, tem;
2746 /* If TYPE is an unconstrained array, use the underlying array type. */
2747 if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2748 type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2750 /* If this is an array, compute the number of dimensions in the array,
2751 get the index types, and point to the inner type. */
2752 if (TREE_CODE (type) != ARRAY_TYPE)
2755 for (ndim = 1, inner_type = type;
2756 TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
2757 && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
2758 ndim++, inner_type = TREE_TYPE (inner_type))
2761 idx_arr = XALLOCAVEC (tree, ndim);
2763 if (mech != By_Descriptor_NCA
2764 && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
2765 for (i = ndim - 1, inner_type = type;
2767 i--, inner_type = TREE_TYPE (inner_type))
2768 idx_arr[i] = TYPE_DOMAIN (inner_type);
2770 for (i = 0, inner_type = type;
2772 i++, inner_type = TREE_TYPE (inner_type))
2773 idx_arr[i] = TYPE_DOMAIN (inner_type);
2775 /* Now get the DTYPE value. */
2776 switch (TREE_CODE (type))
2781 if (TYPE_VAX_FLOATING_POINT_P (type))
2782 switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2795 switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
2798 dtype = TYPE_UNSIGNED (type) ? 2 : 6;
2801 dtype = TYPE_UNSIGNED (type) ? 3 : 7;
2804 dtype = TYPE_UNSIGNED (type) ? 4 : 8;
2807 dtype = TYPE_UNSIGNED (type) ? 5 : 9;
2810 dtype = TYPE_UNSIGNED (type) ? 25 : 26;
2816 dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
2820 if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
2821 && TYPE_VAX_FLOATING_POINT_P (type))
2822 switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2834 dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
2845 /* Get the CLASS value. */
2848 case By_Descriptor_A:
2851 case By_Descriptor_NCA:
2854 case By_Descriptor_SB:
2858 case By_Descriptor_S:
2864 /* Make the type for a 64-bit descriptor for VMS. The first six fields
2865 are the same for all types. */
2867 = make_descriptor_field ("MBO", gnat_type_for_size (16, 1),
2868 record_type, size_int (1), field_list);
2870 = make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1),
2871 record_type, size_int (dtype), field_list);
2873 = make_descriptor_field ("CLASS", gnat_type_for_size (8, 1),
2874 record_type, size_int (klass), field_list);
2876 = make_descriptor_field ("MBMO", gnat_type_for_size (32, 1),
2877 record_type, ssize_int (-1), field_list);
2879 = make_descriptor_field ("LENGTH", gnat_type_for_size (64, 1),
2881 size_in_bytes (mech == By_Descriptor_A
2882 ? inner_type : type),
2885 pointer64_type = build_pointer_type_for_mode (type, DImode, false);
2888 = make_descriptor_field ("POINTER", pointer64_type, record_type,
2889 build_unary_op (ADDR_EXPR, pointer64_type,
2890 build0 (PLACEHOLDER_EXPR, type)),
2896 case By_Descriptor_S:
2899 case By_Descriptor_SB:
2901 = make_descriptor_field ("SB_L1", gnat_type_for_size (64, 1),
2903 (TREE_CODE (type) == ARRAY_TYPE
2904 ? TYPE_MIN_VALUE (TYPE_DOMAIN (type))
2908 = make_descriptor_field ("SB_U1", gnat_type_for_size (64, 1),
2910 (TREE_CODE (type) == ARRAY_TYPE
2911 ? TYPE_MAX_VALUE (TYPE_DOMAIN (type))
2916 case By_Descriptor_A:
2917 case By_Descriptor_NCA:
2919 = make_descriptor_field ("SCALE", gnat_type_for_size (8, 1),
2920 record_type, size_zero_node, field_list);
2923 = make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1),
2924 record_type, size_zero_node, field_list);
2926 dtype = (mech == By_Descriptor_NCA
2928 /* Set FL_COLUMN, FL_COEFF, and
2930 : (TREE_CODE (type) == ARRAY_TYPE
2931 && TYPE_CONVENTION_FORTRAN_P (type)
2934 = make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1),
2935 record_type, size_int (dtype),
2939 = make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1),
2940 record_type, size_int (ndim), field_list);
2943 = make_descriptor_field ("MBZ", gnat_type_for_size (32, 1),
2944 record_type, size_int (0), field_list);
2946 = make_descriptor_field ("ARSIZE", gnat_type_for_size (64, 1),
2947 record_type, size_in_bytes (type),
2950 /* Now build a pointer to the 0,0,0... element. */
2951 tem = build0 (PLACEHOLDER_EXPR, type);
2952 for (i = 0, inner_type = type; i < ndim;
2953 i++, inner_type = TREE_TYPE (inner_type))
2954 tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
2955 convert (TYPE_DOMAIN (inner_type), size_zero_node),
2956 NULL_TREE, NULL_TREE);
2959 = make_descriptor_field ("A0", pointer64_type, record_type,
2960 build1 (ADDR_EXPR, pointer64_type, tem),
2963 /* Next come the addressing coefficients. */
2964 tem = size_one_node;
2965 for (i = 0; i < ndim; i++)
2969 = size_binop (MULT_EXPR, tem,
2970 size_binop (PLUS_EXPR,
2971 size_binop (MINUS_EXPR,
2972 TYPE_MAX_VALUE (idx_arr[i]),
2973 TYPE_MIN_VALUE (idx_arr[i])),
2976 fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
2977 fname[1] = '0' + i, fname[2] = 0;
2979 = make_descriptor_field (fname, gnat_type_for_size (64, 1),
2980 record_type, idx_length, field_list);
2982 if (mech == By_Descriptor_NCA)
2986 /* Finally here are the bounds. */
2987 for (i = 0; i < ndim; i++)
2991 fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
2993 = make_descriptor_field (fname, gnat_type_for_size (64, 1),
2995 TYPE_MIN_VALUE (idx_arr[i]), field_list);
2999 = make_descriptor_field (fname, gnat_type_for_size (64, 1),
3001 TYPE_MAX_VALUE (idx_arr[i]), field_list);
3006 post_error ("unsupported descriptor type for &", gnat_entity);
3009 TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC64");
3010 finish_record_type (record_type, nreverse (field_list), 0, false);
3014 /* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result.
3015 GNAT_ACTUAL is the actual parameter for which the descriptor is built. */
3018 fill_vms_descriptor (tree gnu_type, tree gnu_expr, Node_Id gnat_actual)
3020 VEC(constructor_elt,gc) *v = NULL;
3023 gnu_expr = maybe_unconstrained_array (gnu_expr);
3024 gnu_expr = gnat_protect_expr (gnu_expr);
3025 gnat_mark_addressable (gnu_expr);
3027 /* We may need to substitute both GNU_EXPR and a CALL_EXPR to the raise CE
3028 routine in case we have a 32-bit descriptor. */
3029 gnu_expr = build2 (COMPOUND_EXPR, void_type_node,
3030 build_call_raise (CE_Range_Check_Failed, gnat_actual,
3031 N_Raise_Constraint_Error),
3034 for (field = TYPE_FIELDS (gnu_type); field; field = DECL_CHAIN (field))
3037 = convert (TREE_TYPE (field),
3038 SUBSTITUTE_PLACEHOLDER_IN_EXPR (DECL_INITIAL (field),
3040 CONSTRUCTOR_APPEND_ELT (v, field, value);
3043 return gnat_build_constructor (gnu_type, v);
3046 /* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a
3047 regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to
3048 which the VMS descriptor is passed. */
3051 convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
3053 tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
3054 tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
3055 /* The CLASS field is the 3rd field in the descriptor. */
3056 tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type)));
3057 /* The POINTER field is the 6th field in the descriptor. */
3058 tree pointer = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (klass)));
3060 /* Retrieve the value of the POINTER field. */
3062 = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
3064 if (POINTER_TYPE_P (gnu_type))
3065 return convert (gnu_type, gnu_expr64);
3067 else if (TYPE_IS_FAT_POINTER_P (gnu_type))
3069 tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3070 tree p_bounds_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
3071 tree template_type = TREE_TYPE (p_bounds_type);
3072 tree min_field = TYPE_FIELDS (template_type);
3073 tree max_field = DECL_CHAIN (TYPE_FIELDS (template_type));
3074 tree template_tree, template_addr, aflags, dimct, t, u;
3075 /* See the head comment of build_vms_descriptor. */
3076 int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
3077 tree lfield, ufield;
3078 VEC(constructor_elt,gc) *v;
3080 /* Convert POINTER to the pointer-to-array type. */
3081 gnu_expr64 = convert (p_array_type, gnu_expr64);
3085 case 1: /* Class S */
3086 case 15: /* Class SB */
3087 /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */
3088 v = VEC_alloc (constructor_elt, gc, 2);
3089 t = DECL_CHAIN (DECL_CHAIN (klass));
3090 t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3091 CONSTRUCTOR_APPEND_ELT (v, min_field,
3092 convert (TREE_TYPE (min_field),
3094 CONSTRUCTOR_APPEND_ELT (v, max_field,
3095 convert (TREE_TYPE (max_field), t));
3096 template_tree = gnat_build_constructor (template_type, v);
3097 template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree);
3099 /* For class S, we are done. */
3103 /* Test that we really have a SB descriptor, like DEC Ada. */
3104 t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL);
3105 u = convert (TREE_TYPE (klass), DECL_INITIAL (klass));
3106 u = build_binary_op (EQ_EXPR, boolean_type_node, t, u);
3107 /* If so, there is already a template in the descriptor and
3108 it is located right after the POINTER field. The fields are
3109 64bits so they must be repacked. */
3110 t = DECL_CHAIN (pointer);
3111 lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3112 lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
3115 ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3117 (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield);
3119 /* Build the template in the form of a constructor. */
3120 v = VEC_alloc (constructor_elt, gc, 2);
3121 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield);
3122 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (template_type)),
3124 template_tree = gnat_build_constructor (template_type, v);
3126 /* Otherwise use the {1, LENGTH} template we build above. */
3127 template_addr = build3 (COND_EXPR, p_bounds_type, u,
3128 build_unary_op (ADDR_EXPR, p_bounds_type,
3133 case 4: /* Class A */
3134 /* The AFLAGS field is the 3rd field after the pointer in the
3136 t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer)));
3137 aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3138 /* The DIMCT field is the next field in the descriptor after
3141 dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3142 /* Raise CONSTRAINT_ERROR if either more than 1 dimension
3143 or FL_COEFF or FL_BOUNDS not set. */
3144 u = build_int_cst (TREE_TYPE (aflags), 192);
3145 u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node,
3146 build_binary_op (NE_EXPR, boolean_type_node,
3148 convert (TREE_TYPE (dimct),
3150 build_binary_op (NE_EXPR, boolean_type_node,
3151 build2 (BIT_AND_EXPR,
3155 /* There is already a template in the descriptor and it is located
3156 in block 3. The fields are 64bits so they must be repacked. */
3157 t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN
3159 lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3160 lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
3163 ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3165 (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield);
3167 /* Build the template in the form of a constructor. */
3168 v = VEC_alloc (constructor_elt, gc, 2);
3169 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield);
3170 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (template_type)),
3172 template_tree = gnat_build_constructor (template_type, v);
3173 template_tree = build3 (COND_EXPR, template_type, u,
3174 build_call_raise (CE_Length_Check_Failed, Empty,
3175 N_Raise_Constraint_Error),
3178 = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree);
3181 case 10: /* Class NCA */
3183 post_error ("unsupported descriptor type for &", gnat_subprog);
3184 template_addr = integer_zero_node;
3188 /* Build the fat pointer in the form of a constructor. */
3189 v = VEC_alloc (constructor_elt, gc, 2);
3190 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr64);
3191 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)),
3193 return gnat_build_constructor (gnu_type, v);
3200 /* Convert GNU_EXPR, a pointer to a 32bit VMS descriptor, to GNU_TYPE, a
3201 regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to
3202 which the VMS descriptor is passed. */
3205 convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
3207 tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
3208 tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
3209 /* The CLASS field is the 3rd field in the descriptor. */
3210 tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type)));
3211 /* The POINTER field is the 4th field in the descriptor. */
3212 tree pointer = DECL_CHAIN (klass);
3214 /* Retrieve the value of the POINTER field. */
3216 = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
3218 if (POINTER_TYPE_P (gnu_type))
3219 return convert (gnu_type, gnu_expr32);
3221 else if (TYPE_IS_FAT_POINTER_P (gnu_type))
3223 tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3224 tree p_bounds_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
3225 tree template_type = TREE_TYPE (p_bounds_type);
3226 tree min_field = TYPE_FIELDS (template_type);
3227 tree max_field = DECL_CHAIN (TYPE_FIELDS (template_type));
3228 tree template_tree, template_addr, aflags, dimct, t, u;
3229 /* See the head comment of build_vms_descriptor. */
3230 int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
3231 VEC(constructor_elt,gc) *v;
3233 /* Convert POINTER to the pointer-to-array type. */
3234 gnu_expr32 = convert (p_array_type, gnu_expr32);
3238 case 1: /* Class S */
3239 case 15: /* Class SB */
3240 /* Build {1, LENGTH} template; LENGTH is the 1st field. */
3241 v = VEC_alloc (constructor_elt, gc, 2);
3242 t = TYPE_FIELDS (desc_type);
3243 t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3244 CONSTRUCTOR_APPEND_ELT (v, min_field,
3245 convert (TREE_TYPE (min_field),
3247 CONSTRUCTOR_APPEND_ELT (v, max_field,
3248 convert (TREE_TYPE (max_field), t));
3249 template_tree = gnat_build_constructor (template_type, v);
3250 template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree);
3252 /* For class S, we are done. */
3256 /* Test that we really have a SB descriptor, like DEC Ada. */
3257 t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL);
3258 u = convert (TREE_TYPE (klass), DECL_INITIAL (klass));
3259 u = build_binary_op (EQ_EXPR, boolean_type_node, t, u);
3260 /* If so, there is already a template in the descriptor and
3261 it is located right after the POINTER field. */
3262 t = DECL_CHAIN (pointer);
3264 = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3265 /* Otherwise use the {1, LENGTH} template we build above. */
3266 template_addr = build3 (COND_EXPR, p_bounds_type, u,
3267 build_unary_op (ADDR_EXPR, p_bounds_type,
3272 case 4: /* Class A */
3273 /* The AFLAGS field is the 7th field in the descriptor. */
3274 t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer)));
3275 aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3276 /* The DIMCT field is the 8th field in the descriptor. */
3278 dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3279 /* Raise CONSTRAINT_ERROR if either more than 1 dimension
3280 or FL_COEFF or FL_BOUNDS not set. */
3281 u = build_int_cst (TREE_TYPE (aflags), 192);
3282 u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node,
3283 build_binary_op (NE_EXPR, boolean_type_node,
3285 convert (TREE_TYPE (dimct),
3287 build_binary_op (NE_EXPR, boolean_type_node,
3288 build2 (BIT_AND_EXPR,
3292 /* There is already a template in the descriptor and it is
3293 located at the start of block 3 (12th field). */
3294 t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (t))));
3296 = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3297 template_tree = build3 (COND_EXPR, TREE_TYPE (t), u,
3298 build_call_raise (CE_Length_Check_Failed, Empty,
3299 N_Raise_Constraint_Error),
3302 = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree);
3305 case 10: /* Class NCA */
3307 post_error ("unsupported descriptor type for &", gnat_subprog);
3308 template_addr = integer_zero_node;
3312 /* Build the fat pointer in the form of a constructor. */
3313 v = VEC_alloc (constructor_elt, gc, 2);
3314 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr32);
3315 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)),
3318 return gnat_build_constructor (gnu_type, v);
3325 /* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular
3326 pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit)
3327 pointer type of GNU_EXPR. BY_REF is true if the result is to be used by
3328 reference. GNAT_SUBPROG is the subprogram to which the VMS descriptor is
3332 convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type,
3333 bool by_ref, Entity_Id gnat_subprog)
3335 tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
3336 tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
3337 tree mbo = TYPE_FIELDS (desc_type);
3338 const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo));
3339 tree mbmo = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (mbo)));
3340 tree real_type, is64bit, gnu_expr32, gnu_expr64;
3343 real_type = TREE_TYPE (gnu_type);
3345 real_type = gnu_type;
3347 /* If the field name is not MBO, it must be 32-bit and no alternate.
3348 Otherwise primary must be 64-bit and alternate 32-bit. */
3349 if (strcmp (mbostr, "MBO") != 0)
3351 tree ret = convert_vms_descriptor32 (real_type, gnu_expr, gnat_subprog);
3353 ret = build_unary_op (ADDR_EXPR, gnu_type, ret);
3357 /* Build the test for 64-bit descriptor. */
3358 mbo = build3 (COMPONENT_REF, TREE_TYPE (mbo), desc, mbo, NULL_TREE);
3359 mbmo = build3 (COMPONENT_REF, TREE_TYPE (mbmo), desc, mbmo, NULL_TREE);
3361 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
3362 build_binary_op (EQ_EXPR, boolean_type_node,
3363 convert (integer_type_node, mbo),
3365 build_binary_op (EQ_EXPR, boolean_type_node,
3366 convert (integer_type_node, mbmo),
3367 integer_minus_one_node));
3369 /* Build the 2 possible end results. */
3370 gnu_expr64 = convert_vms_descriptor64 (real_type, gnu_expr, gnat_subprog);
3372 gnu_expr64 = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr64);
3373 gnu_expr = fold_convert (gnu_expr_alt_type, gnu_expr);
3374 gnu_expr32 = convert_vms_descriptor32 (real_type, gnu_expr, gnat_subprog);
3376 gnu_expr32 = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr32);
3378 return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32);
3381 /* Build a type to be used to represent an aliased object whose nominal type
3382 is an unconstrained array. This consists of a RECORD_TYPE containing a
3383 field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE.
3384 If ARRAY_TYPE is that of an unconstrained array, this is used to represent
3385 an arbitrary unconstrained object. Use NAME as the name of the record.
3386 DEBUG_INFO_P is true if we need to write debug information for the type. */
3389 build_unc_object_type (tree template_type, tree object_type, tree name,
3392 tree type = make_node (RECORD_TYPE);
3394 = create_field_decl (get_identifier ("BOUNDS"), template_type, type,
3395 NULL_TREE, NULL_TREE, 0, 1);
3397 = create_field_decl (get_identifier ("ARRAY"), object_type, type,
3398 NULL_TREE, NULL_TREE, 0, 1);
3400 TYPE_NAME (type) = name;
3401 TYPE_CONTAINS_TEMPLATE_P (type) = 1;
3402 DECL_CHAIN (template_field) = array_field;
3403 finish_record_type (type, template_field, 0, true);
3405 /* Declare it now since it will never be declared otherwise. This is
3406 necessary to ensure that its subtrees are properly marked. */
3407 create_type_decl (name, type, NULL, true, debug_info_p, Empty);
3412 /* Same, taking a thin or fat pointer type instead of a template type. */
3415 build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
3416 tree name, bool debug_info_p)
3420 gcc_assert (TYPE_IS_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
3423 = (TYPE_IS_FAT_POINTER_P (thin_fat_ptr_type)
3424 ? TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (thin_fat_ptr_type))))
3425 : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type))));
3428 build_unc_object_type (template_type, object_type, name, debug_info_p);
3431 /* Shift the component offsets within an unconstrained object TYPE to make it
3432 suitable for use as a designated type for thin pointers. */
3435 shift_unc_components_for_thin_pointers (tree type)
3437 /* Thin pointer values designate the ARRAY data of an unconstrained object,
3438 allocated past the BOUNDS template. The designated type is adjusted to
3439 have ARRAY at position zero and the template at a negative offset, so
3440 that COMPONENT_REFs on (*thin_ptr) designate the proper location. */
3442 tree bounds_field = TYPE_FIELDS (type);
3443 tree array_field = DECL_CHAIN (TYPE_FIELDS (type));
3445 DECL_FIELD_OFFSET (bounds_field)
3446 = size_binop (MINUS_EXPR, size_zero_node, byte_position (array_field));
3448 DECL_FIELD_OFFSET (array_field) = size_zero_node;
3449 DECL_FIELD_BIT_OFFSET (array_field) = bitsize_zero_node;
3452 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.
3453 In the normal case this is just two adjustments, but we have more to
3454 do if NEW_TYPE is an UNCONSTRAINED_ARRAY_TYPE. */
3457 update_pointer_to (tree old_type, tree new_type)
3459 tree ptr = TYPE_POINTER_TO (old_type);
3460 tree ref = TYPE_REFERENCE_TO (old_type);
3463 /* If this is the main variant, process all the other variants first. */
3464 if (TYPE_MAIN_VARIANT (old_type) == old_type)
3465 for (t = TYPE_NEXT_VARIANT (old_type); t; t = TYPE_NEXT_VARIANT (t))
3466 update_pointer_to (t, new_type);
3468 /* If no pointers and no references, we are done. */
3472 /* Merge the old type qualifiers in the new type.
3474 Each old variant has qualifiers for specific reasons, and the new
3475 designated type as well. Each set of qualifiers represents useful
3476 information grabbed at some point, and merging the two simply unifies
3477 these inputs into the final type description.
3479 Consider for instance a volatile type frozen after an access to constant
3480 type designating it; after the designated type's freeze, we get here with
3481 a volatile NEW_TYPE and a dummy OLD_TYPE with a readonly variant, created
3482 when the access type was processed. We will make a volatile and readonly
3483 designated type, because that's what it really is.
3485 We might also get here for a non-dummy OLD_TYPE variant with different
3486 qualifiers than those of NEW_TYPE, for instance in some cases of pointers
3487 to private record type elaboration (see the comments around the call to
3488 this routine in gnat_to_gnu_entity <E_Access_Type>). We have to merge
3489 the qualifiers in those cases too, to avoid accidentally discarding the
3490 initial set, and will often end up with OLD_TYPE == NEW_TYPE then. */
3492 = build_qualified_type (new_type,
3493 TYPE_QUALS (old_type) | TYPE_QUALS (new_type));
3495 /* If old type and new type are identical, there is nothing to do. */
3496 if (old_type == new_type)
3499 /* Otherwise, first handle the simple case. */
3500 if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
3502 tree new_ptr, new_ref;
3504 /* If pointer or reference already points to new type, nothing to do.
3505 This can happen as update_pointer_to can be invoked multiple times
3506 on the same couple of types because of the type variants. */
3507 if ((ptr && TREE_TYPE (ptr) == new_type)
3508 || (ref && TREE_TYPE (ref) == new_type))
3511 /* Chain PTR and its variants at the end. */
3512 new_ptr = TYPE_POINTER_TO (new_type);
3515 while (TYPE_NEXT_PTR_TO (new_ptr))
3516 new_ptr = TYPE_NEXT_PTR_TO (new_ptr);
3517 TYPE_NEXT_PTR_TO (new_ptr) = ptr;
3520 TYPE_POINTER_TO (new_type) = ptr;
3522 /* Now adjust them. */
3523 for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr))
3524 for (t = TYPE_MAIN_VARIANT (ptr); t; t = TYPE_NEXT_VARIANT (t))
3526 TREE_TYPE (t) = new_type;
3527 if (TYPE_NULL_BOUNDS (t))
3528 TREE_TYPE (TREE_OPERAND (TYPE_NULL_BOUNDS (t), 0)) = new_type;
3531 /* If we have adjusted named types, finalize them. This is necessary
3532 since we had forced a DWARF typedef for them in gnat_pushdecl. */
3533 for (ptr = TYPE_POINTER_TO (old_type); ptr; ptr = TYPE_NEXT_PTR_TO (ptr))
3534 if (TYPE_NAME (ptr) && TREE_CODE (TYPE_NAME (ptr)) == TYPE_DECL)
3535 rest_of_type_decl_compilation (TYPE_NAME (ptr));
3537 /* Chain REF and its variants at the end. */
3538 new_ref = TYPE_REFERENCE_TO (new_type);
3541 while (TYPE_NEXT_REF_TO (new_ref))
3542 new_ref = TYPE_NEXT_REF_TO (new_ref);
3543 TYPE_NEXT_REF_TO (new_ref) = ref;
3546 TYPE_REFERENCE_TO (new_type) = ref;
3548 /* Now adjust them. */
3549 for (; ref; ref = TYPE_NEXT_REF_TO (ref))
3550 for (t = TYPE_MAIN_VARIANT (ref); t; t = TYPE_NEXT_VARIANT (t))
3551 TREE_TYPE (t) = new_type;
3553 TYPE_POINTER_TO (old_type) = NULL_TREE;
3554 TYPE_REFERENCE_TO (old_type) = NULL_TREE;
3557 /* Now deal with the unconstrained array case. In this case the pointer
3558 is actually a record where both fields are pointers to dummy nodes.
3559 Turn them into pointers to the correct types using update_pointer_to.
3560 Likewise for the pointer to the object record (thin pointer). */
3563 tree new_ptr = TYPE_POINTER_TO (new_type);
3565 gcc_assert (TYPE_IS_FAT_POINTER_P (ptr));
3567 /* If PTR already points to NEW_TYPE, nothing to do. This can happen
3568 since update_pointer_to can be invoked multiple times on the same
3569 couple of types because of the type variants. */
3570 if (TYPE_UNCONSTRAINED_ARRAY (ptr) == new_type)
3574 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
3575 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr))));
3578 (TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (ptr)))),
3579 TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (new_ptr)))));
3581 update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type),
3582 TYPE_OBJECT_RECORD_TYPE (new_type));
3584 TYPE_POINTER_TO (old_type) = NULL_TREE;
3588 /* Convert EXPR, a pointer to a constrained array, into a pointer to an
3589 unconstrained one. This involves making or finding a template. */
3592 convert_to_fat_pointer (tree type, tree expr)
3594 tree template_type = TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))));
3595 tree p_array_type = TREE_TYPE (TYPE_FIELDS (type));
3596 tree etype = TREE_TYPE (expr);
3598 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
3600 /* If EXPR is null, make a fat pointer that contains a null pointer to the
3601 array (compare_fat_pointers ensures that this is the full discriminant)
3602 and a valid pointer to the bounds. This latter property is necessary
3603 since the compiler can hoist the load of the bounds done through it. */
3604 if (integer_zerop (expr))
3606 tree ptr_template_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)));
3607 tree null_bounds, t;
3609 if (TYPE_NULL_BOUNDS (ptr_template_type))
3610 null_bounds = TYPE_NULL_BOUNDS (ptr_template_type);
3613 /* The template type can still be dummy at this point so we build an
3614 empty constructor. The middle-end will fill it in with zeros. */
3615 t = build_constructor (template_type, NULL);
3616 TREE_CONSTANT (t) = TREE_STATIC (t) = 1;
3617 null_bounds = build_unary_op (ADDR_EXPR, NULL_TREE, t);
3618 SET_TYPE_NULL_BOUNDS (ptr_template_type, null_bounds);
3621 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
3622 fold_convert (p_array_type, null_pointer_node));
3623 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), null_bounds);
3624 t = build_constructor (type, v);
3625 /* Do not set TREE_CONSTANT so as to force T to static memory. */
3626 TREE_CONSTANT (t) = 0;
3627 TREE_STATIC (t) = 1;
3632 /* If EXPR is a thin pointer, make template and data from the record.. */
3633 else if (TYPE_IS_THIN_POINTER_P (etype))
3635 tree fields = TYPE_FIELDS (TREE_TYPE (etype));
3637 expr = gnat_protect_expr (expr);
3638 if (TREE_CODE (expr) == ADDR_EXPR)
3639 expr = TREE_OPERAND (expr, 0);
3641 expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
3643 template_tree = build_component_ref (expr, NULL_TREE, fields, false);
3644 expr = build_unary_op (ADDR_EXPR, NULL_TREE,
3645 build_component_ref (expr, NULL_TREE,
3646 DECL_CHAIN (fields), false));
3649 /* Otherwise, build the constructor for the template. */
3651 template_tree = build_template (template_type, TREE_TYPE (etype), expr);
3653 /* The final result is a constructor for the fat pointer.
3655 If EXPR is an argument of a foreign convention subprogram, the type it
3656 points to is directly the component type. In this case, the expression
3657 type may not match the corresponding FIELD_DECL type at this point, so we
3658 call "convert" here to fix that up if necessary. This type consistency is
3659 required, for instance because it ensures that possible later folding of
3660 COMPONENT_REFs against this constructor always yields something of the
3661 same type as the initial reference.
3663 Note that the call to "build_template" above is still fine because it
3664 will only refer to the provided TEMPLATE_TYPE in this case. */
3665 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
3666 convert (p_array_type, expr));
3667 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
3668 build_unary_op (ADDR_EXPR, NULL_TREE,
3670 return gnat_build_constructor (type, v);
3673 /* Convert to a thin pointer type, TYPE. The only thing we know how to convert
3674 is something that is a fat pointer, so convert to it first if it EXPR
3675 is not already a fat pointer. */
3678 convert_to_thin_pointer (tree type, tree expr)
3680 if (!TYPE_IS_FAT_POINTER_P (TREE_TYPE (expr)))
3682 = convert_to_fat_pointer
3683 (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr);
3685 /* We get the pointer to the data and use a NOP_EXPR to make it the
3687 expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)),
3689 expr = build1 (NOP_EXPR, type, expr);
3694 /* Create an expression whose value is that of EXPR,
3695 converted to type TYPE. The TREE_TYPE of the value
3696 is always TYPE. This function implements all reasonable
3697 conversions; callers should filter out those that are
3698 not permitted by the language being compiled. */
3701 convert (tree type, tree expr)
3703 tree etype = TREE_TYPE (expr);
3704 enum tree_code ecode = TREE_CODE (etype);
3705 enum tree_code code = TREE_CODE (type);
3707 /* If the expression is already of the right type, we are done. */
3711 /* If both input and output have padding and are of variable size, do this
3712 as an unchecked conversion. Likewise if one is a mere variant of the
3713 other, so we avoid a pointless unpad/repad sequence. */
3714 else if (code == RECORD_TYPE && ecode == RECORD_TYPE
3715 && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype)
3716 && (!TREE_CONSTANT (TYPE_SIZE (type))
3717 || !TREE_CONSTANT (TYPE_SIZE (etype))
3718 || gnat_types_compatible_p (type, etype)
3719 || TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type)))
3720 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (etype)))))
3723 /* If the output type has padding, convert to the inner type and make a
3724 constructor to build the record, unless a variable size is involved. */
3725 else if (code == RECORD_TYPE && TYPE_PADDING_P (type))
3727 VEC(constructor_elt,gc) *v;
3729 /* If we previously converted from another type and our type is
3730 of variable size, remove the conversion to avoid the need for
3731 variable-sized temporaries. Likewise for a conversion between
3732 original and packable version. */
3733 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
3734 && (!TREE_CONSTANT (TYPE_SIZE (type))
3735 || (ecode == RECORD_TYPE
3736 && TYPE_NAME (etype)
3737 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (expr, 0))))))
3738 expr = TREE_OPERAND (expr, 0);
3740 /* If we are just removing the padding from expr, convert the original
3741 object if we have variable size in order to avoid the need for some
3742 variable-sized temporaries. Likewise if the padding is a variant
3743 of the other, so we avoid a pointless unpad/repad sequence. */
3744 if (TREE_CODE (expr) == COMPONENT_REF
3745 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
3746 && (!TREE_CONSTANT (TYPE_SIZE (type))
3747 || gnat_types_compatible_p (type,
3748 TREE_TYPE (TREE_OPERAND (expr, 0)))
3749 || (ecode == RECORD_TYPE
3750 && TYPE_NAME (etype)
3751 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type))))))
3752 return convert (type, TREE_OPERAND (expr, 0));
3754 /* If the inner type is of self-referential size and the expression type
3755 is a record, do this as an unchecked conversion. But first pad the
3756 expression if possible to have the same size on both sides. */
3757 if (ecode == RECORD_TYPE
3758 && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
3760 if (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST)
3761 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
3762 false, false, false, true),
3764 return unchecked_convert (type, expr, false);
3767 /* If we are converting between array types with variable size, do the
3768 final conversion as an unchecked conversion, again to avoid the need
3769 for some variable-sized temporaries. If valid, this conversion is
3770 very likely purely technical and without real effects. */
3771 if (ecode == ARRAY_TYPE
3772 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == ARRAY_TYPE
3773 && !TREE_CONSTANT (TYPE_SIZE (etype))
3774 && !TREE_CONSTANT (TYPE_SIZE (type)))
3775 return unchecked_convert (type,
3776 convert (TREE_TYPE (TYPE_FIELDS (type)),
3780 v = VEC_alloc (constructor_elt, gc, 1);
3781 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
3782 convert (TREE_TYPE (TYPE_FIELDS (type)), expr));
3783 return gnat_build_constructor (type, v);
3786 /* If the input type has padding, remove it and convert to the output type.
3787 The conditions ordering is arranged to ensure that the output type is not
3788 a padding type here, as it is not clear whether the conversion would
3789 always be correct if this was to happen. */
3790 else if (ecode == RECORD_TYPE && TYPE_PADDING_P (etype))
3794 /* If we have just converted to this padded type, just get the
3795 inner expression. */
3796 if (TREE_CODE (expr) == CONSTRUCTOR
3797 && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr))
3798 && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index
3799 == TYPE_FIELDS (etype))
3801 = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value;
3803 /* Otherwise, build an explicit component reference. */
3806 = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false);
3808 return convert (type, unpadded);
3811 /* If the input is a biased type, adjust first. */
3812 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
3813 return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype),
3814 fold_convert (TREE_TYPE (etype),
3816 TYPE_MIN_VALUE (etype)));
3818 /* If the input is a justified modular type, we need to extract the actual
3819 object before converting it to any other type with the exceptions of an
3820 unconstrained array or of a mere type variant. It is useful to avoid the
3821 extraction and conversion in the type variant case because it could end
3822 up replacing a VAR_DECL expr by a constructor and we might be about the
3823 take the address of the result. */
3824 if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
3825 && code != UNCONSTRAINED_ARRAY_TYPE
3826 && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype))
3827 return convert (type, build_component_ref (expr, NULL_TREE,
3828 TYPE_FIELDS (etype), false));
3830 /* If converting to a type that contains a template, convert to the data
3831 type and then build the template. */
3832 if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type))
3834 tree obj_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)));
3835 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
3837 /* If the source already has a template, get a reference to the
3838 associated array only, as we are going to rebuild a template
3839 for the target type anyway. */
3840 expr = maybe_unconstrained_array (expr);
3842 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
3843 build_template (TREE_TYPE (TYPE_FIELDS (type)),
3844 obj_type, NULL_TREE));
3845 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
3846 convert (obj_type, expr));
3847 return gnat_build_constructor (type, v);
3850 /* There are some cases of expressions that we process specially. */
3851 switch (TREE_CODE (expr))
3857 /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
3858 conversion in gnat_expand_expr. NULL_EXPR does not represent
3859 and actual value, so no conversion is needed. */
3860 expr = copy_node (expr);
3861 TREE_TYPE (expr) = type;
3865 /* If we are converting a STRING_CST to another constrained array type,
3866 just make a new one in the proper type. */
3867 if (code == ecode && AGGREGATE_TYPE_P (etype)
3868 && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
3869 && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
3871 expr = copy_node (expr);
3872 TREE_TYPE (expr) = type;
3878 /* If we are converting a VECTOR_CST to a mere variant type, just make
3879 a new one in the proper type. */
3880 if (code == ecode && gnat_types_compatible_p (type, etype))
3882 expr = copy_node (expr);
3883 TREE_TYPE (expr) = type;
3888 /* If we are converting a CONSTRUCTOR to a mere variant type, just make
3889 a new one in the proper type. */
3890 if (code == ecode && gnat_types_compatible_p (type, etype))
3892 expr = copy_node (expr);
3893 TREE_TYPE (expr) = type;
3897 /* Likewise for a conversion between original and packable version, or
3898 conversion between types of the same size and with the same list of
3899 fields, but we have to work harder to preserve type consistency. */
3901 && code == RECORD_TYPE
3902 && (TYPE_NAME (type) == TYPE_NAME (etype)
3903 || tree_int_cst_equal (TYPE_SIZE (type), TYPE_SIZE (etype))))
3906 VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr);
3907 unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e);
3908 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, len);
3909 tree efield = TYPE_FIELDS (etype), field = TYPE_FIELDS (type);
3910 unsigned HOST_WIDE_INT idx;
3913 /* Whether we need to clear TREE_CONSTANT et al. on the output
3914 constructor when we convert in place. */
3915 bool clear_constant = false;
3917 FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value)
3919 constructor_elt *elt;
3920 /* We expect only simple constructors. */
3921 if (!SAME_FIELD_P (index, efield))
3923 /* The field must be the same. */
3924 if (!SAME_FIELD_P (efield, field))
3926 elt = VEC_quick_push (constructor_elt, v, NULL);
3928 elt->value = convert (TREE_TYPE (field), value);
3930 /* If packing has made this field a bitfield and the input
3931 value couldn't be emitted statically any more, we need to
3932 clear TREE_CONSTANT on our output. */
3934 && TREE_CONSTANT (expr)
3935 && !CONSTRUCTOR_BITFIELD_P (efield)
3936 && CONSTRUCTOR_BITFIELD_P (field)
3937 && !initializer_constant_valid_for_bitfield_p (value))
3938 clear_constant = true;
3940 efield = DECL_CHAIN (efield);
3941 field = DECL_CHAIN (field);
3944 /* If we have been able to match and convert all the input fields
3945 to their output type, convert in place now. We'll fallback to a
3946 view conversion downstream otherwise. */
3949 expr = copy_node (expr);
3950 TREE_TYPE (expr) = type;
3951 CONSTRUCTOR_ELTS (expr) = v;
3953 TREE_CONSTANT (expr) = TREE_STATIC (expr) = 0;
3958 /* Likewise for a conversion between array type and vector type with a
3959 compatible representative array. */
3960 else if (code == VECTOR_TYPE
3961 && ecode == ARRAY_TYPE
3962 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
3965 VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr);
3966 unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e);
3967 VEC(constructor_elt,gc) *v;
3968 unsigned HOST_WIDE_INT ix;
3971 /* Build a VECTOR_CST from a *constant* array constructor. */
3972 if (TREE_CONSTANT (expr))
3974 bool constant_p = true;
3976 /* Iterate through elements and check if all constructor
3977 elements are *_CSTs. */
3978 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
3979 if (!CONSTANT_CLASS_P (value))
3986 return build_vector_from_ctor (type,
3987 CONSTRUCTOR_ELTS (expr));
3990 /* Otherwise, build a regular vector constructor. */
3991 v = VEC_alloc (constructor_elt, gc, len);
3992 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
3994 constructor_elt *elt = VEC_quick_push (constructor_elt, v, NULL);
3995 elt->index = NULL_TREE;
3998 expr = copy_node (expr);
3999 TREE_TYPE (expr) = type;
4000 CONSTRUCTOR_ELTS (expr) = v;
4005 case UNCONSTRAINED_ARRAY_REF:
4006 /* First retrieve the underlying array. */
4007 expr = maybe_unconstrained_array (expr);
4008 etype = TREE_TYPE (expr);
4009 ecode = TREE_CODE (etype);
4012 case VIEW_CONVERT_EXPR:
4014 /* GCC 4.x is very sensitive to type consistency overall, and view
4015 conversions thus are very frequent. Even though just "convert"ing
4016 the inner operand to the output type is fine in most cases, it
4017 might expose unexpected input/output type mismatches in special
4018 circumstances so we avoid such recursive calls when we can. */
4019 tree op0 = TREE_OPERAND (expr, 0);
4021 /* If we are converting back to the original type, we can just
4022 lift the input conversion. This is a common occurrence with
4023 switches back-and-forth amongst type variants. */
4024 if (type == TREE_TYPE (op0))
4027 /* Otherwise, if we're converting between two aggregate or vector
4028 types, we might be allowed to substitute the VIEW_CONVERT_EXPR
4029 target type in place or to just convert the inner expression. */
4030 if ((AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
4031 || (VECTOR_TYPE_P (type) && VECTOR_TYPE_P (etype)))
4033 /* If we are converting between mere variants, we can just
4034 substitute the VIEW_CONVERT_EXPR in place. */
4035 if (gnat_types_compatible_p (type, etype))
4036 return build1 (VIEW_CONVERT_EXPR, type, op0);
4038 /* Otherwise, we may just bypass the input view conversion unless
4039 one of the types is a fat pointer, which is handled by
4040 specialized code below which relies on exact type matching. */
4041 else if (!TYPE_IS_FAT_POINTER_P (type)
4042 && !TYPE_IS_FAT_POINTER_P (etype))
4043 return convert (type, op0);
4053 /* Check for converting to a pointer to an unconstrained array. */
4054 if (TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype))
4055 return convert_to_fat_pointer (type, expr);
4057 /* If we are converting between two aggregate or vector types that are mere
4058 variants, just make a VIEW_CONVERT_EXPR. Likewise when we are converting
4059 to a vector type from its representative array type. */
4060 else if ((code == ecode
4061 && (AGGREGATE_TYPE_P (type) || VECTOR_TYPE_P (type))
4062 && gnat_types_compatible_p (type, etype))
4063 || (code == VECTOR_TYPE
4064 && ecode == ARRAY_TYPE
4065 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
4067 return build1 (VIEW_CONVERT_EXPR, type, expr);
4069 /* If we are converting between tagged types, try to upcast properly. */
4070 else if (ecode == RECORD_TYPE && code == RECORD_TYPE
4071 && TYPE_ALIGN_OK (etype) && TYPE_ALIGN_OK (type))
4073 tree child_etype = etype;
4075 tree field = TYPE_FIELDS (child_etype);
4076 if (DECL_NAME (field) == parent_name_id && TREE_TYPE (field) == type)
4077 return build_component_ref (expr, NULL_TREE, field, false);
4078 child_etype = TREE_TYPE (field);
4079 } while (TREE_CODE (child_etype) == RECORD_TYPE);
4082 /* If we are converting from a smaller form of record type back to it, just
4083 make a VIEW_CONVERT_EXPR. But first pad the expression to have the same
4084 size on both sides. */
4085 else if (ecode == RECORD_TYPE && code == RECORD_TYPE
4086 && smaller_form_type_p (etype, type))
4088 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
4089 false, false, false, true),
4091 return build1 (VIEW_CONVERT_EXPR, type, expr);
4094 /* In all other cases of related types, make a NOP_EXPR. */
4095 else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
4096 return fold_convert (type, expr);
4101 return fold_build1 (CONVERT_EXPR, type, expr);
4104 if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
4105 && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
4106 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
4107 return unchecked_convert (type, expr, false);
4108 else if (TYPE_BIASED_REPRESENTATION_P (type))
4109 return fold_convert (type,
4110 fold_build2 (MINUS_EXPR, TREE_TYPE (type),
4111 convert (TREE_TYPE (type), expr),
4112 TYPE_MIN_VALUE (type)));
4114 /* ... fall through ... */
4118 /* If we are converting an additive expression to an integer type
4119 with lower precision, be wary of the optimization that can be
4120 applied by convert_to_integer. There are 2 problematic cases:
4121 - if the first operand was originally of a biased type,
4122 because we could be recursively called to convert it
4123 to an intermediate type and thus rematerialize the
4124 additive operator endlessly,
4125 - if the expression contains a placeholder, because an
4126 intermediate conversion that changes the sign could
4127 be inserted and thus introduce an artificial overflow
4128 at compile time when the placeholder is substituted. */
4129 if (code == INTEGER_TYPE
4130 && ecode == INTEGER_TYPE
4131 && TYPE_PRECISION (type) < TYPE_PRECISION (etype)
4132 && (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR))
4134 tree op0 = get_unwidened (TREE_OPERAND (expr, 0), type);
4136 if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE
4137 && TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0)))
4138 || CONTAINS_PLACEHOLDER_P (expr))
4139 return build1 (NOP_EXPR, type, expr);
4142 return fold (convert_to_integer (type, expr));
4145 case REFERENCE_TYPE:
4146 /* If converting between two pointers to records denoting
4147 both a template and type, adjust if needed to account
4148 for any differing offsets, since one might be negative. */
4149 if (TYPE_IS_THIN_POINTER_P (etype) && TYPE_IS_THIN_POINTER_P (type))
4152 = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))),
4153 bit_position (TYPE_FIELDS (TREE_TYPE (type))));
4155 = size_binop (CEIL_DIV_EXPR, bit_diff, sbitsize_unit_node);
4156 expr = build1 (NOP_EXPR, type, expr);
4157 TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0));
4158 if (integer_zerop (byte_diff))
4161 return build_binary_op (POINTER_PLUS_EXPR, type, expr,
4162 fold (convert (sizetype, byte_diff)));
4165 /* If converting to a thin pointer, handle specially. */
4166 if (TYPE_IS_THIN_POINTER_P (type)
4167 && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
4168 return convert_to_thin_pointer (type, expr);
4170 /* If converting fat pointer to normal pointer, get the pointer to the
4171 array and then convert it. */
4172 else if (TYPE_IS_FAT_POINTER_P (etype))
4174 = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false);
4176 return fold (convert_to_pointer (type, expr));
4179 return fold (convert_to_real (type, expr));
4182 if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype))
4184 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1);
4186 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
4187 convert (TREE_TYPE (TYPE_FIELDS (type)),
4189 return gnat_build_constructor (type, v);
4192 /* ... fall through ... */
4195 /* In these cases, assume the front-end has validated the conversion.
4196 If the conversion is valid, it will be a bit-wise conversion, so
4197 it can be viewed as an unchecked conversion. */
4198 return unchecked_convert (type, expr, false);
4201 /* This is a either a conversion between a tagged type and some
4202 subtype, which we have to mark as a UNION_TYPE because of
4203 overlapping fields or a conversion of an Unchecked_Union. */
4204 return unchecked_convert (type, expr, false);
4206 case UNCONSTRAINED_ARRAY_TYPE:
4207 /* If the input is a VECTOR_TYPE, convert to the representative
4208 array type first. */
4209 if (ecode == VECTOR_TYPE)
4211 expr = convert (TYPE_REPRESENTATIVE_ARRAY (etype), expr);
4212 etype = TREE_TYPE (expr);
4213 ecode = TREE_CODE (etype);
4216 /* If EXPR is a constrained array, take its address, convert it to a
4217 fat pointer, and then dereference it. Likewise if EXPR is a
4218 record containing both a template and a constrained array.
4219 Note that a record representing a justified modular type
4220 always represents a packed constrained array. */
4221 if (ecode == ARRAY_TYPE
4222 || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
4223 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
4224 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))
4227 (INDIRECT_REF, NULL_TREE,
4228 convert_to_fat_pointer (TREE_TYPE (type),
4229 build_unary_op (ADDR_EXPR,
4232 /* Do something very similar for converting one unconstrained
4233 array to another. */
4234 else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
4236 build_unary_op (INDIRECT_REF, NULL_TREE,
4237 convert (TREE_TYPE (type),
4238 build_unary_op (ADDR_EXPR,
4244 return fold (convert_to_complex (type, expr));
4251 /* Create an expression whose value is that of EXPR converted to the common
4252 index type, which is sizetype. EXPR is supposed to be in the base type
4253 of the GNAT index type. Calling it is equivalent to doing
4255 convert (sizetype, expr)
4257 but we try to distribute the type conversion with the knowledge that EXPR
4258 cannot overflow in its type. This is a best-effort approach and we fall
4259 back to the above expression as soon as difficulties are encountered.
4261 This is necessary to overcome issues that arise when the GNAT base index
4262 type and the GCC common index type (sizetype) don't have the same size,
4263 which is quite frequent on 64-bit architectures. In this case, and if
4264 the GNAT base index type is signed but the iteration type of the loop has
4265 been forced to unsigned, the loop scalar evolution engine cannot compute
4266 a simple evolution for the general induction variables associated with the
4267 array indices, because it will preserve the wrap-around semantics in the
4268 unsigned type of their "inner" part. As a result, many loop optimizations
4271 The solution is to use a special (basic) induction variable that is at
4272 least as large as sizetype, and to express the aforementioned general
4273 induction variables in terms of this induction variable, eliminating
4274 the problematic intermediate truncation to the GNAT base index type.
4275 This is possible as long as the original expression doesn't overflow
4276 and if the middle-end hasn't introduced artificial overflows in the
4277 course of the various simplification it can make to the expression. */
4280 convert_to_index_type (tree expr)
4282 enum tree_code code = TREE_CODE (expr);
4283 tree type = TREE_TYPE (expr);
4285 /* If the type is unsigned, overflow is allowed so we cannot be sure that
4286 EXPR doesn't overflow. Keep it simple if optimization is disabled. */
4287 if (TYPE_UNSIGNED (type) || !optimize)
4288 return convert (sizetype, expr);
4293 /* The main effect of the function: replace a loop parameter with its
4294 associated special induction variable. */
4295 if (DECL_LOOP_PARM_P (expr) && DECL_INDUCTION_VAR (expr))
4296 expr = DECL_INDUCTION_VAR (expr);
4301 tree otype = TREE_TYPE (TREE_OPERAND (expr, 0));
4302 /* Bail out as soon as we suspect some sort of type frobbing. */
4303 if (TYPE_PRECISION (type) != TYPE_PRECISION (otype)
4304 || TYPE_UNSIGNED (type) != TYPE_UNSIGNED (otype))
4308 /* ... fall through ... */
4310 case NON_LVALUE_EXPR:
4311 return fold_build1 (code, sizetype,
4312 convert_to_index_type (TREE_OPERAND (expr, 0)));
4317 return fold_build2 (code, sizetype,
4318 convert_to_index_type (TREE_OPERAND (expr, 0)),
4319 convert_to_index_type (TREE_OPERAND (expr, 1)));
4322 return fold_build2 (code, sizetype, TREE_OPERAND (expr, 0),
4323 convert_to_index_type (TREE_OPERAND (expr, 1)));
4326 return fold_build3 (code, sizetype, TREE_OPERAND (expr, 0),
4327 convert_to_index_type (TREE_OPERAND (expr, 1)),
4328 convert_to_index_type (TREE_OPERAND (expr, 2)));
4334 return convert (sizetype, expr);
4337 /* Remove all conversions that are done in EXP. This includes converting
4338 from a padded type or to a justified modular type. If TRUE_ADDRESS
4339 is true, always return the address of the containing object even if
4340 the address is not bit-aligned. */
4343 remove_conversions (tree exp, bool true_address)
4345 switch (TREE_CODE (exp))
4349 && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
4350 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
4352 remove_conversions (VEC_index (constructor_elt,
4353 CONSTRUCTOR_ELTS (exp), 0)->value,
4358 if (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
4359 return remove_conversions (TREE_OPERAND (exp, 0), true_address);
4363 case VIEW_CONVERT_EXPR:
4364 case NON_LVALUE_EXPR:
4365 return remove_conversions (TREE_OPERAND (exp, 0), true_address);
4374 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
4375 refers to the underlying array. If it has TYPE_CONTAINS_TEMPLATE_P,
4376 likewise return an expression pointing to the underlying array. */
4379 maybe_unconstrained_array (tree exp)
4381 enum tree_code code = TREE_CODE (exp);
4382 tree type = TREE_TYPE (exp);
4384 switch (TREE_CODE (type))
4386 case UNCONSTRAINED_ARRAY_TYPE:
4387 if (code == UNCONSTRAINED_ARRAY_REF)
4389 const bool read_only = TREE_READONLY (exp);
4390 const bool no_trap = TREE_THIS_NOTRAP (exp);
4392 exp = TREE_OPERAND (exp, 0);
4393 type = TREE_TYPE (exp);
4395 if (TREE_CODE (exp) == COND_EXPR)
4398 = build_unary_op (INDIRECT_REF, NULL_TREE,
4399 build_component_ref (TREE_OPERAND (exp, 1),
4404 = build_unary_op (INDIRECT_REF, NULL_TREE,
4405 build_component_ref (TREE_OPERAND (exp, 2),
4410 exp = build3 (COND_EXPR,
4411 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (type))),
4412 TREE_OPERAND (exp, 0), op1, op2);
4416 exp = build_unary_op (INDIRECT_REF, NULL_TREE,
4417 build_component_ref (exp, NULL_TREE,
4420 TREE_READONLY (exp) = read_only;
4421 TREE_THIS_NOTRAP (exp) = no_trap;
4425 else if (code == NULL_EXPR)
4426 exp = build1 (NULL_EXPR,
4427 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))),
4428 TREE_OPERAND (exp, 0));
4432 /* If this is a padded type and it contains a template, convert to the
4433 unpadded type first. */
4434 if (TYPE_PADDING_P (type)
4435 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
4436 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
4438 exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
4439 type = TREE_TYPE (exp);
4442 if (TYPE_CONTAINS_TEMPLATE_P (type))
4444 exp = build_component_ref (exp, NULL_TREE,
4445 DECL_CHAIN (TYPE_FIELDS (type)),
4447 type = TREE_TYPE (exp);
4449 /* If the array type is padded, convert to the unpadded type. */
4450 if (TYPE_IS_PADDING_P (type))
4451 exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp);
4462 /* If EXP's type is a VECTOR_TYPE, return EXP converted to the associated
4463 TYPE_REPRESENTATIVE_ARRAY. */
4466 maybe_vector_array (tree exp)
4468 tree etype = TREE_TYPE (exp);
4470 if (VECTOR_TYPE_P (etype))
4471 exp = convert (TYPE_REPRESENTATIVE_ARRAY (etype), exp);
4476 /* Return true if EXPR is an expression that can be folded as an operand
4477 of a VIEW_CONVERT_EXPR. See ada-tree.h for a complete rationale. */
4480 can_fold_for_view_convert_p (tree expr)
4484 /* The folder will fold NOP_EXPRs between integral types with the same
4485 precision (in the middle-end's sense). We cannot allow it if the
4486 types don't have the same precision in the Ada sense as well. */
4487 if (TREE_CODE (expr) != NOP_EXPR)
4490 t1 = TREE_TYPE (expr);
4491 t2 = TREE_TYPE (TREE_OPERAND (expr, 0));
4493 /* Defer to the folder for non-integral conversions. */
4494 if (!(INTEGRAL_TYPE_P (t1) && INTEGRAL_TYPE_P (t2)))
4497 /* Only fold conversions that preserve both precisions. */
4498 if (TYPE_PRECISION (t1) == TYPE_PRECISION (t2)
4499 && operand_equal_p (rm_size (t1), rm_size (t2), 0))
4505 /* Return an expression that does an unchecked conversion of EXPR to TYPE.
4506 If NOTRUNC_P is true, truncation operations should be suppressed.
4508 Special care is required with (source or target) integral types whose
4509 precision is not equal to their size, to make sure we fetch or assign
4510 the value bits whose location might depend on the endianness, e.g.
4512 Rmsize : constant := 8;
4513 subtype Int is Integer range 0 .. 2 ** Rmsize - 1;
4515 type Bit_Array is array (1 .. Rmsize) of Boolean;
4516 pragma Pack (Bit_Array);
4518 function To_Bit_Array is new Unchecked_Conversion (Int, Bit_Array);
4520 Value : Int := 2#1000_0001#;
4521 Vbits : Bit_Array := To_Bit_Array (Value);
4523 we expect the 8 bits at Vbits'Address to always contain Value, while
4524 their original location depends on the endianness, at Value'Address
4525 on a little-endian architecture but not on a big-endian one. */
4528 unchecked_convert (tree type, tree expr, bool notrunc_p)
4530 tree etype = TREE_TYPE (expr);
4531 enum tree_code ecode = TREE_CODE (etype);
4532 enum tree_code code = TREE_CODE (type);
4535 /* If the expression is already of the right type, we are done. */
4539 /* If both types types are integral just do a normal conversion.
4540 Likewise for a conversion to an unconstrained array. */
4541 if ((((INTEGRAL_TYPE_P (type)
4542 && !(code == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (type)))
4543 || (POINTER_TYPE_P (type) && ! TYPE_IS_THIN_POINTER_P (type))
4544 || (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type)))
4545 && ((INTEGRAL_TYPE_P (etype)
4546 && !(ecode == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (etype)))
4547 || (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype))
4548 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))))
4549 || code == UNCONSTRAINED_ARRAY_TYPE)
4551 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
4553 tree ntype = copy_type (etype);
4554 TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
4555 TYPE_MAIN_VARIANT (ntype) = ntype;
4556 expr = build1 (NOP_EXPR, ntype, expr);
4559 if (code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
4561 tree rtype = copy_type (type);
4562 TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
4563 TYPE_MAIN_VARIANT (rtype) = rtype;
4564 expr = convert (rtype, expr);
4565 expr = build1 (NOP_EXPR, type, expr);
4568 expr = convert (type, expr);
4571 /* If we are converting to an integral type whose precision is not equal
4572 to its size, first unchecked convert to a record type that contains an
4573 field of the given precision. Then extract the field. */
4574 else if (INTEGRAL_TYPE_P (type)
4575 && TYPE_RM_SIZE (type)
4576 && 0 != compare_tree_int (TYPE_RM_SIZE (type),
4577 GET_MODE_BITSIZE (TYPE_MODE (type))))
4579 tree rec_type = make_node (RECORD_TYPE);
4580 unsigned HOST_WIDE_INT prec = TREE_INT_CST_LOW (TYPE_RM_SIZE (type));
4581 tree field_type, field;
4583 if (TYPE_UNSIGNED (type))
4584 field_type = make_unsigned_type (prec);
4586 field_type = make_signed_type (prec);
4587 SET_TYPE_RM_SIZE (field_type, TYPE_RM_SIZE (type));
4589 field = create_field_decl (get_identifier ("OBJ"), field_type, rec_type,
4590 NULL_TREE, NULL_TREE, 1, 0);
4592 TYPE_FIELDS (rec_type) = field;
4593 layout_type (rec_type);
4595 expr = unchecked_convert (rec_type, expr, notrunc_p);
4596 expr = build_component_ref (expr, NULL_TREE, field, false);
4597 expr = fold_build1 (NOP_EXPR, type, expr);
4600 /* Similarly if we are converting from an integral type whose precision is
4601 not equal to its size, first copy into a field of the given precision
4602 and unchecked convert the record type. */
4603 else if (INTEGRAL_TYPE_P (etype)
4604 && TYPE_RM_SIZE (etype)
4605 && 0 != compare_tree_int (TYPE_RM_SIZE (etype),
4606 GET_MODE_BITSIZE (TYPE_MODE (etype))))
4608 tree rec_type = make_node (RECORD_TYPE);
4609 unsigned HOST_WIDE_INT prec = TREE_INT_CST_LOW (TYPE_RM_SIZE (etype));
4610 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1);
4611 tree field_type, field;
4613 if (TYPE_UNSIGNED (etype))
4614 field_type = make_unsigned_type (prec);
4616 field_type = make_signed_type (prec);
4617 SET_TYPE_RM_SIZE (field_type, TYPE_RM_SIZE (etype));
4619 field = create_field_decl (get_identifier ("OBJ"), field_type, rec_type,
4620 NULL_TREE, NULL_TREE, 1, 0);
4622 TYPE_FIELDS (rec_type) = field;
4623 layout_type (rec_type);
4625 expr = fold_build1 (NOP_EXPR, field_type, expr);
4626 CONSTRUCTOR_APPEND_ELT (v, field, expr);
4627 expr = gnat_build_constructor (rec_type, v);
4628 expr = unchecked_convert (type, expr, notrunc_p);
4631 /* If we are converting from a scalar type to a type with a different size,
4632 we need to pad to have the same size on both sides.
4634 ??? We cannot do it unconditionally because unchecked conversions are
4635 used liberally by the front-end to implement polymorphism, e.g. in:
4637 S191s : constant ada__tags__addr_ptr := ada__tags__addr_ptr!(S190s);
4638 return p___size__4 (p__object!(S191s.all));
4640 so we skip all expressions that are references. */
4641 else if (!REFERENCE_CLASS_P (expr)
4642 && !AGGREGATE_TYPE_P (etype)
4643 && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST
4644 && (c = tree_int_cst_compare (TYPE_SIZE (etype), TYPE_SIZE (type))))
4648 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
4649 false, false, false, true),
4651 expr = unchecked_convert (type, expr, notrunc_p);
4655 tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty,
4656 false, false, false, true);
4657 expr = unchecked_convert (rec_type, expr, notrunc_p);
4658 expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (rec_type),
4663 /* We have a special case when we are converting between two unconstrained
4664 array types. In that case, take the address, convert the fat pointer
4665 types, and dereference. */
4666 else if (ecode == code && code == UNCONSTRAINED_ARRAY_TYPE)
4667 expr = build_unary_op (INDIRECT_REF, NULL_TREE,
4668 build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type),
4669 build_unary_op (ADDR_EXPR, NULL_TREE,
4672 /* Another special case is when we are converting to a vector type from its
4673 representative array type; this a regular conversion. */
4674 else if (code == VECTOR_TYPE
4675 && ecode == ARRAY_TYPE
4676 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
4678 expr = convert (type, expr);
4682 expr = maybe_unconstrained_array (expr);
4683 etype = TREE_TYPE (expr);
4684 ecode = TREE_CODE (etype);
4685 if (can_fold_for_view_convert_p (expr))
4686 expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr);
4688 expr = build1 (VIEW_CONVERT_EXPR, type, expr);
4691 /* If the result is an integral type whose precision is not equal to its
4692 size, sign- or zero-extend the result. We need not do this if the input
4693 is an integral type of the same precision and signedness or if the output
4694 is a biased type or if both the input and output are unsigned. */
4696 && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
4697 && !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
4698 && 0 != compare_tree_int (TYPE_RM_SIZE (type),
4699 GET_MODE_BITSIZE (TYPE_MODE (type)))
4700 && !(INTEGRAL_TYPE_P (etype)
4701 && TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype)
4702 && operand_equal_p (TYPE_RM_SIZE (type),
4703 (TYPE_RM_SIZE (etype) != 0
4704 ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)),
4706 && !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype)))
4709 = gnat_type_for_mode (TYPE_MODE (type), TYPE_UNSIGNED (type));
4711 = convert (base_type,
4712 size_binop (MINUS_EXPR,
4714 (GET_MODE_BITSIZE (TYPE_MODE (type))),
4715 TYPE_RM_SIZE (type)));
4718 build_binary_op (RSHIFT_EXPR, base_type,
4719 build_binary_op (LSHIFT_EXPR, base_type,
4720 convert (base_type, expr),
4725 /* An unchecked conversion should never raise Constraint_Error. The code
4726 below assumes that GCC's conversion routines overflow the same way that
4727 the underlying hardware does. This is probably true. In the rare case
4728 when it is false, we can rely on the fact that such conversions are
4729 erroneous anyway. */
4730 if (TREE_CODE (expr) == INTEGER_CST)
4731 TREE_OVERFLOW (expr) = 0;
4733 /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
4734 show no longer constant. */
4735 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
4736 && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype),
4738 TREE_CONSTANT (expr) = 0;
4743 /* Return the appropriate GCC tree code for the specified GNAT_TYPE,
4744 the latter being a record type as predicated by Is_Record_Type. */
4747 tree_code_for_record_type (Entity_Id gnat_type)
4749 Node_Id component_list, component;
4751 /* Return UNION_TYPE if it's an Unchecked_Union whose non-discriminant
4752 fields are all in the variant part. Otherwise, return RECORD_TYPE. */
4753 if (!Is_Unchecked_Union (gnat_type))
4756 gnat_type = Implementation_Base_Type (gnat_type);
4758 = Component_List (Type_Definition (Declaration_Node (gnat_type)));
4760 for (component = First_Non_Pragma (Component_Items (component_list));
4761 Present (component);
4762 component = Next_Non_Pragma (component))
4763 if (Ekind (Defining_Entity (component)) == E_Component)
4769 /* Return true if GNAT_TYPE is a "double" floating-point type, i.e. whose
4770 size is equal to 64 bits, or an array of such a type. Set ALIGN_CLAUSE
4771 according to the presence of an alignment clause on the type or, if it
4772 is an array, on the component type. */
4775 is_double_float_or_array (Entity_Id gnat_type, bool *align_clause)
4777 gnat_type = Underlying_Type (gnat_type);
4779 *align_clause = Present (Alignment_Clause (gnat_type));
4781 if (Is_Array_Type (gnat_type))
4783 gnat_type = Underlying_Type (Component_Type (gnat_type));
4784 if (Present (Alignment_Clause (gnat_type)))
4785 *align_clause = true;
4788 if (!Is_Floating_Point_Type (gnat_type))
4791 if (UI_To_Int (Esize (gnat_type)) != 64)
4797 /* Return true if GNAT_TYPE is a "double" or larger scalar type, i.e. whose
4798 size is greater or equal to 64 bits, or an array of such a type. Set
4799 ALIGN_CLAUSE according to the presence of an alignment clause on the
4800 type or, if it is an array, on the component type. */
4803 is_double_scalar_or_array (Entity_Id gnat_type, bool *align_clause)
4805 gnat_type = Underlying_Type (gnat_type);
4807 *align_clause = Present (Alignment_Clause (gnat_type));
4809 if (Is_Array_Type (gnat_type))
4811 gnat_type = Underlying_Type (Component_Type (gnat_type));
4812 if (Present (Alignment_Clause (gnat_type)))
4813 *align_clause = true;
4816 if (!Is_Scalar_Type (gnat_type))
4819 if (UI_To_Int (Esize (gnat_type)) < 64)
4825 /* Return true if GNU_TYPE is suitable as the type of a non-aliased
4826 component of an aggregate type. */
4829 type_for_nonaliased_component_p (tree gnu_type)
4831 /* If the type is passed by reference, we may have pointers to the
4832 component so it cannot be made non-aliased. */
4833 if (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type))
4836 /* We used to say that any component of aggregate type is aliased
4837 because the front-end may take 'Reference of it. The front-end
4838 has been enhanced in the meantime so as to use a renaming instead
4839 in most cases, but the back-end can probably take the address of
4840 such a component too so we go for the conservative stance.
4842 For instance, we might need the address of any array type, even
4843 if normally passed by copy, to construct a fat pointer if the
4844 component is used as an actual for an unconstrained formal.
4846 Likewise for record types: even if a specific record subtype is
4847 passed by copy, the parent type might be passed by ref (e.g. if
4848 it's of variable size) and we might take the address of a child
4849 component to pass to a parent formal. We have no way to check
4850 for such conditions here. */
4851 if (AGGREGATE_TYPE_P (gnu_type))
4857 /* Return true if TYPE is a smaller form of ORIG_TYPE. */
4860 smaller_form_type_p (tree type, tree orig_type)
4864 /* We're not interested in variants here. */
4865 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (orig_type))
4868 /* Like a variant, a packable version keeps the original TYPE_NAME. */
4869 if (TYPE_NAME (type) != TYPE_NAME (orig_type))
4872 size = TYPE_SIZE (type);
4873 osize = TYPE_SIZE (orig_type);
4875 if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (osize) == INTEGER_CST))
4878 return tree_int_cst_lt (size, osize) != 0;
4881 /* Perform final processing on global variables. */
4883 static GTY (()) tree dummy_global;
4886 gnat_write_global_declarations (void)
4891 /* If we have declared types as used at the global level, insert them in
4892 the global hash table. We use a dummy variable for this purpose. */
4893 if (!VEC_empty (tree, types_used_by_cur_var_decl))
4896 = build_decl (BUILTINS_LOCATION, VAR_DECL, NULL_TREE, void_type_node);
4897 TREE_STATIC (dummy_global) = 1;
4898 TREE_ASM_WRITTEN (dummy_global) = 1;
4899 varpool_mark_needed_node (varpool_node (dummy_global));
4901 while (!VEC_empty (tree, types_used_by_cur_var_decl))
4903 tree t = VEC_pop (tree, types_used_by_cur_var_decl);
4904 types_used_by_var_decl_insert (t, dummy_global);
4908 /* Output debug information for all global type declarations first. This
4909 ensures that global types whose compilation hasn't been finalized yet,
4910 for example pointers to Taft amendment types, have their compilation
4911 finalized in the right context. */
4912 FOR_EACH_VEC_ELT (tree, global_decls, i, iter)
4913 if (TREE_CODE (iter) == TYPE_DECL)
4914 debug_hooks->global_decl (iter);
4916 /* Proceed to optimize and emit assembly.
4917 FIXME: shouldn't be the front end's responsibility to call this. */
4918 cgraph_finalize_compilation_unit ();
4920 /* After cgraph has had a chance to emit everything that's going to
4921 be emitted, output debug information for the rest of globals. */
4924 timevar_push (TV_SYMOUT);
4925 FOR_EACH_VEC_ELT (tree, global_decls, i, iter)
4926 if (TREE_CODE (iter) != TYPE_DECL)
4927 debug_hooks->global_decl (iter);
4928 timevar_pop (TV_SYMOUT);
4932 /* ************************************************************************
4933 * * GCC builtins support *
4934 * ************************************************************************ */
4936 /* The general scheme is fairly simple:
4938 For each builtin function/type to be declared, gnat_install_builtins calls
4939 internal facilities which eventually get to gnat_push_decl, which in turn
4940 tracks the so declared builtin function decls in the 'builtin_decls' global
4941 datastructure. When an Intrinsic subprogram declaration is processed, we
4942 search this global datastructure to retrieve the associated BUILT_IN DECL
4945 /* Search the chain of currently available builtin declarations for a node
4946 corresponding to function NAME (an IDENTIFIER_NODE). Return the first node
4947 found, if any, or NULL_TREE otherwise. */
4949 builtin_decl_for (tree name)
4954 FOR_EACH_VEC_ELT (tree, builtin_decls, i, decl)
4955 if (DECL_NAME (decl) == name)
4961 /* The code below eventually exposes gnat_install_builtins, which declares
4962 the builtin types and functions we might need, either internally or as
4963 user accessible facilities.
4965 ??? This is a first implementation shot, still in rough shape. It is
4966 heavily inspired from the "C" family implementation, with chunks copied
4967 verbatim from there.
4969 Two obvious TODO candidates are
4970 o Use a more efficient name/decl mapping scheme
4971 o Devise a middle-end infrastructure to avoid having to copy
4972 pieces between front-ends. */
4974 /* ----------------------------------------------------------------------- *
4975 * BUILTIN ELEMENTARY TYPES *
4976 * ----------------------------------------------------------------------- */
4978 /* Standard data types to be used in builtin argument declarations. */
4982 CTI_SIGNED_SIZE_TYPE, /* For format checking only. */
4984 CTI_CONST_STRING_TYPE,
4989 static tree c_global_trees[CTI_MAX];
4991 #define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE]
4992 #define string_type_node c_global_trees[CTI_STRING_TYPE]
4993 #define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE]
4995 /* ??? In addition some attribute handlers, we currently don't support a
4996 (small) number of builtin-types, which in turns inhibits support for a
4997 number of builtin functions. */
4998 #define wint_type_node void_type_node
4999 #define intmax_type_node void_type_node
5000 #define uintmax_type_node void_type_node
5002 /* Build the void_list_node (void_type_node having been created). */
5005 build_void_list_node (void)
5007 tree t = build_tree_list (NULL_TREE, void_type_node);
5011 /* Used to help initialize the builtin-types.def table. When a type of
5012 the correct size doesn't exist, use error_mark_node instead of NULL.
5013 The later results in segfaults even when a decl using the type doesn't
5017 builtin_type_for_size (int size, bool unsignedp)
5019 tree type = gnat_type_for_size (size, unsignedp);
5020 return type ? type : error_mark_node;
5023 /* Build/push the elementary type decls that builtin functions/types
5027 install_builtin_elementary_types (void)
5029 signed_size_type_node = gnat_signed_type (size_type_node);
5030 pid_type_node = integer_type_node;
5031 void_list_node = build_void_list_node ();
5033 string_type_node = build_pointer_type (char_type_node);
5034 const_string_type_node
5035 = build_pointer_type (build_qualified_type
5036 (char_type_node, TYPE_QUAL_CONST));
5039 /* ----------------------------------------------------------------------- *
5040 * BUILTIN FUNCTION TYPES *
5041 * ----------------------------------------------------------------------- */
5043 /* Now, builtin function types per se. */
5047 #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
5048 #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
5049 #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
5050 #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
5051 #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
5052 #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
5053 #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
5054 #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME,
5055 #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME,
5056 #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
5057 #define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME,
5058 #define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME,
5059 #define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
5060 #define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
5061 #define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG6) \
5063 #define DEF_POINTER_TYPE(NAME, TYPE) NAME,
5064 #include "builtin-types.def"
5065 #undef DEF_PRIMITIVE_TYPE
5066 #undef DEF_FUNCTION_TYPE_0
5067 #undef DEF_FUNCTION_TYPE_1
5068 #undef DEF_FUNCTION_TYPE_2
5069 #undef DEF_FUNCTION_TYPE_3
5070 #undef DEF_FUNCTION_TYPE_4
5071 #undef DEF_FUNCTION_TYPE_5
5072 #undef DEF_FUNCTION_TYPE_6
5073 #undef DEF_FUNCTION_TYPE_7
5074 #undef DEF_FUNCTION_TYPE_VAR_0
5075 #undef DEF_FUNCTION_TYPE_VAR_1
5076 #undef DEF_FUNCTION_TYPE_VAR_2
5077 #undef DEF_FUNCTION_TYPE_VAR_3
5078 #undef DEF_FUNCTION_TYPE_VAR_4
5079 #undef DEF_FUNCTION_TYPE_VAR_5
5080 #undef DEF_POINTER_TYPE
5084 typedef enum c_builtin_type builtin_type;
5086 /* A temporary array used in communication with def_fn_type. */
5087 static GTY(()) tree builtin_types[(int) BT_LAST + 1];
5089 /* A helper function for install_builtin_types. Build function type
5090 for DEF with return type RET and N arguments. If VAR is true, then the
5091 function should be variadic after those N arguments.
5093 Takes special care not to ICE if any of the types involved are
5094 error_mark_node, which indicates that said type is not in fact available
5095 (see builtin_type_for_size). In which case the function type as a whole
5096 should be error_mark_node. */
5099 def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...)
5102 tree *args = XALLOCAVEC (tree, n);
5107 for (i = 0; i < n; ++i)
5109 builtin_type a = (builtin_type) va_arg (list, int);
5110 t = builtin_types[a];
5111 if (t == error_mark_node)
5116 t = builtin_types[ret];
5117 if (t == error_mark_node)
5120 t = build_varargs_function_type_array (t, n, args);
5122 t = build_function_type_array (t, n, args);
5125 builtin_types[def] = t;
5129 /* Build the builtin function types and install them in the builtin_types
5130 array for later use in builtin function decls. */
5133 install_builtin_function_types (void)
5135 tree va_list_ref_type_node;
5136 tree va_list_arg_type_node;
5138 if (TREE_CODE (va_list_type_node) == ARRAY_TYPE)
5140 va_list_arg_type_node = va_list_ref_type_node =
5141 build_pointer_type (TREE_TYPE (va_list_type_node));
5145 va_list_arg_type_node = va_list_type_node;
5146 va_list_ref_type_node = build_reference_type (va_list_type_node);
5149 #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
5150 builtin_types[ENUM] = VALUE;
5151 #define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \
5152 def_fn_type (ENUM, RETURN, 0, 0);
5153 #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \
5154 def_fn_type (ENUM, RETURN, 0, 1, ARG1);
5155 #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \
5156 def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2);
5157 #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
5158 def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3);
5159 #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
5160 def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4);
5161 #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5162 def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
5163 #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5165 def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6);
5166 #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5168 def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7);
5169 #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \
5170 def_fn_type (ENUM, RETURN, 1, 0);
5171 #define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \
5172 def_fn_type (ENUM, RETURN, 1, 1, ARG1);
5173 #define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \
5174 def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2);
5175 #define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
5176 def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3);
5177 #define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
5178 def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4);
5179 #define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5180 def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
5181 #define DEF_POINTER_TYPE(ENUM, TYPE) \
5182 builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]);
5184 #include "builtin-types.def"
5186 #undef DEF_PRIMITIVE_TYPE
5187 #undef DEF_FUNCTION_TYPE_1
5188 #undef DEF_FUNCTION_TYPE_2
5189 #undef DEF_FUNCTION_TYPE_3
5190 #undef DEF_FUNCTION_TYPE_4
5191 #undef DEF_FUNCTION_TYPE_5
5192 #undef DEF_FUNCTION_TYPE_6
5193 #undef DEF_FUNCTION_TYPE_VAR_0
5194 #undef DEF_FUNCTION_TYPE_VAR_1
5195 #undef DEF_FUNCTION_TYPE_VAR_2
5196 #undef DEF_FUNCTION_TYPE_VAR_3
5197 #undef DEF_FUNCTION_TYPE_VAR_4
5198 #undef DEF_FUNCTION_TYPE_VAR_5
5199 #undef DEF_POINTER_TYPE
5200 builtin_types[(int) BT_LAST] = NULL_TREE;
5203 /* ----------------------------------------------------------------------- *
5204 * BUILTIN ATTRIBUTES *
5205 * ----------------------------------------------------------------------- */
5207 enum built_in_attribute
5209 #define DEF_ATTR_NULL_TREE(ENUM) ENUM,
5210 #define DEF_ATTR_INT(ENUM, VALUE) ENUM,
5211 #define DEF_ATTR_IDENT(ENUM, STRING) ENUM,
5212 #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM,
5213 #include "builtin-attrs.def"
5214 #undef DEF_ATTR_NULL_TREE
5216 #undef DEF_ATTR_IDENT
5217 #undef DEF_ATTR_TREE_LIST
5221 static GTY(()) tree built_in_attributes[(int) ATTR_LAST];
5224 install_builtin_attributes (void)
5226 /* Fill in the built_in_attributes array. */
5227 #define DEF_ATTR_NULL_TREE(ENUM) \
5228 built_in_attributes[(int) ENUM] = NULL_TREE;
5229 #define DEF_ATTR_INT(ENUM, VALUE) \
5230 built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE);
5231 #define DEF_ATTR_IDENT(ENUM, STRING) \
5232 built_in_attributes[(int) ENUM] = get_identifier (STRING);
5233 #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \
5234 built_in_attributes[(int) ENUM] \
5235 = tree_cons (built_in_attributes[(int) PURPOSE], \
5236 built_in_attributes[(int) VALUE], \
5237 built_in_attributes[(int) CHAIN]);
5238 #include "builtin-attrs.def"
5239 #undef DEF_ATTR_NULL_TREE
5241 #undef DEF_ATTR_IDENT
5242 #undef DEF_ATTR_TREE_LIST
5245 /* Handle a "const" attribute; arguments as in
5246 struct attribute_spec.handler. */
5249 handle_const_attribute (tree *node, tree ARG_UNUSED (name),
5250 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5253 if (TREE_CODE (*node) == FUNCTION_DECL)
5254 TREE_READONLY (*node) = 1;
5256 *no_add_attrs = true;
5261 /* Handle a "nothrow" attribute; arguments as in
5262 struct attribute_spec.handler. */
5265 handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name),
5266 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5269 if (TREE_CODE (*node) == FUNCTION_DECL)
5270 TREE_NOTHROW (*node) = 1;
5272 *no_add_attrs = true;
5277 /* Handle a "pure" attribute; arguments as in
5278 struct attribute_spec.handler. */
5281 handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args),
5282 int ARG_UNUSED (flags), bool *no_add_attrs)
5284 if (TREE_CODE (*node) == FUNCTION_DECL)
5285 DECL_PURE_P (*node) = 1;
5286 /* ??? TODO: Support types. */
5289 warning (OPT_Wattributes, "%qs attribute ignored",
5290 IDENTIFIER_POINTER (name));
5291 *no_add_attrs = true;
5297 /* Handle a "no vops" attribute; arguments as in
5298 struct attribute_spec.handler. */
5301 handle_novops_attribute (tree *node, tree ARG_UNUSED (name),
5302 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5303 bool *ARG_UNUSED (no_add_attrs))
5305 gcc_assert (TREE_CODE (*node) == FUNCTION_DECL);
5306 DECL_IS_NOVOPS (*node) = 1;
5310 /* Helper for nonnull attribute handling; fetch the operand number
5311 from the attribute argument list. */
5314 get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp)
5316 /* Verify the arg number is a constant. */
5317 if (TREE_CODE (arg_num_expr) != INTEGER_CST
5318 || TREE_INT_CST_HIGH (arg_num_expr) != 0)
5321 *valp = TREE_INT_CST_LOW (arg_num_expr);
5325 /* Handle the "nonnull" attribute. */
5327 handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name),
5328 tree args, int ARG_UNUSED (flags),
5332 unsigned HOST_WIDE_INT attr_arg_num;
5334 /* If no arguments are specified, all pointer arguments should be
5335 non-null. Verify a full prototype is given so that the arguments
5336 will have the correct types when we actually check them later. */
5339 if (!prototype_p (type))
5341 error ("nonnull attribute without arguments on a non-prototype");
5342 *no_add_attrs = true;
5347 /* Argument list specified. Verify that each argument number references
5348 a pointer argument. */
5349 for (attr_arg_num = 1; args; args = TREE_CHAIN (args))
5351 unsigned HOST_WIDE_INT arg_num = 0, ck_num;
5353 if (!get_nonnull_operand (TREE_VALUE (args), &arg_num))
5355 error ("nonnull argument has invalid operand number (argument %lu)",
5356 (unsigned long) attr_arg_num);
5357 *no_add_attrs = true;
5361 if (prototype_p (type))
5363 function_args_iterator iter;
5366 function_args_iter_init (&iter, type);
5367 for (ck_num = 1; ; ck_num++, function_args_iter_next (&iter))
5369 argument = function_args_iter_cond (&iter);
5370 if (!argument || ck_num == arg_num)
5375 || TREE_CODE (argument) == VOID_TYPE)
5377 error ("nonnull argument with out-of-range operand number "
5378 "(argument %lu, operand %lu)",
5379 (unsigned long) attr_arg_num, (unsigned long) arg_num);
5380 *no_add_attrs = true;
5384 if (TREE_CODE (argument) != POINTER_TYPE)
5386 error ("nonnull argument references non-pointer operand "
5387 "(argument %lu, operand %lu)",
5388 (unsigned long) attr_arg_num, (unsigned long) arg_num);
5389 *no_add_attrs = true;
5398 /* Handle a "sentinel" attribute. */
5401 handle_sentinel_attribute (tree *node, tree name, tree args,
5402 int ARG_UNUSED (flags), bool *no_add_attrs)
5404 if (!prototype_p (*node))
5406 warning (OPT_Wattributes,
5407 "%qs attribute requires prototypes with named arguments",
5408 IDENTIFIER_POINTER (name));
5409 *no_add_attrs = true;
5413 if (!stdarg_p (*node))
5415 warning (OPT_Wattributes,
5416 "%qs attribute only applies to variadic functions",
5417 IDENTIFIER_POINTER (name));
5418 *no_add_attrs = true;
5424 tree position = TREE_VALUE (args);
5426 if (TREE_CODE (position) != INTEGER_CST)
5428 warning (0, "requested position is not an integer constant");
5429 *no_add_attrs = true;
5433 if (tree_int_cst_lt (position, integer_zero_node))
5435 warning (0, "requested position is less than zero");
5436 *no_add_attrs = true;
5444 /* Handle a "noreturn" attribute; arguments as in
5445 struct attribute_spec.handler. */
5448 handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args),
5449 int ARG_UNUSED (flags), bool *no_add_attrs)
5451 tree type = TREE_TYPE (*node);
5453 /* See FIXME comment in c_common_attribute_table. */
5454 if (TREE_CODE (*node) == FUNCTION_DECL)
5455 TREE_THIS_VOLATILE (*node) = 1;
5456 else if (TREE_CODE (type) == POINTER_TYPE
5457 && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
5459 = build_pointer_type
5460 (build_type_variant (TREE_TYPE (type),
5461 TYPE_READONLY (TREE_TYPE (type)), 1));
5464 warning (OPT_Wattributes, "%qs attribute ignored",
5465 IDENTIFIER_POINTER (name));
5466 *no_add_attrs = true;
5472 /* Handle a "leaf" attribute; arguments as in
5473 struct attribute_spec.handler. */
5476 handle_leaf_attribute (tree *node, tree name,
5477 tree ARG_UNUSED (args),
5478 int ARG_UNUSED (flags), bool *no_add_attrs)
5480 if (TREE_CODE (*node) != FUNCTION_DECL)
5482 warning (OPT_Wattributes, "%qE attribute ignored", name);
5483 *no_add_attrs = true;
5485 if (!TREE_PUBLIC (*node))
5487 warning (OPT_Wattributes, "%qE attribute has no effect", name);
5488 *no_add_attrs = true;
5494 /* Handle a "malloc" attribute; arguments as in
5495 struct attribute_spec.handler. */
5498 handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args),
5499 int ARG_UNUSED (flags), bool *no_add_attrs)
5501 if (TREE_CODE (*node) == FUNCTION_DECL
5502 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node))))
5503 DECL_IS_MALLOC (*node) = 1;
5506 warning (OPT_Wattributes, "%qs attribute ignored",
5507 IDENTIFIER_POINTER (name));
5508 *no_add_attrs = true;
5514 /* Fake handler for attributes we don't properly support. */
5517 fake_attribute_handler (tree * ARG_UNUSED (node),
5518 tree ARG_UNUSED (name),
5519 tree ARG_UNUSED (args),
5520 int ARG_UNUSED (flags),
5521 bool * ARG_UNUSED (no_add_attrs))
5526 /* Handle a "type_generic" attribute. */
5529 handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name),
5530 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5531 bool * ARG_UNUSED (no_add_attrs))
5533 /* Ensure we have a function type. */
5534 gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE);
5536 /* Ensure we have a variadic function. */
5537 gcc_assert (!prototype_p (*node) || stdarg_p (*node));
5542 /* Handle a "vector_size" attribute; arguments as in
5543 struct attribute_spec.handler. */
5546 handle_vector_size_attribute (tree *node, tree name, tree args,
5547 int ARG_UNUSED (flags),
5550 unsigned HOST_WIDE_INT vecsize, nunits;
5551 enum machine_mode orig_mode;
5552 tree type = *node, new_type, size;
5554 *no_add_attrs = true;
5556 size = TREE_VALUE (args);
5558 if (!host_integerp (size, 1))
5560 warning (OPT_Wattributes, "%qs attribute ignored",
5561 IDENTIFIER_POINTER (name));
5565 /* Get the vector size (in bytes). */
5566 vecsize = tree_low_cst (size, 1);
5568 /* We need to provide for vector pointers, vector arrays, and
5569 functions returning vectors. For example:
5571 __attribute__((vector_size(16))) short *foo;
5573 In this case, the mode is SI, but the type being modified is
5574 HI, so we need to look further. */
5576 while (POINTER_TYPE_P (type)
5577 || TREE_CODE (type) == FUNCTION_TYPE
5578 || TREE_CODE (type) == ARRAY_TYPE)
5579 type = TREE_TYPE (type);
5581 /* Get the mode of the type being modified. */
5582 orig_mode = TYPE_MODE (type);
5584 if ((!INTEGRAL_TYPE_P (type)
5585 && !SCALAR_FLOAT_TYPE_P (type)
5586 && !FIXED_POINT_TYPE_P (type))
5587 || (!SCALAR_FLOAT_MODE_P (orig_mode)
5588 && GET_MODE_CLASS (orig_mode) != MODE_INT
5589 && !ALL_SCALAR_FIXED_POINT_MODE_P (orig_mode))
5590 || !host_integerp (TYPE_SIZE_UNIT (type), 1)
5591 || TREE_CODE (type) == BOOLEAN_TYPE)
5593 error ("invalid vector type for attribute %qs",
5594 IDENTIFIER_POINTER (name));
5598 if (vecsize % tree_low_cst (TYPE_SIZE_UNIT (type), 1))
5600 error ("vector size not an integral multiple of component size");
5606 error ("zero vector size");
5610 /* Calculate how many units fit in the vector. */
5611 nunits = vecsize / tree_low_cst (TYPE_SIZE_UNIT (type), 1);
5612 if (nunits & (nunits - 1))
5614 error ("number of components of the vector not a power of two");
5618 new_type = build_vector_type (type, nunits);
5620 /* Build back pointers if needed. */
5621 *node = reconstruct_complex_type (*node, new_type);
5626 /* Handle a "vector_type" attribute; arguments as in
5627 struct attribute_spec.handler. */
5630 handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args),
5631 int ARG_UNUSED (flags),
5634 /* Vector representative type and size. */
5635 tree rep_type = *node;
5636 tree rep_size = TYPE_SIZE_UNIT (rep_type);
5639 /* Vector size in bytes and number of units. */
5640 unsigned HOST_WIDE_INT vec_bytes, vec_units;
5642 /* Vector element type and mode. */
5644 enum machine_mode elem_mode;
5646 *no_add_attrs = true;
5648 /* Get the representative array type, possibly nested within a
5649 padding record e.g. for alignment purposes. */
5651 if (TYPE_IS_PADDING_P (rep_type))
5652 rep_type = TREE_TYPE (TYPE_FIELDS (rep_type));
5654 if (TREE_CODE (rep_type) != ARRAY_TYPE)
5656 error ("attribute %qs applies to array types only",
5657 IDENTIFIER_POINTER (name));
5661 /* Silently punt on variable sizes. We can't make vector types for them,
5662 need to ignore them on front-end generated subtypes of unconstrained
5663 bases, and this attribute is for binding implementors, not end-users, so
5664 we should never get there from legitimate explicit uses. */
5666 if (!host_integerp (rep_size, 1))
5669 /* Get the element type/mode and check this is something we know
5670 how to make vectors of. */
5672 elem_type = TREE_TYPE (rep_type);
5673 elem_mode = TYPE_MODE (elem_type);
5675 if ((!INTEGRAL_TYPE_P (elem_type)
5676 && !SCALAR_FLOAT_TYPE_P (elem_type)
5677 && !FIXED_POINT_TYPE_P (elem_type))
5678 || (!SCALAR_FLOAT_MODE_P (elem_mode)
5679 && GET_MODE_CLASS (elem_mode) != MODE_INT
5680 && !ALL_SCALAR_FIXED_POINT_MODE_P (elem_mode))
5681 || !host_integerp (TYPE_SIZE_UNIT (elem_type), 1))
5683 error ("invalid element type for attribute %qs",
5684 IDENTIFIER_POINTER (name));
5688 /* Sanity check the vector size and element type consistency. */
5690 vec_bytes = tree_low_cst (rep_size, 1);
5692 if (vec_bytes % tree_low_cst (TYPE_SIZE_UNIT (elem_type), 1))
5694 error ("vector size not an integral multiple of component size");
5700 error ("zero vector size");
5704 vec_units = vec_bytes / tree_low_cst (TYPE_SIZE_UNIT (elem_type), 1);
5705 if (vec_units & (vec_units - 1))
5707 error ("number of components of the vector not a power of two");
5711 /* Build the vector type and replace. */
5713 *node = build_vector_type (elem_type, vec_units);
5714 rep_name = TYPE_NAME (rep_type);
5715 if (TREE_CODE (rep_name) == TYPE_DECL)
5716 rep_name = DECL_NAME (rep_name);
5717 TYPE_NAME (*node) = rep_name;
5718 TYPE_REPRESENTATIVE_ARRAY (*node) = rep_type;
5723 /* ----------------------------------------------------------------------- *
5724 * BUILTIN FUNCTIONS *
5725 * ----------------------------------------------------------------------- */
5727 /* Worker for DEF_BUILTIN. Possibly define a builtin function with one or two
5728 names. Does not declare a non-__builtin_ function if flag_no_builtin, or
5729 if nonansi_p and flag_no_nonansi_builtin. */
5732 def_builtin_1 (enum built_in_function fncode,
5734 enum built_in_class fnclass,
5735 tree fntype, tree libtype,
5736 bool both_p, bool fallback_p,
5737 bool nonansi_p ATTRIBUTE_UNUSED,
5738 tree fnattrs, bool implicit_p)
5741 const char *libname;
5743 /* Preserve an already installed decl. It most likely was setup in advance
5744 (e.g. as part of the internal builtins) for specific reasons. */
5745 if (builtin_decl_explicit (fncode) != NULL_TREE)
5748 gcc_assert ((!both_p && !fallback_p)
5749 || !strncmp (name, "__builtin_",
5750 strlen ("__builtin_")));
5752 libname = name + strlen ("__builtin_");
5753 decl = add_builtin_function (name, fntype, fncode, fnclass,
5754 (fallback_p ? libname : NULL),
5757 /* ??? This is normally further controlled by command-line options
5758 like -fno-builtin, but we don't have them for Ada. */
5759 add_builtin_function (libname, libtype, fncode, fnclass,
5762 set_builtin_decl (fncode, decl, implicit_p);
5765 static int flag_isoc94 = 0;
5766 static int flag_isoc99 = 0;
5768 /* Install what the common builtins.def offers. */
5771 install_builtin_functions (void)
5773 #define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \
5774 NONANSI_P, ATTRS, IMPLICIT, COND) \
5776 def_builtin_1 (ENUM, NAME, CLASS, \
5777 builtin_types[(int) TYPE], \
5778 builtin_types[(int) LIBTYPE], \
5779 BOTH_P, FALLBACK_P, NONANSI_P, \
5780 built_in_attributes[(int) ATTRS], IMPLICIT);
5781 #include "builtins.def"
5785 /* ----------------------------------------------------------------------- *
5786 * BUILTIN FUNCTIONS *
5787 * ----------------------------------------------------------------------- */
5789 /* Install the builtin functions we might need. */
5792 gnat_install_builtins (void)
5794 install_builtin_elementary_types ();
5795 install_builtin_function_types ();
5796 install_builtin_attributes ();
5798 /* Install builtins used by generic middle-end pieces first. Some of these
5799 know about internal specificities and control attributes accordingly, for
5800 instance __builtin_alloca vs no-throw and -fstack-check. We will ignore
5801 the generic definition from builtins.def. */
5802 build_common_builtin_nodes ();
5804 /* Now, install the target specific builtins, such as the AltiVec family on
5805 ppc, and the common set as exposed by builtins.def. */
5806 targetm.init_builtins ();
5807 install_builtin_functions ();
5810 #include "gt-ada-utils.h"
5811 #include "gtype-ada.h"