1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2011, 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 "langhooks.h"
41 #include "tree-dump.h"
42 #include "tree-inline.h"
43 #include "tree-iterator.h"
59 #ifndef MAX_BITS_PER_WORD
60 #define MAX_BITS_PER_WORD BITS_PER_WORD
63 /* If nonzero, pretend we are allocating at global level. */
66 /* The default alignment of "double" floating-point types, i.e. floating
67 point types whose size is equal to 64 bits, or 0 if this alignment is
68 not specifically capped. */
69 int double_float_alignment;
71 /* The default alignment of "double" or larger scalar types, i.e. scalar
72 types whose size is greater or equal to 64 bits, or 0 if this alignment
73 is not specifically capped. */
74 int double_scalar_alignment;
76 /* Tree nodes for the various types and decls we create. */
77 tree gnat_std_decls[(int) ADT_LAST];
79 /* Functions to call for each of the possible raise reasons. */
80 tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
82 /* Likewise, but with extra info for each of the possible raise reasons. */
83 tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1];
85 /* Forward declarations for handlers of attributes. */
86 static tree handle_const_attribute (tree *, tree, tree, int, bool *);
87 static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *);
88 static tree handle_pure_attribute (tree *, tree, tree, int, bool *);
89 static tree handle_novops_attribute (tree *, tree, tree, int, bool *);
90 static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *);
91 static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *);
92 static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *);
93 static tree handle_leaf_attribute (tree *, tree, tree, int, bool *);
94 static tree handle_malloc_attribute (tree *, tree, tree, int, bool *);
95 static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *);
96 static tree handle_vector_size_attribute (tree *, tree, tree, int, bool *);
97 static tree handle_vector_type_attribute (tree *, tree, tree, int, bool *);
99 /* Fake handler for attributes we don't properly support, typically because
100 they'd require dragging a lot of the common-c front-end circuitry. */
101 static tree fake_attribute_handler (tree *, tree, tree, int, bool *);
103 /* Table of machine-independent internal attributes for Ada. We support
104 this minimal set of attributes to accommodate the needs of builtins. */
105 const struct attribute_spec gnat_internal_attribute_table[] =
107 /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler,
108 affects_type_identity } */
109 { "const", 0, 0, true, false, false, handle_const_attribute,
111 { "nothrow", 0, 0, true, false, false, handle_nothrow_attribute,
113 { "pure", 0, 0, true, false, false, handle_pure_attribute,
115 { "no vops", 0, 0, true, false, false, handle_novops_attribute,
117 { "nonnull", 0, -1, false, true, true, handle_nonnull_attribute,
119 { "sentinel", 0, 1, false, true, true, handle_sentinel_attribute,
121 { "noreturn", 0, 0, true, false, false, handle_noreturn_attribute,
123 { "leaf", 0, 0, true, false, false, handle_leaf_attribute,
125 { "malloc", 0, 0, true, false, false, handle_malloc_attribute,
127 { "type generic", 0, 0, false, true, true, handle_type_generic_attribute,
130 { "vector_size", 1, 1, false, true, false, handle_vector_size_attribute,
132 { "vector_type", 0, 0, false, true, false, handle_vector_type_attribute,
134 { "may_alias", 0, 0, false, true, false, NULL, false },
136 /* ??? format and format_arg are heavy and not supported, which actually
137 prevents support for stdio builtins, which we however declare as part
138 of the common builtins.def contents. */
139 { "format", 3, 3, false, true, true, fake_attribute_handler, false },
140 { "format_arg", 1, 1, false, true, true, fake_attribute_handler, false },
142 { NULL, 0, 0, false, false, false, NULL, false }
145 /* Associates a GNAT tree node to a GCC tree node. It is used in
146 `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
147 of `save_gnu_tree' for more info. */
148 static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
150 #define GET_GNU_TREE(GNAT_ENTITY) \
151 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id]
153 #define SET_GNU_TREE(GNAT_ENTITY,VAL) \
154 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL)
156 #define PRESENT_GNU_TREE(GNAT_ENTITY) \
157 (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
159 /* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */
160 static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table;
162 #define GET_DUMMY_NODE(GNAT_ENTITY) \
163 dummy_node_table[(GNAT_ENTITY) - First_Node_Id]
165 #define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \
166 dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL)
168 #define PRESENT_DUMMY_NODE(GNAT_ENTITY) \
169 (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
171 /* This variable keeps a table for types for each precision so that we only
172 allocate each of them once. Signed and unsigned types are kept separate.
174 Note that these types are only used when fold-const requests something
175 special. Perhaps we should NOT share these types; we'll see how it
177 static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
179 /* Likewise for float types, but record these by mode. */
180 static GTY(()) tree float_types[NUM_MACHINE_MODES];
182 /* For each binding contour we allocate a binding_level structure to indicate
183 the binding depth. */
185 struct GTY((chain_next ("%h.chain"))) gnat_binding_level {
186 /* The binding level containing this one (the enclosing binding level). */
187 struct gnat_binding_level *chain;
188 /* The BLOCK node for this level. */
190 /* If nonzero, the setjmp buffer that needs to be updated for any
191 variable-sized definition within this context. */
195 /* The binding level currently in effect. */
196 static GTY(()) struct gnat_binding_level *current_binding_level;
198 /* A chain of gnat_binding_level structures awaiting reuse. */
199 static GTY((deletable)) struct gnat_binding_level *free_binding_level;
201 /* An array of global declarations. */
202 static GTY(()) VEC(tree,gc) *global_decls;
204 /* An array of builtin function declarations. */
205 static GTY(()) VEC(tree,gc) *builtin_decls;
207 /* An array of global renaming pointers. */
208 static GTY(()) VEC(tree,gc) *global_renaming_pointers;
210 /* A chain of unused BLOCK nodes. */
211 static GTY((deletable)) tree free_block_chain;
213 static tree merge_sizes (tree, tree, tree, bool, bool);
214 static tree compute_related_constant (tree, tree);
215 static tree split_plus (tree, tree *);
216 static tree float_type_for_precision (int, enum machine_mode);
217 static tree convert_to_fat_pointer (tree, tree);
218 static tree convert_to_thin_pointer (tree, tree);
219 static bool potential_alignment_gap (tree, tree, tree);
220 static void process_attributes (tree, struct attrib *);
222 /* Initialize the association of GNAT nodes to GCC trees. */
225 init_gnat_to_gnu (void)
227 associate_gnat_to_gnu = ggc_alloc_cleared_vec_tree (max_gnat_nodes);
230 /* GNAT_ENTITY is a GNAT tree node for an entity. Associate GNU_DECL, a GCC
231 tree node, with GNAT_ENTITY. If GNU_DECL is not a ..._DECL node, abort.
232 If NO_CHECK is true, the latter check is suppressed.
234 If GNU_DECL is zero, reset a previous association. */
237 save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check)
239 /* Check that GNAT_ENTITY is not already defined and that it is being set
240 to something which is a decl. If that is not the case, this usually
241 means GNAT_ENTITY is defined twice, but occasionally is due to some
243 gcc_assert (!(gnu_decl
244 && (PRESENT_GNU_TREE (gnat_entity)
245 || (!no_check && !DECL_P (gnu_decl)))));
247 SET_GNU_TREE (gnat_entity, gnu_decl);
250 /* GNAT_ENTITY is a GNAT tree node for an entity. Return the GCC tree node
251 that was associated with it. If there is no such tree node, abort.
253 In some cases, such as delayed elaboration or expressions that need to
254 be elaborated only once, GNAT_ENTITY is really not an entity. */
257 get_gnu_tree (Entity_Id gnat_entity)
259 gcc_assert (PRESENT_GNU_TREE (gnat_entity));
260 return GET_GNU_TREE (gnat_entity);
263 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
266 present_gnu_tree (Entity_Id gnat_entity)
268 return PRESENT_GNU_TREE (gnat_entity);
271 /* Initialize the association of GNAT nodes to GCC trees as dummies. */
274 init_dummy_type (void)
276 dummy_node_table = ggc_alloc_cleared_vec_tree (max_gnat_nodes);
279 /* Make a dummy type corresponding to GNAT_TYPE. */
282 make_dummy_type (Entity_Id gnat_type)
284 Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type);
287 /* If there is an equivalent type, get its underlying type. */
288 if (Present (gnat_underlying))
289 gnat_underlying = Underlying_Type (gnat_underlying);
291 /* If there was no equivalent type (can only happen when just annotating
292 types) or underlying type, go back to the original type. */
293 if (No (gnat_underlying))
294 gnat_underlying = gnat_type;
296 /* If it there already a dummy type, use that one. Else make one. */
297 if (PRESENT_DUMMY_NODE (gnat_underlying))
298 return GET_DUMMY_NODE (gnat_underlying);
300 /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make
302 gnu_type = make_node (Is_Record_Type (gnat_underlying)
303 ? tree_code_for_record_type (gnat_underlying)
305 TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
306 TYPE_DUMMY_P (gnu_type) = 1;
307 TYPE_STUB_DECL (gnu_type)
308 = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
309 if (Is_By_Reference_Type (gnat_type))
310 TREE_ADDRESSABLE (gnu_type) = 1;
312 SET_DUMMY_NODE (gnat_underlying, gnu_type);
317 /* Return the dummy type that was made for GNAT_TYPE, if any. */
320 get_dummy_type (Entity_Id gnat_type)
322 return GET_DUMMY_NODE (gnat_type);
325 /* Build dummy fat and thin pointer types whose designated type is specified
326 by GNAT_DESIG_TYPE/GNU_DESIG_TYPE and attach them to the latter. */
329 build_dummy_unc_pointer_types (Entity_Id gnat_desig_type, tree gnu_desig_type)
331 tree gnu_template_type, gnu_ptr_template, gnu_array_type, gnu_ptr_array;
332 tree gnu_fat_type, fields, gnu_object_type;
334 gnu_template_type = make_node (RECORD_TYPE);
335 TYPE_NAME (gnu_template_type) = create_concat_name (gnat_desig_type, "XUB");
336 TYPE_DUMMY_P (gnu_template_type) = 1;
337 gnu_ptr_template = build_pointer_type (gnu_template_type);
339 gnu_array_type = make_node (ENUMERAL_TYPE);
340 TYPE_NAME (gnu_array_type) = create_concat_name (gnat_desig_type, "XUA");
341 TYPE_DUMMY_P (gnu_array_type) = 1;
342 gnu_ptr_array = build_pointer_type (gnu_array_type);
344 gnu_fat_type = make_node (RECORD_TYPE);
345 /* Build a stub DECL to trigger the special processing for fat pointer types
347 TYPE_NAME (gnu_fat_type)
348 = create_type_stub_decl (create_concat_name (gnat_desig_type, "XUP"),
350 fields = create_field_decl (get_identifier ("P_ARRAY"), gnu_ptr_array,
351 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
353 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
354 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
355 finish_fat_pointer_type (gnu_fat_type, fields);
356 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_desig_type);
357 /* Suppress debug info until after the type is completed. */
358 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 1;
360 gnu_object_type = make_node (RECORD_TYPE);
361 TYPE_NAME (gnu_object_type) = create_concat_name (gnat_desig_type, "XUT");
362 TYPE_DUMMY_P (gnu_object_type) = 1;
364 TYPE_POINTER_TO (gnu_desig_type) = gnu_fat_type;
365 TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type;
368 /* Return nonzero if we are currently in the global binding level. */
371 global_bindings_p (void)
373 return ((force_global || !current_function_decl) ? -1 : 0);
376 /* Enter a new binding level. */
379 gnat_pushlevel (void)
381 struct gnat_binding_level *newlevel = NULL;
383 /* Reuse a struct for this binding level, if there is one. */
384 if (free_binding_level)
386 newlevel = free_binding_level;
387 free_binding_level = free_binding_level->chain;
390 newlevel = ggc_alloc_gnat_binding_level ();
392 /* Use a free BLOCK, if any; otherwise, allocate one. */
393 if (free_block_chain)
395 newlevel->block = free_block_chain;
396 free_block_chain = BLOCK_CHAIN (free_block_chain);
397 BLOCK_CHAIN (newlevel->block) = NULL_TREE;
400 newlevel->block = make_node (BLOCK);
402 /* Point the BLOCK we just made to its parent. */
403 if (current_binding_level)
404 BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
406 BLOCK_VARS (newlevel->block) = NULL_TREE;
407 BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
408 TREE_USED (newlevel->block) = 1;
410 /* Add this level to the front of the chain (stack) of active levels. */
411 newlevel->chain = current_binding_level;
412 newlevel->jmpbuf_decl = NULL_TREE;
413 current_binding_level = newlevel;
416 /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
417 and point FNDECL to this BLOCK. */
420 set_current_block_context (tree fndecl)
422 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
423 DECL_INITIAL (fndecl) = current_binding_level->block;
424 set_block_for_group (current_binding_level->block);
427 /* Set the jmpbuf_decl for the current binding level to DECL. */
430 set_block_jmpbuf_decl (tree decl)
432 current_binding_level->jmpbuf_decl = decl;
435 /* Get the jmpbuf_decl, if any, for the current binding level. */
438 get_block_jmpbuf_decl (void)
440 return current_binding_level->jmpbuf_decl;
443 /* Exit a binding level. Set any BLOCK into the current code group. */
448 struct gnat_binding_level *level = current_binding_level;
449 tree block = level->block;
451 BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
452 BLOCK_SUBBLOCKS (block) = blocks_nreverse (BLOCK_SUBBLOCKS (block));
454 /* If this is a function-level BLOCK don't do anything. Otherwise, if there
455 are no variables free the block and merge its subblocks into those of its
456 parent block. Otherwise, add it to the list of its parent. */
457 if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
459 else if (BLOCK_VARS (block) == NULL_TREE)
461 BLOCK_SUBBLOCKS (level->chain->block)
462 = block_chainon (BLOCK_SUBBLOCKS (block),
463 BLOCK_SUBBLOCKS (level->chain->block));
464 BLOCK_CHAIN (block) = free_block_chain;
465 free_block_chain = block;
469 BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block);
470 BLOCK_SUBBLOCKS (level->chain->block) = block;
471 TREE_USED (block) = 1;
472 set_block_for_group (block);
475 /* Free this binding structure. */
476 current_binding_level = level->chain;
477 level->chain = free_binding_level;
478 free_binding_level = level;
481 /* Exit a binding level and discard the associated BLOCK. */
486 struct gnat_binding_level *level = current_binding_level;
487 tree block = level->block;
489 BLOCK_CHAIN (block) = free_block_chain;
490 free_block_chain = block;
492 /* Free this binding structure. */
493 current_binding_level = level->chain;
494 level->chain = free_binding_level;
495 free_binding_level = level;
498 /* Records a ..._DECL node DECL as belonging to the current lexical scope
499 and uses GNAT_NODE for location information and propagating flags. */
502 gnat_pushdecl (tree decl, Node_Id gnat_node)
504 /* If this decl is public external or at toplevel, there is no context. */
505 if ((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || global_bindings_p ())
506 DECL_CONTEXT (decl) = 0;
509 DECL_CONTEXT (decl) = current_function_decl;
511 /* Functions imported in another function are not really nested.
512 For really nested functions mark them initially as needing
513 a static chain for uses of that flag before unnesting;
514 lower_nested_functions will then recompute it. */
515 if (TREE_CODE (decl) == FUNCTION_DECL && !TREE_PUBLIC (decl))
516 DECL_STATIC_CHAIN (decl) = 1;
519 TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node));
521 /* Set the location of DECL and emit a declaration for it. */
522 if (Present (gnat_node))
523 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl));
524 add_decl_expr (decl, gnat_node);
526 /* Put the declaration on the list. The list of declarations is in reverse
527 order. The list will be reversed later. Put global declarations in the
528 globals list and local ones in the current block. But skip TYPE_DECLs
529 for UNCONSTRAINED_ARRAY_TYPE in both cases, as they will cause trouble
530 with the debugger and aren't needed anyway. */
531 if (!(TREE_CODE (decl) == TYPE_DECL
532 && TREE_CODE (TREE_TYPE (decl)) == UNCONSTRAINED_ARRAY_TYPE))
534 if (global_bindings_p ())
536 VEC_safe_push (tree, gc, global_decls, decl);
538 if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl))
539 VEC_safe_push (tree, gc, builtin_decls, decl);
541 else if (!DECL_EXTERNAL (decl))
543 DECL_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
544 BLOCK_VARS (current_binding_level->block) = decl;
548 /* For the declaration of a type, set its name if it either is not already
549 set or if the previous type name was not derived from a source name.
550 We'd rather have the type named with a real name and all the pointer
551 types to the same object have the same POINTER_TYPE node. Code in the
552 equivalent function of c-decl.c makes a copy of the type node here, but
553 that may cause us trouble with incomplete types. We make an exception
554 for fat pointer types because the compiler automatically builds them
555 for unconstrained array types and the debugger uses them to represent
556 both these and pointers to these. */
557 if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl))
559 tree t = TREE_TYPE (decl);
561 if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
563 /* Array and pointer types aren't "tagged" types so we force the
564 type to be associated with its typedef in the DWARF back-end,
565 in order to make sure that the latter is always preserved. */
566 if (!DECL_ARTIFICIAL (decl)
567 && (TREE_CODE (t) == ARRAY_TYPE
568 || TREE_CODE (t) == POINTER_TYPE))
570 tree tt = build_distinct_type_copy (t);
571 if (TREE_CODE (t) == POINTER_TYPE)
572 TYPE_NEXT_PTR_TO (t) = tt;
573 TYPE_NAME (tt) = DECL_NAME (decl);
574 TYPE_STUB_DECL (tt) = TYPE_STUB_DECL (t);
575 DECL_ORIGINAL_TYPE (decl) = tt;
578 else if (TYPE_IS_FAT_POINTER_P (t))
580 /* We need a variant for the placeholder machinery to work. */
581 tree tt = build_variant_type_copy (t);
582 TYPE_NAME (tt) = decl;
583 TREE_USED (tt) = TREE_USED (t);
584 TREE_TYPE (decl) = tt;
585 if (DECL_ORIGINAL_TYPE (TYPE_NAME (t)))
586 DECL_ORIGINAL_TYPE (decl) = DECL_ORIGINAL_TYPE (TYPE_NAME (t));
588 DECL_ORIGINAL_TYPE (decl) = t;
589 DECL_ARTIFICIAL (decl) = 0;
592 else if (DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl))
597 /* Propagate the name to all the anonymous variants. This is needed
598 for the type qualifiers machinery to work properly. */
600 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
601 if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
602 TYPE_NAME (t) = decl;
606 /* Record TYPE as a builtin type for Ada. NAME is the name of the type.
607 ARTIFICIAL_P is true if it's a type that was generated by the compiler. */
610 record_builtin_type (const char *name, tree type, bool artificial_p)
612 tree type_decl = build_decl (input_location,
613 TYPE_DECL, get_identifier (name), type);
614 DECL_ARTIFICIAL (type_decl) = artificial_p;
615 gnat_pushdecl (type_decl, Empty);
617 if (debug_hooks->type_decl)
618 debug_hooks->type_decl (type_decl, false);
621 /* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
622 finish constructing the record type as a fat pointer type. */
625 finish_fat_pointer_type (tree record_type, tree field_list)
627 /* Make sure we can put it into a register. */
628 TYPE_ALIGN (record_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
630 /* Show what it really is. */
631 TYPE_FAT_POINTER_P (record_type) = 1;
633 /* Do not emit debug info for it since the types of its fields may still be
634 incomplete at this point. */
635 finish_record_type (record_type, field_list, 0, false);
637 /* Force type_contains_placeholder_p to return true on it. Although the
638 PLACEHOLDER_EXPRs are referenced only indirectly, this isn't a pointer
639 type but the representation of the unconstrained array. */
640 TYPE_CONTAINS_PLACEHOLDER_INTERNAL (record_type) = 2;
643 /* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
644 finish constructing the record or union type. If REP_LEVEL is zero, this
645 record has no representation clause and so will be entirely laid out here.
646 If REP_LEVEL is one, this record has a representation clause and has been
647 laid out already; only set the sizes and alignment. If REP_LEVEL is two,
648 this record is derived from a parent record and thus inherits its layout;
649 only make a pass on the fields to finalize them. DEBUG_INFO_P is true if
650 we need to write debug information about this type. */
653 finish_record_type (tree record_type, tree field_list, int rep_level,
656 enum tree_code code = TREE_CODE (record_type);
657 tree name = TYPE_NAME (record_type);
658 tree ada_size = bitsize_zero_node;
659 tree size = bitsize_zero_node;
660 bool had_size = TYPE_SIZE (record_type) != 0;
661 bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0;
662 bool had_align = TYPE_ALIGN (record_type) != 0;
665 TYPE_FIELDS (record_type) = field_list;
667 /* Always attach the TYPE_STUB_DECL for a record type. It is required to
668 generate debug info and have a parallel type. */
669 if (name && TREE_CODE (name) == TYPE_DECL)
670 name = DECL_NAME (name);
671 TYPE_STUB_DECL (record_type) = create_type_stub_decl (name, record_type);
673 /* Globally initialize the record first. If this is a rep'ed record,
674 that just means some initializations; otherwise, layout the record. */
677 TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
680 TYPE_SIZE_UNIT (record_type) = size_zero_node;
683 TYPE_SIZE (record_type) = bitsize_zero_node;
685 /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
686 out just like a UNION_TYPE, since the size will be fixed. */
687 else if (code == QUAL_UNION_TYPE)
692 /* Ensure there isn't a size already set. There can be in an error
693 case where there is a rep clause but all fields have errors and
694 no longer have a position. */
695 TYPE_SIZE (record_type) = 0;
696 layout_type (record_type);
699 /* At this point, the position and size of each field is known. It was
700 either set before entry by a rep clause, or by laying out the type above.
702 We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs)
703 to compute the Ada size; the GCC size and alignment (for rep'ed records
704 that are not padding types); and the mode (for rep'ed records). We also
705 clear the DECL_BIT_FIELD indication for the cases we know have not been
706 handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */
708 if (code == QUAL_UNION_TYPE)
709 field_list = nreverse (field_list);
711 for (field = field_list; field; field = DECL_CHAIN (field))
713 tree type = TREE_TYPE (field);
714 tree pos = bit_position (field);
715 tree this_size = DECL_SIZE (field);
718 if ((TREE_CODE (type) == RECORD_TYPE
719 || TREE_CODE (type) == UNION_TYPE
720 || TREE_CODE (type) == QUAL_UNION_TYPE)
721 && !TYPE_FAT_POINTER_P (type)
722 && !TYPE_CONTAINS_TEMPLATE_P (type)
723 && TYPE_ADA_SIZE (type))
724 this_ada_size = TYPE_ADA_SIZE (type);
726 this_ada_size = this_size;
728 /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */
729 if (DECL_BIT_FIELD (field)
730 && operand_equal_p (this_size, TYPE_SIZE (type), 0))
732 unsigned int align = TYPE_ALIGN (type);
734 /* In the general case, type alignment is required. */
735 if (value_factor_p (pos, align))
737 /* The enclosing record type must be sufficiently aligned.
738 Otherwise, if no alignment was specified for it and it
739 has been laid out already, bump its alignment to the
740 desired one if this is compatible with its size. */
741 if (TYPE_ALIGN (record_type) >= align)
743 DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
744 DECL_BIT_FIELD (field) = 0;
748 && value_factor_p (TYPE_SIZE (record_type), align))
750 TYPE_ALIGN (record_type) = align;
751 DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
752 DECL_BIT_FIELD (field) = 0;
756 /* In the non-strict alignment case, only byte alignment is. */
757 if (!STRICT_ALIGNMENT
758 && DECL_BIT_FIELD (field)
759 && value_factor_p (pos, BITS_PER_UNIT))
760 DECL_BIT_FIELD (field) = 0;
763 /* If we still have DECL_BIT_FIELD set at this point, we know that the
764 field is technically not addressable. Except that it can actually
765 be addressed if it is BLKmode and happens to be properly aligned. */
766 if (DECL_BIT_FIELD (field)
767 && !(DECL_MODE (field) == BLKmode
768 && value_factor_p (pos, BITS_PER_UNIT)))
769 DECL_NONADDRESSABLE_P (field) = 1;
771 /* A type must be as aligned as its most aligned field that is not
772 a bit-field. But this is already enforced by layout_type. */
773 if (rep_level > 0 && !DECL_BIT_FIELD (field))
774 TYPE_ALIGN (record_type)
775 = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
780 ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size);
781 size = size_binop (MAX_EXPR, size, this_size);
784 case QUAL_UNION_TYPE:
786 = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
787 this_ada_size, ada_size);
788 size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
793 /* Since we know here that all fields are sorted in order of
794 increasing bit position, the size of the record is one
795 higher than the ending bit of the last field processed
796 unless we have a rep clause, since in that case we might
797 have a field outside a QUAL_UNION_TYPE that has a higher ending
798 position. So use a MAX in that case. Also, if this field is a
799 QUAL_UNION_TYPE, we need to take into account the previous size in
800 the case of empty variants. */
802 = merge_sizes (ada_size, pos, this_ada_size,
803 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
805 = merge_sizes (size, pos, this_size,
806 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
814 if (code == QUAL_UNION_TYPE)
815 nreverse (field_list);
819 /* If this is a padding record, we never want to make the size smaller
820 than what was specified in it, if any. */
821 if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
822 size = TYPE_SIZE (record_type);
824 /* Now set any of the values we've just computed that apply. */
825 if (!TYPE_FAT_POINTER_P (record_type)
826 && !TYPE_CONTAINS_TEMPLATE_P (record_type))
827 SET_TYPE_ADA_SIZE (record_type, ada_size);
831 tree size_unit = had_size_unit
832 ? TYPE_SIZE_UNIT (record_type)
834 size_binop (CEIL_DIV_EXPR, size,
836 unsigned int align = TYPE_ALIGN (record_type);
838 TYPE_SIZE (record_type) = variable_size (round_up (size, align));
839 TYPE_SIZE_UNIT (record_type)
840 = variable_size (round_up (size_unit, align / BITS_PER_UNIT));
842 compute_record_mode (record_type);
847 rest_of_record_type_compilation (record_type);
850 /* Wrap up compilation of RECORD_TYPE, i.e. output all the debug information
851 associated with it. It need not be invoked directly in most cases since
852 finish_record_type takes care of doing so, but this can be necessary if
853 a parallel type is to be attached to the record type. */
856 rest_of_record_type_compilation (tree record_type)
858 tree field_list = TYPE_FIELDS (record_type);
860 enum tree_code code = TREE_CODE (record_type);
861 bool var_size = false;
863 for (field = field_list; field; field = DECL_CHAIN (field))
865 /* We need to make an XVE/XVU record if any field has variable size,
866 whether or not the record does. For example, if we have a union,
867 it may be that all fields, rounded up to the alignment, have the
868 same size, in which case we'll use that size. But the debug
869 output routines (except Dwarf2) won't be able to output the fields,
870 so we need to make the special record. */
871 if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST
872 /* If a field has a non-constant qualifier, the record will have
873 variable size too. */
874 || (code == QUAL_UNION_TYPE
875 && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST))
882 /* If this record is of variable size, rename it so that the
883 debugger knows it is and make a new, parallel, record
884 that tells the debugger how the record is laid out. See
885 exp_dbug.ads. But don't do this for records that are padding
886 since they confuse GDB. */
887 if (var_size && !TYPE_IS_PADDING_P (record_type))
890 = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
891 ? UNION_TYPE : TREE_CODE (record_type));
892 tree orig_name = TYPE_NAME (record_type), new_name;
893 tree last_pos = bitsize_zero_node;
894 tree old_field, prev_old_field = NULL_TREE;
896 if (TREE_CODE (orig_name) == TYPE_DECL)
897 orig_name = DECL_NAME (orig_name);
900 = concat_name (orig_name, TREE_CODE (record_type) == QUAL_UNION_TYPE
902 TYPE_NAME (new_record_type) = new_name;
903 TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
904 TYPE_STUB_DECL (new_record_type)
905 = create_type_stub_decl (new_name, new_record_type);
906 DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
907 = DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
908 TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
909 TYPE_SIZE_UNIT (new_record_type)
910 = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT);
912 add_parallel_type (TYPE_STUB_DECL (record_type), new_record_type);
914 /* Now scan all the fields, replacing each field with a new
915 field corresponding to the new encoding. */
916 for (old_field = TYPE_FIELDS (record_type); old_field;
917 old_field = DECL_CHAIN (old_field))
919 tree field_type = TREE_TYPE (old_field);
920 tree field_name = DECL_NAME (old_field);
922 tree curpos = bit_position (old_field);
924 unsigned int align = 0;
927 /* See how the position was modified from the last position.
929 There are two basic cases we support: a value was added
930 to the last position or the last position was rounded to
931 a boundary and they something was added. Check for the
932 first case first. If not, see if there is any evidence
933 of rounding. If so, round the last position and try
936 If this is a union, the position can be taken as zero. */
938 /* Some computations depend on the shape of the position expression,
939 so strip conversions to make sure it's exposed. */
940 curpos = remove_conversions (curpos, true);
942 if (TREE_CODE (new_record_type) == UNION_TYPE)
943 pos = bitsize_zero_node, align = 0;
945 pos = compute_related_constant (curpos, last_pos);
947 if (!pos && TREE_CODE (curpos) == MULT_EXPR
948 && host_integerp (TREE_OPERAND (curpos, 1), 1))
950 tree offset = TREE_OPERAND (curpos, 0);
951 align = tree_low_cst (TREE_OPERAND (curpos, 1), 1);
953 /* An offset which is a bitwise AND with a negative power of 2
954 means an alignment corresponding to this power of 2. Note
955 that, as sizetype is sign-extended but nonetheless unsigned,
956 we don't directly use tree_int_cst_sgn. */
957 offset = remove_conversions (offset, true);
958 if (TREE_CODE (offset) == BIT_AND_EXPR
959 && host_integerp (TREE_OPERAND (offset, 1), 0)
960 && TREE_INT_CST_HIGH (TREE_OPERAND (offset, 1)) < 0)
963 = - tree_low_cst (TREE_OPERAND (offset, 1), 0);
964 if (exact_log2 (pow) > 0)
968 pos = compute_related_constant (curpos,
969 round_up (last_pos, align));
971 else if (!pos && TREE_CODE (curpos) == PLUS_EXPR
972 && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST
973 && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR
974 && host_integerp (TREE_OPERAND
975 (TREE_OPERAND (curpos, 0), 1),
980 (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1);
981 pos = compute_related_constant (curpos,
982 round_up (last_pos, align));
984 else if (potential_alignment_gap (prev_old_field, old_field,
987 align = TYPE_ALIGN (field_type);
988 pos = compute_related_constant (curpos,
989 round_up (last_pos, align));
992 /* If we can't compute a position, set it to zero.
994 ??? We really should abort here, but it's too much work
995 to get this correct for all cases. */
998 pos = bitsize_zero_node;
1000 /* See if this type is variable-sized and make a pointer type
1001 and indicate the indirection if so. Beware that the debug
1002 back-end may adjust the position computed above according
1003 to the alignment of the field type, i.e. the pointer type
1004 in this case, if we don't preventively counter that. */
1005 if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
1007 field_type = build_pointer_type (field_type);
1008 if (align != 0 && TYPE_ALIGN (field_type) > align)
1010 field_type = copy_node (field_type);
1011 TYPE_ALIGN (field_type) = align;
1016 /* Make a new field name, if necessary. */
1017 if (var || align != 0)
1022 sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
1023 align / BITS_PER_UNIT);
1025 strcpy (suffix, "XVL");
1027 field_name = concat_name (field_name, suffix);
1031 = create_field_decl (field_name, field_type, new_record_type,
1032 DECL_SIZE (old_field), pos, 0, 0);
1033 DECL_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
1034 TYPE_FIELDS (new_record_type) = new_field;
1036 /* If old_field is a QUAL_UNION_TYPE, take its size as being
1037 zero. The only time it's not the last field of the record
1038 is when there are other components at fixed positions after
1039 it (meaning there was a rep clause for every field) and we
1040 want to be able to encode them. */
1041 last_pos = size_binop (PLUS_EXPR, bit_position (old_field),
1042 (TREE_CODE (TREE_TYPE (old_field))
1045 : DECL_SIZE (old_field));
1046 prev_old_field = old_field;
1049 TYPE_FIELDS (new_record_type)
1050 = nreverse (TYPE_FIELDS (new_record_type));
1052 rest_of_type_decl_compilation (TYPE_STUB_DECL (new_record_type));
1055 rest_of_type_decl_compilation (TYPE_STUB_DECL (record_type));
1058 /* Append PARALLEL_TYPE on the chain of parallel types for decl. */
1061 add_parallel_type (tree decl, tree parallel_type)
1065 while (DECL_PARALLEL_TYPE (d))
1066 d = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (d));
1068 SET_DECL_PARALLEL_TYPE (d, parallel_type);
1071 /* Utility function of above to merge LAST_SIZE, the previous size of a record
1072 with FIRST_BIT and SIZE that describe a field. SPECIAL is true if this
1073 represents a QUAL_UNION_TYPE in which case we must look for COND_EXPRs and
1074 replace a value of zero with the old size. If HAS_REP is true, we take the
1075 MAX of the end position of this field with LAST_SIZE. In all other cases,
1076 we use FIRST_BIT plus SIZE. Return an expression for the size. */
1079 merge_sizes (tree last_size, tree first_bit, tree size, bool special,
1082 tree type = TREE_TYPE (last_size);
1085 if (!special || TREE_CODE (size) != COND_EXPR)
1087 new_size = size_binop (PLUS_EXPR, first_bit, size);
1089 new_size = size_binop (MAX_EXPR, last_size, new_size);
1093 new_size = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
1094 integer_zerop (TREE_OPERAND (size, 1))
1095 ? last_size : merge_sizes (last_size, first_bit,
1096 TREE_OPERAND (size, 1),
1098 integer_zerop (TREE_OPERAND (size, 2))
1099 ? last_size : merge_sizes (last_size, first_bit,
1100 TREE_OPERAND (size, 2),
1103 /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
1104 when fed through substitute_in_expr) into thinking that a constant
1105 size is not constant. */
1106 while (TREE_CODE (new_size) == NON_LVALUE_EXPR)
1107 new_size = TREE_OPERAND (new_size, 0);
1112 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
1113 related by the addition of a constant. Return that constant if so. */
1116 compute_related_constant (tree op0, tree op1)
1118 tree op0_var, op1_var;
1119 tree op0_con = split_plus (op0, &op0_var);
1120 tree op1_con = split_plus (op1, &op1_var);
1121 tree result = size_binop (MINUS_EXPR, op0_con, op1_con);
1123 if (operand_equal_p (op0_var, op1_var, 0))
1125 else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0))
1131 /* Utility function of above to split a tree OP which may be a sum, into a
1132 constant part, which is returned, and a variable part, which is stored
1133 in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of
1137 split_plus (tree in, tree *pvar)
1139 /* Strip NOPS in order to ease the tree traversal and maximize the
1140 potential for constant or plus/minus discovery. We need to be careful
1141 to always return and set *pvar to bitsizetype trees, but it's worth
1145 *pvar = convert (bitsizetype, in);
1147 if (TREE_CODE (in) == INTEGER_CST)
1149 *pvar = bitsize_zero_node;
1150 return convert (bitsizetype, in);
1152 else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
1154 tree lhs_var, rhs_var;
1155 tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
1156 tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
1158 if (lhs_var == TREE_OPERAND (in, 0)
1159 && rhs_var == TREE_OPERAND (in, 1))
1160 return bitsize_zero_node;
1162 *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
1163 return size_binop (TREE_CODE (in), lhs_con, rhs_con);
1166 return bitsize_zero_node;
1169 /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
1170 subprogram. If it is VOID_TYPE, then we are dealing with a procedure,
1171 otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
1172 PARM_DECL nodes that are the subprogram parameters. CICO_LIST is the
1173 copy-in/copy-out list to be stored into the TYPE_CICO_LIST field.
1174 RETURN_UNCONSTRAINED_P is true if the function returns an unconstrained
1175 object. RETURN_BY_DIRECT_REF_P is true if the function returns by direct
1176 reference. RETURN_BY_INVISI_REF_P is true if the function returns by
1177 invisible reference. */
1180 create_subprog_type (tree return_type, tree param_decl_list, tree cico_list,
1181 bool return_unconstrained_p, bool return_by_direct_ref_p,
1182 bool return_by_invisi_ref_p)
1184 /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
1185 the subprogram formal parameters. This list is generated by traversing
1186 the input list of PARM_DECL nodes. */
1187 tree param_type_list = NULL_TREE;
1190 for (t = param_decl_list; t; t = DECL_CHAIN (t))
1191 param_type_list = tree_cons (NULL_TREE, TREE_TYPE (t), param_type_list);
1193 /* The list of the function parameter types has to be terminated by the void
1194 type to signal to the back-end that we are not dealing with a variable
1195 parameter subprogram, but that it has a fixed number of parameters. */
1196 param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list);
1198 /* The list of argument types has been created in reverse so reverse it. */
1199 param_type_list = nreverse (param_type_list);
1201 type = build_function_type (return_type, param_type_list);
1203 /* TYPE may have been shared since GCC hashes types. If it has a different
1204 CICO_LIST, make a copy. Likewise for the various flags. */
1205 if (!fntype_same_flags_p (type, cico_list, return_unconstrained_p,
1206 return_by_direct_ref_p, return_by_invisi_ref_p))
1208 type = copy_type (type);
1209 TYPE_CI_CO_LIST (type) = cico_list;
1210 TYPE_RETURN_UNCONSTRAINED_P (type) = return_unconstrained_p;
1211 TYPE_RETURN_BY_DIRECT_REF_P (type) = return_by_direct_ref_p;
1212 TREE_ADDRESSABLE (type) = return_by_invisi_ref_p;
1218 /* Return a copy of TYPE but safe to modify in any way. */
1221 copy_type (tree type)
1223 tree new_type = copy_node (type);
1225 /* Unshare the language-specific data. */
1226 if (TYPE_LANG_SPECIFIC (type))
1228 TYPE_LANG_SPECIFIC (new_type) = NULL;
1229 SET_TYPE_LANG_SPECIFIC (new_type, GET_TYPE_LANG_SPECIFIC (type));
1232 /* And the contents of the language-specific slot if needed. */
1233 if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE)
1234 && TYPE_RM_VALUES (type))
1236 TYPE_RM_VALUES (new_type) = NULL_TREE;
1237 SET_TYPE_RM_SIZE (new_type, TYPE_RM_SIZE (type));
1238 SET_TYPE_RM_MIN_VALUE (new_type, TYPE_RM_MIN_VALUE (type));
1239 SET_TYPE_RM_MAX_VALUE (new_type, TYPE_RM_MAX_VALUE (type));
1242 /* copy_node clears this field instead of copying it, because it is
1243 aliased with TREE_CHAIN. */
1244 TYPE_STUB_DECL (new_type) = TYPE_STUB_DECL (type);
1246 TYPE_POINTER_TO (new_type) = 0;
1247 TYPE_REFERENCE_TO (new_type) = 0;
1248 TYPE_MAIN_VARIANT (new_type) = new_type;
1249 TYPE_NEXT_VARIANT (new_type) = 0;
1254 /* Return a subtype of sizetype with range MIN to MAX and whose
1255 TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position
1256 of the associated TYPE_DECL. */
1259 create_index_type (tree min, tree max, tree index, Node_Id gnat_node)
1261 /* First build a type for the desired range. */
1262 tree type = build_nonshared_range_type (sizetype, min, max);
1264 /* Then set the index type. */
1265 SET_TYPE_INDEX_TYPE (type, index);
1266 create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node);
1271 /* Return a subtype of TYPE with range MIN to MAX. If TYPE is NULL,
1272 sizetype is used. */
1275 create_range_type (tree type, tree min, tree max)
1279 if (type == NULL_TREE)
1282 /* First build a type with the base range. */
1283 range_type = build_nonshared_range_type (type, TYPE_MIN_VALUE (type),
1284 TYPE_MAX_VALUE (type));
1286 /* Then set the actual range. */
1287 SET_TYPE_RM_MIN_VALUE (range_type, convert (type, min));
1288 SET_TYPE_RM_MAX_VALUE (range_type, convert (type, max));
1293 /* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of a type.
1294 TYPE_NAME gives the name of the type and TYPE is a ..._TYPE node giving
1298 create_type_stub_decl (tree type_name, tree type)
1300 /* Using a named TYPE_DECL ensures that a type name marker is emitted in
1301 STABS while setting DECL_ARTIFICIAL ensures that no DW_TAG_typedef is
1302 emitted in DWARF. */
1303 tree type_decl = build_decl (input_location,
1304 TYPE_DECL, type_name, type);
1305 DECL_ARTIFICIAL (type_decl) = 1;
1309 /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type and TYPE
1310 is a ..._TYPE node giving its data type. ARTIFICIAL_P is true if this
1311 is a declaration that was generated by the compiler. DEBUG_INFO_P is
1312 true if we need to write debug information about this type. GNAT_NODE
1313 is used for the position of the decl. */
1316 create_type_decl (tree type_name, tree type, struct attrib *attr_list,
1317 bool artificial_p, bool debug_info_p, Node_Id gnat_node)
1319 enum tree_code code = TREE_CODE (type);
1320 bool named = TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL;
1323 /* Only the builtin TYPE_STUB_DECL should be used for dummy types. */
1324 gcc_assert (!TYPE_IS_DUMMY_P (type));
1326 /* If the type hasn't been named yet, we're naming it; preserve an existing
1327 TYPE_STUB_DECL that has been attached to it for some purpose. */
1328 if (!named && TYPE_STUB_DECL (type))
1330 type_decl = TYPE_STUB_DECL (type);
1331 DECL_NAME (type_decl) = type_name;
1334 type_decl = build_decl (input_location,
1335 TYPE_DECL, type_name, type);
1337 DECL_ARTIFICIAL (type_decl) = artificial_p;
1339 /* Add this decl to the current binding level. */
1340 gnat_pushdecl (type_decl, gnat_node);
1342 process_attributes (type_decl, attr_list);
1344 /* If we're naming the type, equate the TYPE_STUB_DECL to the name.
1345 This causes the name to be also viewed as a "tag" by the debug
1346 back-end, with the advantage that no DW_TAG_typedef is emitted
1347 for artificial "tagged" types in DWARF. */
1349 TYPE_STUB_DECL (type) = type_decl;
1351 /* Pass the type declaration to the debug back-end unless this is an
1352 UNCONSTRAINED_ARRAY_TYPE that the back-end does not support, or a
1353 type for which debugging information was not requested, or else an
1354 ENUMERAL_TYPE or RECORD_TYPE (except for fat pointers) which are
1355 handled separately. And do not pass dummy types either. */
1356 if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p)
1357 DECL_IGNORED_P (type_decl) = 1;
1358 else if (code != ENUMERAL_TYPE
1359 && (code != RECORD_TYPE || TYPE_FAT_POINTER_P (type))
1360 && !((code == POINTER_TYPE || code == REFERENCE_TYPE)
1361 && TYPE_IS_DUMMY_P (TREE_TYPE (type)))
1362 && !(code == RECORD_TYPE
1364 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (type))))))
1365 rest_of_type_decl_compilation (type_decl);
1370 /* Return a VAR_DECL or CONST_DECL node.
1372 VAR_NAME gives the name of the variable. ASM_NAME is its assembler name
1373 (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is
1374 the GCC tree for an optional initial expression; NULL_TREE if none.
1376 CONST_FLAG is true if this variable is constant, in which case we might
1377 return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false.
1379 PUBLIC_FLAG is true if this is for a reference to a public entity or for a
1380 definition to be made visible outside of the current compilation unit, for
1381 instance variable definitions in a package specification.
1383 EXTERN_FLAG is true when processing an external variable declaration (as
1384 opposed to a definition: no storage is to be allocated for the variable).
1386 STATIC_FLAG is only relevant when not at top level. In that case
1387 it indicates whether to always allocate storage to the variable.
1389 GNAT_NODE is used for the position of the decl. */
1392 create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
1393 bool const_flag, bool public_flag, bool extern_flag,
1394 bool static_flag, bool const_decl_allowed_p,
1395 struct attrib *attr_list, Node_Id gnat_node)
1399 && gnat_types_compatible_p (type, TREE_TYPE (var_init))
1400 && (global_bindings_p () || static_flag
1401 ? initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) != 0
1402 : TREE_CONSTANT (var_init)));
1404 /* Whether we will make TREE_CONSTANT the DECL we produce here, in which
1405 case the initializer may be used in-lieu of the DECL node (as done in
1406 Identifier_to_gnu). This is useful to prevent the need of elaboration
1407 code when an identifier for which such a decl is made is in turn used as
1408 an initializer. We used to rely on CONST vs VAR_DECL for this purpose,
1409 but extra constraints apply to this choice (see below) and are not
1410 relevant to the distinction we wish to make. */
1411 bool constant_p = const_flag && init_const;
1413 /* The actual DECL node. CONST_DECL was initially intended for enumerals
1414 and may be used for scalars in general but not for aggregates. */
1416 = build_decl (input_location,
1417 (constant_p && const_decl_allowed_p
1418 && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL,
1421 /* If this is external, throw away any initializations (they will be done
1422 elsewhere) unless this is a constant for which we would like to remain
1423 able to get the initializer. If we are defining a global here, leave a
1424 constant initialization and save any variable elaborations for the
1425 elaboration routine. If we are just annotating types, throw away the
1426 initialization if it isn't a constant. */
1427 if ((extern_flag && !constant_p)
1428 || (type_annotate_only && var_init && !TREE_CONSTANT (var_init)))
1429 var_init = NULL_TREE;
1431 /* At the global level, an initializer requiring code to be generated
1432 produces elaboration statements. Check that such statements are allowed,
1433 that is, not violating a No_Elaboration_Code restriction. */
1434 if (global_bindings_p () && var_init != 0 && !init_const)
1435 Check_Elaboration_Code_Allowed (gnat_node);
1437 DECL_INITIAL (var_decl) = var_init;
1438 TREE_READONLY (var_decl) = const_flag;
1439 DECL_EXTERNAL (var_decl) = extern_flag;
1440 TREE_PUBLIC (var_decl) = public_flag || extern_flag;
1441 TREE_CONSTANT (var_decl) = constant_p;
1442 TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
1443 = TYPE_VOLATILE (type);
1445 /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
1446 try to fiddle with DECL_COMMON. However, on platforms that don't
1447 support global BSS sections, uninitialized global variables would
1448 go in DATA instead, thus increasing the size of the executable. */
1450 && TREE_CODE (var_decl) == VAR_DECL
1451 && TREE_PUBLIC (var_decl)
1452 && !have_global_bss_p ())
1453 DECL_COMMON (var_decl) = 1;
1455 /* At the global binding level, we need to allocate static storage for the
1456 variable if it isn't external. Otherwise, we allocate automatic storage
1457 unless requested not to. */
1458 TREE_STATIC (var_decl)
1459 = !extern_flag && (static_flag || global_bindings_p ());
1461 /* For an external constant whose initializer is not absolute, do not emit
1462 debug info. In DWARF this would mean a global relocation in a read-only
1463 section which runs afoul of the PE-COFF run-time relocation mechanism. */
1466 && initializer_constant_valid_p (var_init, TREE_TYPE (var_init))
1467 != null_pointer_node)
1468 DECL_IGNORED_P (var_decl) = 1;
1470 /* Add this decl to the current binding level. */
1471 gnat_pushdecl (var_decl, gnat_node);
1473 if (TREE_SIDE_EFFECTS (var_decl))
1474 TREE_ADDRESSABLE (var_decl) = 1;
1476 if (TREE_CODE (var_decl) == VAR_DECL)
1479 SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
1480 process_attributes (var_decl, attr_list);
1481 if (global_bindings_p ())
1482 rest_of_decl_compilation (var_decl, true, 0);
1485 expand_decl (var_decl);
1490 /* Return true if TYPE, an aggregate type, contains (or is) an array. */
1493 aggregate_type_contains_array_p (tree type)
1495 switch (TREE_CODE (type))
1499 case QUAL_UNION_TYPE:
1502 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
1503 if (AGGREGATE_TYPE_P (TREE_TYPE (field))
1504 && aggregate_type_contains_array_p (TREE_TYPE (field)))
1517 /* Return a FIELD_DECL node. FIELD_NAME is the field's name, FIELD_TYPE is
1518 its type and RECORD_TYPE is the type of the enclosing record. If SIZE is
1519 nonzero, it is the specified size of the field. If POS is nonzero, it is
1520 the bit position. PACKED is 1 if the enclosing record is packed, -1 if it
1521 has Component_Alignment of Storage_Unit. If ADDRESSABLE is nonzero, it
1522 means we are allowed to take the address of the field; if it is negative,
1523 we should not make a bitfield, which is used by make_aligning_type. */
1526 create_field_decl (tree field_name, tree field_type, tree record_type,
1527 tree size, tree pos, int packed, int addressable)
1529 tree field_decl = build_decl (input_location,
1530 FIELD_DECL, field_name, field_type);
1532 DECL_CONTEXT (field_decl) = record_type;
1533 TREE_READONLY (field_decl) = TYPE_READONLY (field_type);
1535 /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1536 byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
1537 Likewise for an aggregate without specified position that contains an
1538 array, because in this case slices of variable length of this array
1539 must be handled by GCC and variable-sized objects need to be aligned
1540 to at least a byte boundary. */
1541 if (packed && (TYPE_MODE (field_type) == BLKmode
1543 && AGGREGATE_TYPE_P (field_type)
1544 && aggregate_type_contains_array_p (field_type))))
1545 DECL_ALIGN (field_decl) = BITS_PER_UNIT;
1547 /* If a size is specified, use it. Otherwise, if the record type is packed
1548 compute a size to use, which may differ from the object's natural size.
1549 We always set a size in this case to trigger the checks for bitfield
1550 creation below, which is typically required when no position has been
1553 size = convert (bitsizetype, size);
1554 else if (packed == 1)
1556 size = rm_size (field_type);
1557 if (TYPE_MODE (field_type) == BLKmode)
1558 size = round_up (size, BITS_PER_UNIT);
1561 /* If we may, according to ADDRESSABLE, make a bitfield if a size is
1562 specified for two reasons: first if the size differs from the natural
1563 size. Second, if the alignment is insufficient. There are a number of
1564 ways the latter can be true.
1566 We never make a bitfield if the type of the field has a nonconstant size,
1567 because no such entity requiring bitfield operations should reach here.
1569 We do *preventively* make a bitfield when there might be the need for it
1570 but we don't have all the necessary information to decide, as is the case
1571 of a field with no specified position in a packed record.
1573 We also don't look at STRICT_ALIGNMENT here, and rely on later processing
1574 in layout_decl or finish_record_type to clear the bit_field indication if
1575 it is in fact not needed. */
1576 if (addressable >= 0
1578 && TREE_CODE (size) == INTEGER_CST
1579 && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
1580 && (!tree_int_cst_equal (size, TYPE_SIZE (field_type))
1581 || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type)))
1583 || (TYPE_ALIGN (record_type) != 0
1584 && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))))
1586 DECL_BIT_FIELD (field_decl) = 1;
1587 DECL_SIZE (field_decl) = size;
1588 if (!packed && !pos)
1590 if (TYPE_ALIGN (record_type) != 0
1591 && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))
1592 DECL_ALIGN (field_decl) = TYPE_ALIGN (record_type);
1594 DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
1598 DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
1600 /* Bump the alignment if need be, either for bitfield/packing purposes or
1601 to satisfy the type requirements if no such consideration applies. When
1602 we get the alignment from the type, indicate if this is from an explicit
1603 user request, which prevents stor-layout from lowering it later on. */
1605 unsigned int bit_align
1606 = (DECL_BIT_FIELD (field_decl) ? 1
1607 : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0);
1609 if (bit_align > DECL_ALIGN (field_decl))
1610 DECL_ALIGN (field_decl) = bit_align;
1611 else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl))
1613 DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
1614 DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type);
1620 /* We need to pass in the alignment the DECL is known to have.
1621 This is the lowest-order bit set in POS, but no more than
1622 the alignment of the record, if one is specified. Note
1623 that an alignment of 0 is taken as infinite. */
1624 unsigned int known_align;
1626 if (host_integerp (pos, 1))
1627 known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1);
1629 known_align = BITS_PER_UNIT;
1631 if (TYPE_ALIGN (record_type)
1632 && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
1633 known_align = TYPE_ALIGN (record_type);
1635 layout_decl (field_decl, known_align);
1636 SET_DECL_OFFSET_ALIGN (field_decl,
1637 host_integerp (pos, 1) ? BIGGEST_ALIGNMENT
1639 pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
1640 &DECL_FIELD_BIT_OFFSET (field_decl),
1641 DECL_OFFSET_ALIGN (field_decl), pos);
1644 /* In addition to what our caller says, claim the field is addressable if we
1645 know that its type is not suitable.
1647 The field may also be "technically" nonaddressable, meaning that even if
1648 we attempt to take the field's address we will actually get the address
1649 of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD
1650 value we have at this point is not accurate enough, so we don't account
1651 for this here and let finish_record_type decide. */
1652 if (!addressable && !type_for_nonaliased_component_p (field_type))
1655 DECL_NONADDRESSABLE_P (field_decl) = !addressable;
1660 /* Return a PARM_DECL node. PARAM_NAME is the name of the parameter and
1661 PARAM_TYPE is its type. READONLY is true if the parameter is readonly
1662 (either an In parameter or an address of a pass-by-ref parameter). */
1665 create_param_decl (tree param_name, tree param_type, bool readonly)
1667 tree param_decl = build_decl (input_location,
1668 PARM_DECL, param_name, param_type);
1670 /* Honor TARGET_PROMOTE_PROTOTYPES like the C compiler, as not doing so
1671 can lead to various ABI violations. */
1672 if (targetm.calls.promote_prototypes (NULL_TREE)
1673 && INTEGRAL_TYPE_P (param_type)
1674 && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
1676 /* We have to be careful about biased types here. Make a subtype
1677 of integer_type_node with the proper biasing. */
1678 if (TREE_CODE (param_type) == INTEGER_TYPE
1679 && TYPE_BIASED_REPRESENTATION_P (param_type))
1682 = make_unsigned_type (TYPE_PRECISION (integer_type_node));
1683 TREE_TYPE (subtype) = integer_type_node;
1684 TYPE_BIASED_REPRESENTATION_P (subtype) = 1;
1685 SET_TYPE_RM_MIN_VALUE (subtype, TYPE_MIN_VALUE (param_type));
1686 SET_TYPE_RM_MAX_VALUE (subtype, TYPE_MAX_VALUE (param_type));
1687 param_type = subtype;
1690 param_type = integer_type_node;
1693 DECL_ARG_TYPE (param_decl) = param_type;
1694 TREE_READONLY (param_decl) = readonly;
1698 /* Given a DECL and ATTR_LIST, process the listed attributes. */
1701 process_attributes (tree decl, struct attrib *attr_list)
1703 for (; attr_list; attr_list = attr_list->next)
1704 switch (attr_list->type)
1706 case ATTR_MACHINE_ATTRIBUTE:
1707 input_location = DECL_SOURCE_LOCATION (decl);
1708 decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args,
1710 ATTR_FLAG_TYPE_IN_PLACE);
1713 case ATTR_LINK_ALIAS:
1714 if (! DECL_EXTERNAL (decl))
1716 TREE_STATIC (decl) = 1;
1717 assemble_alias (decl, attr_list->name);
1721 case ATTR_WEAK_EXTERNAL:
1723 declare_weak (decl);
1725 post_error ("?weak declarations not supported on this target",
1726 attr_list->error_point);
1729 case ATTR_LINK_SECTION:
1730 if (targetm.have_named_sections)
1732 DECL_SECTION_NAME (decl)
1733 = build_string (IDENTIFIER_LENGTH (attr_list->name),
1734 IDENTIFIER_POINTER (attr_list->name));
1735 DECL_COMMON (decl) = 0;
1738 post_error ("?section attributes are not supported for this target",
1739 attr_list->error_point);
1742 case ATTR_LINK_CONSTRUCTOR:
1743 DECL_STATIC_CONSTRUCTOR (decl) = 1;
1744 TREE_USED (decl) = 1;
1747 case ATTR_LINK_DESTRUCTOR:
1748 DECL_STATIC_DESTRUCTOR (decl) = 1;
1749 TREE_USED (decl) = 1;
1752 case ATTR_THREAD_LOCAL_STORAGE:
1753 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
1754 DECL_COMMON (decl) = 0;
1759 /* Record DECL as a global renaming pointer. */
1762 record_global_renaming_pointer (tree decl)
1764 gcc_assert (DECL_RENAMED_OBJECT (decl));
1765 VEC_safe_push (tree, gc, global_renaming_pointers, decl);
1768 /* Invalidate the global renaming pointers. */
1771 invalidate_global_renaming_pointers (void)
1776 FOR_EACH_VEC_ELT (tree, global_renaming_pointers, i, iter)
1777 SET_DECL_RENAMED_OBJECT (iter, NULL_TREE);
1779 VEC_free (tree, gc, global_renaming_pointers);
1782 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
1786 value_factor_p (tree value, HOST_WIDE_INT factor)
1788 if (host_integerp (value, 1))
1789 return tree_low_cst (value, 1) % factor == 0;
1791 if (TREE_CODE (value) == MULT_EXPR)
1792 return (value_factor_p (TREE_OPERAND (value, 0), factor)
1793 || value_factor_p (TREE_OPERAND (value, 1), factor));
1798 /* Given two consecutive field decls PREV_FIELD and CURR_FIELD, return true
1799 unless we can prove these 2 fields are laid out in such a way that no gap
1800 exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET
1801 is the distance in bits between the end of PREV_FIELD and the starting
1802 position of CURR_FIELD. It is ignored if null. */
1805 potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
1807 /* If this is the first field of the record, there cannot be any gap */
1811 /* If the previous field is a union type, then return False: The only
1812 time when such a field is not the last field of the record is when
1813 there are other components at fixed positions after it (meaning there
1814 was a rep clause for every field), in which case we don't want the
1815 alignment constraint to override them. */
1816 if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
1819 /* If the distance between the end of prev_field and the beginning of
1820 curr_field is constant, then there is a gap if the value of this
1821 constant is not null. */
1822 if (offset && host_integerp (offset, 1))
1823 return !integer_zerop (offset);
1825 /* If the size and position of the previous field are constant,
1826 then check the sum of this size and position. There will be a gap
1827 iff it is not multiple of the current field alignment. */
1828 if (host_integerp (DECL_SIZE (prev_field), 1)
1829 && host_integerp (bit_position (prev_field), 1))
1830 return ((tree_low_cst (bit_position (prev_field), 1)
1831 + tree_low_cst (DECL_SIZE (prev_field), 1))
1832 % DECL_ALIGN (curr_field) != 0);
1834 /* If both the position and size of the previous field are multiples
1835 of the current field alignment, there cannot be any gap. */
1836 if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
1837 && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
1840 /* Fallback, return that there may be a potential gap */
1844 /* Return a LABEL_DECL node for LABEL_NAME. */
1847 create_label_decl (tree label_name)
1849 tree label_decl = build_decl (input_location,
1850 LABEL_DECL, label_name, void_type_node);
1852 DECL_CONTEXT (label_decl) = current_function_decl;
1853 DECL_MODE (label_decl) = VOIDmode;
1854 DECL_SOURCE_LOCATION (label_decl) = input_location;
1859 /* Return a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram,
1860 ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1861 node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1862 PARM_DECL nodes chained through the TREE_CHAIN field).
1864 INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, ARTIFICIAL_FLAG and ATTR_LIST are
1865 used to set the appropriate fields in the FUNCTION_DECL. GNAT_NODE is
1866 used for the position of the decl. */
1869 create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type,
1870 tree param_decl_list, bool inline_flag, bool public_flag,
1871 bool extern_flag, bool artificial_flag,
1872 struct attrib *attr_list, Node_Id gnat_node)
1874 tree subprog_decl = build_decl (input_location, FUNCTION_DECL, subprog_name,
1876 tree result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE,
1877 TREE_TYPE (subprog_type));
1878 DECL_ARGUMENTS (subprog_decl) = param_decl_list;
1880 /* If this is a non-inline function nested inside an inlined external
1881 function, we cannot honor both requests without cloning the nested
1882 function in the current unit since it is private to the other unit.
1883 We could inline the nested function as well but it's probably better
1884 to err on the side of too little inlining. */
1887 && current_function_decl
1888 && DECL_DECLARED_INLINE_P (current_function_decl)
1889 && DECL_EXTERNAL (current_function_decl))
1890 DECL_DECLARED_INLINE_P (current_function_decl) = 0;
1892 DECL_ARTIFICIAL (subprog_decl) = artificial_flag;
1893 DECL_EXTERNAL (subprog_decl) = extern_flag;
1894 DECL_DECLARED_INLINE_P (subprog_decl) = inline_flag;
1895 DECL_NO_INLINE_WARNING_P (subprog_decl) = inline_flag && artificial_flag;
1897 TREE_PUBLIC (subprog_decl) = public_flag;
1898 TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type);
1899 TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
1900 TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
1902 DECL_ARTIFICIAL (result_decl) = 1;
1903 DECL_IGNORED_P (result_decl) = 1;
1904 DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (subprog_type);
1905 DECL_RESULT (subprog_decl) = result_decl;
1909 SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
1911 /* The expand_main_function circuitry expects "main_identifier_node" to
1912 designate the DECL_NAME of the 'main' entry point, in turn expected
1913 to be declared as the "main" function literally by default. Ada
1914 program entry points are typically declared with a different name
1915 within the binder generated file, exported as 'main' to satisfy the
1916 system expectations. Force main_identifier_node in this case. */
1917 if (asm_name == main_identifier_node)
1918 DECL_NAME (subprog_decl) = main_identifier_node;
1921 /* Add this decl to the current binding level. */
1922 gnat_pushdecl (subprog_decl, gnat_node);
1924 process_attributes (subprog_decl, attr_list);
1926 /* Output the assembler code and/or RTL for the declaration. */
1927 rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
1929 return subprog_decl;
1932 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
1933 body. This routine needs to be invoked before processing the declarations
1934 appearing in the subprogram. */
1937 begin_subprog_body (tree subprog_decl)
1941 announce_function (subprog_decl);
1943 /* This function is being defined. */
1944 TREE_STATIC (subprog_decl) = 1;
1946 current_function_decl = subprog_decl;
1948 /* Enter a new binding level and show that all the parameters belong to
1952 for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
1953 param_decl = DECL_CHAIN (param_decl))
1954 DECL_CONTEXT (param_decl) = subprog_decl;
1956 make_decl_rtl (subprog_decl);
1959 /* Finish the definition of the current subprogram BODY and finalize it. */
1962 end_subprog_body (tree body)
1964 tree fndecl = current_function_decl;
1966 /* Attach the BLOCK for this level to the function and pop the level. */
1967 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
1968 DECL_INITIAL (fndecl) = current_binding_level->block;
1971 /* Mark the RESULT_DECL as being in this subprogram. */
1972 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
1974 /* The body should be a BIND_EXPR whose BLOCK is the top-level one. */
1975 if (TREE_CODE (body) == BIND_EXPR)
1977 BLOCK_SUPERCONTEXT (BIND_EXPR_BLOCK (body)) = fndecl;
1978 DECL_INITIAL (fndecl) = BIND_EXPR_BLOCK (body);
1981 DECL_SAVED_TREE (fndecl) = body;
1983 current_function_decl = DECL_CONTEXT (fndecl);
1985 /* We cannot track the location of errors past this point. */
1986 error_gnat_node = Empty;
1988 /* If we're only annotating types, don't actually compile this function. */
1989 if (type_annotate_only)
1992 /* Dump functions before gimplification. */
1993 dump_function (TDI_original, fndecl);
1995 /* ??? This special handling of nested functions is probably obsolete. */
1996 if (!DECL_CONTEXT (fndecl))
1997 cgraph_finalize_function (fndecl, false);
1999 /* Register this function with cgraph just far enough to get it
2000 added to our parent's nested function list. */
2001 (void) cgraph_get_create_node (fndecl);
2005 gnat_builtin_function (tree decl)
2007 gnat_pushdecl (decl, Empty);
2011 /* Return an integer type with the number of bits of precision given by
2012 PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
2013 it is a signed type. */
2016 gnat_type_for_size (unsigned precision, int unsignedp)
2021 if (precision <= 2 * MAX_BITS_PER_WORD
2022 && signed_and_unsigned_types[precision][unsignedp])
2023 return signed_and_unsigned_types[precision][unsignedp];
2026 t = make_unsigned_type (precision);
2028 t = make_signed_type (precision);
2030 if (precision <= 2 * MAX_BITS_PER_WORD)
2031 signed_and_unsigned_types[precision][unsignedp] = t;
2035 sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision);
2036 TYPE_NAME (t) = get_identifier (type_name);
2042 /* Likewise for floating-point types. */
2045 float_type_for_precision (int precision, enum machine_mode mode)
2050 if (float_types[(int) mode])
2051 return float_types[(int) mode];
2053 float_types[(int) mode] = t = make_node (REAL_TYPE);
2054 TYPE_PRECISION (t) = precision;
2057 gcc_assert (TYPE_MODE (t) == mode);
2060 sprintf (type_name, "FLOAT_%d", precision);
2061 TYPE_NAME (t) = get_identifier (type_name);
2067 /* Return a data type that has machine mode MODE. UNSIGNEDP selects
2068 an unsigned type; otherwise a signed type is returned. */
2071 gnat_type_for_mode (enum machine_mode mode, int unsignedp)
2073 if (mode == BLKmode)
2076 if (mode == VOIDmode)
2077 return void_type_node;
2079 if (COMPLEX_MODE_P (mode))
2082 if (SCALAR_FLOAT_MODE_P (mode))
2083 return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
2085 if (SCALAR_INT_MODE_P (mode))
2086 return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
2088 if (VECTOR_MODE_P (mode))
2090 enum machine_mode inner_mode = GET_MODE_INNER (mode);
2091 tree inner_type = gnat_type_for_mode (inner_mode, unsignedp);
2093 return build_vector_type_for_mode (inner_type, mode);
2099 /* Return the unsigned version of a TYPE_NODE, a scalar type. */
2102 gnat_unsigned_type (tree type_node)
2104 tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1);
2106 if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2108 type = copy_node (type);
2109 TREE_TYPE (type) = type_node;
2111 else if (TREE_TYPE (type_node)
2112 && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2113 && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2115 type = copy_node (type);
2116 TREE_TYPE (type) = TREE_TYPE (type_node);
2122 /* Return the signed version of a TYPE_NODE, a scalar type. */
2125 gnat_signed_type (tree type_node)
2127 tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0);
2129 if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2131 type = copy_node (type);
2132 TREE_TYPE (type) = type_node;
2134 else if (TREE_TYPE (type_node)
2135 && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2136 && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2138 type = copy_node (type);
2139 TREE_TYPE (type) = TREE_TYPE (type_node);
2145 /* Return 1 if the types T1 and T2 are compatible, i.e. if they can be
2146 transparently converted to each other. */
2149 gnat_types_compatible_p (tree t1, tree t2)
2151 enum tree_code code;
2153 /* This is the default criterion. */
2154 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
2157 /* We only check structural equivalence here. */
2158 if ((code = TREE_CODE (t1)) != TREE_CODE (t2))
2161 /* Vector types are also compatible if they have the same number of subparts
2162 and the same form of (scalar) element type. */
2163 if (code == VECTOR_TYPE
2164 && TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2)
2165 && TREE_CODE (TREE_TYPE (t1)) == TREE_CODE (TREE_TYPE (t2))
2166 && TYPE_PRECISION (TREE_TYPE (t1)) == TYPE_PRECISION (TREE_TYPE (t2)))
2169 /* Array types are also compatible if they are constrained and have the same
2170 domain(s) and the same component type. */
2171 if (code == ARRAY_TYPE
2172 && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2)
2173 || (TYPE_DOMAIN (t1)
2175 && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)),
2176 TYPE_MIN_VALUE (TYPE_DOMAIN (t2)))
2177 && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)),
2178 TYPE_MAX_VALUE (TYPE_DOMAIN (t2)))))
2179 && (TREE_TYPE (t1) == TREE_TYPE (t2)
2180 || (TREE_CODE (TREE_TYPE (t1)) == ARRAY_TYPE
2181 && gnat_types_compatible_p (TREE_TYPE (t1), TREE_TYPE (t2)))))
2184 /* Padding record types are also compatible if they pad the same
2185 type and have the same constant size. */
2186 if (code == RECORD_TYPE
2187 && TYPE_PADDING_P (t1) && TYPE_PADDING_P (t2)
2188 && TREE_TYPE (TYPE_FIELDS (t1)) == TREE_TYPE (TYPE_FIELDS (t2))
2189 && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2)))
2195 /* Return true if T, a FUNCTION_TYPE, has the specified list of flags. */
2198 fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p,
2199 bool return_by_direct_ref_p, bool return_by_invisi_ref_p)
2201 return TYPE_CI_CO_LIST (t) == cico_list
2202 && TYPE_RETURN_UNCONSTRAINED_P (t) == return_unconstrained_p
2203 && TYPE_RETURN_BY_DIRECT_REF_P (t) == return_by_direct_ref_p
2204 && TREE_ADDRESSABLE (t) == return_by_invisi_ref_p;
2207 /* EXP is an expression for the size of an object. If this size contains
2208 discriminant references, replace them with the maximum (if MAX_P) or
2209 minimum (if !MAX_P) possible value of the discriminant. */
2212 max_size (tree exp, bool max_p)
2214 enum tree_code code = TREE_CODE (exp);
2215 tree type = TREE_TYPE (exp);
2217 switch (TREE_CODE_CLASS (code))
2219 case tcc_declaration:
2224 if (code == CALL_EXPR)
2229 t = maybe_inline_call_in_expr (exp);
2231 return max_size (t, max_p);
2233 n = call_expr_nargs (exp);
2235 argarray = XALLOCAVEC (tree, n);
2236 for (i = 0; i < n; i++)
2237 argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p);
2238 return build_call_array (type, CALL_EXPR_FN (exp), n, argarray);
2243 /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
2244 modify. Otherwise, we treat it like a variable. */
2245 if (!CONTAINS_PLACEHOLDER_P (exp))
2248 type = TREE_TYPE (TREE_OPERAND (exp, 1));
2250 max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true);
2252 case tcc_comparison:
2253 return max_p ? size_one_node : size_zero_node;
2257 case tcc_expression:
2258 switch (TREE_CODE_LENGTH (code))
2261 if (code == NON_LVALUE_EXPR)
2262 return max_size (TREE_OPERAND (exp, 0), max_p);
2265 fold_build1 (code, type,
2266 max_size (TREE_OPERAND (exp, 0),
2267 code == NEGATE_EXPR ? !max_p : max_p));
2270 if (code == COMPOUND_EXPR)
2271 return max_size (TREE_OPERAND (exp, 1), max_p);
2274 tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
2275 tree rhs = max_size (TREE_OPERAND (exp, 1),
2276 code == MINUS_EXPR ? !max_p : max_p);
2278 /* Special-case wanting the maximum value of a MIN_EXPR.
2279 In that case, if one side overflows, return the other.
2280 sizetype is signed, but we know sizes are non-negative.
2281 Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2282 overflowing and the RHS a variable. */
2285 && TREE_CODE (rhs) == INTEGER_CST
2286 && TREE_OVERFLOW (rhs))
2290 && TREE_CODE (lhs) == INTEGER_CST
2291 && TREE_OVERFLOW (lhs))
2293 else if ((code == MINUS_EXPR || code == PLUS_EXPR)
2294 && TREE_CODE (lhs) == INTEGER_CST
2295 && TREE_OVERFLOW (lhs)
2296 && !TREE_CONSTANT (rhs))
2299 return fold_build2 (code, type, lhs, rhs);
2303 if (code == SAVE_EXPR)
2305 else if (code == COND_EXPR)
2306 return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
2307 max_size (TREE_OPERAND (exp, 1), max_p),
2308 max_size (TREE_OPERAND (exp, 2), max_p));
2311 /* Other tree classes cannot happen. */
2319 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2320 EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2321 Return a constructor for the template. */
2324 build_template (tree template_type, tree array_type, tree expr)
2326 VEC(constructor_elt,gc) *template_elts = NULL;
2327 tree bound_list = NULL_TREE;
2330 while (TREE_CODE (array_type) == RECORD_TYPE
2331 && (TYPE_PADDING_P (array_type)
2332 || TYPE_JUSTIFIED_MODULAR_P (array_type)))
2333 array_type = TREE_TYPE (TYPE_FIELDS (array_type));
2335 if (TREE_CODE (array_type) == ARRAY_TYPE
2336 || (TREE_CODE (array_type) == INTEGER_TYPE
2337 && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
2338 bound_list = TYPE_ACTUAL_BOUNDS (array_type);
2340 /* First make the list for a CONSTRUCTOR for the template. Go down the
2341 field list of the template instead of the type chain because this
2342 array might be an Ada array of arrays and we can't tell where the
2343 nested arrays stop being the underlying object. */
2345 for (field = TYPE_FIELDS (template_type); field;
2347 ? (bound_list = TREE_CHAIN (bound_list))
2348 : (array_type = TREE_TYPE (array_type))),
2349 field = DECL_CHAIN (DECL_CHAIN (field)))
2351 tree bounds, min, max;
2353 /* If we have a bound list, get the bounds from there. Likewise
2354 for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
2355 DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2356 This will give us a maximum range. */
2358 bounds = TREE_VALUE (bound_list);
2359 else if (TREE_CODE (array_type) == ARRAY_TYPE)
2360 bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
2361 else if (expr && TREE_CODE (expr) == PARM_DECL
2362 && DECL_BY_COMPONENT_PTR_P (expr))
2363 bounds = TREE_TYPE (field);
2367 min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds));
2368 max = convert (TREE_TYPE (DECL_CHAIN (field)), TYPE_MAX_VALUE (bounds));
2370 /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2371 substitute it from OBJECT. */
2372 min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr);
2373 max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr);
2375 CONSTRUCTOR_APPEND_ELT (template_elts, field, min);
2376 CONSTRUCTOR_APPEND_ELT (template_elts, DECL_CHAIN (field), max);
2379 return gnat_build_constructor (template_type, template_elts);
2382 /* Helper routine to make a descriptor field. FIELD_LIST is the list of decls
2383 being built; the new decl is chained on to the front of the list. */
2386 make_descriptor_field (const char *name, tree type, tree rec_type,
2387 tree initial, tree field_list)
2390 = create_field_decl (get_identifier (name), type, rec_type, NULL_TREE,
2393 DECL_INITIAL (field) = initial;
2394 DECL_CHAIN (field) = field_list;
2398 /* Build a 32-bit VMS descriptor from a Mechanism_Type, which must specify a
2399 descriptor type, and the GCC type of an object. Each FIELD_DECL in the
2400 type contains in its DECL_INITIAL the expression to use when a constructor
2401 is made for the type. GNAT_ENTITY is an entity used to print out an error
2402 message if the mechanism cannot be applied to an object of that type and
2403 also for the name. */
2406 build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
2408 tree record_type = make_node (RECORD_TYPE);
2409 tree pointer32_type, pointer64_type;
2410 tree field_list = NULL_TREE;
2411 int klass, ndim, i, dtype = 0;
2412 tree inner_type, tem;
2415 /* If TYPE is an unconstrained array, use the underlying array type. */
2416 if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2417 type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2419 /* If this is an array, compute the number of dimensions in the array,
2420 get the index types, and point to the inner type. */
2421 if (TREE_CODE (type) != ARRAY_TYPE)
2424 for (ndim = 1, inner_type = type;
2425 TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
2426 && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
2427 ndim++, inner_type = TREE_TYPE (inner_type))
2430 idx_arr = XALLOCAVEC (tree, ndim);
2432 if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA
2433 && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
2434 for (i = ndim - 1, inner_type = type;
2436 i--, inner_type = TREE_TYPE (inner_type))
2437 idx_arr[i] = TYPE_DOMAIN (inner_type);
2439 for (i = 0, inner_type = type;
2441 i++, inner_type = TREE_TYPE (inner_type))
2442 idx_arr[i] = TYPE_DOMAIN (inner_type);
2444 /* Now get the DTYPE value. */
2445 switch (TREE_CODE (type))
2450 if (TYPE_VAX_FLOATING_POINT_P (type))
2451 switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2464 switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
2467 dtype = TYPE_UNSIGNED (type) ? 2 : 6;
2470 dtype = TYPE_UNSIGNED (type) ? 3 : 7;
2473 dtype = TYPE_UNSIGNED (type) ? 4 : 8;
2476 dtype = TYPE_UNSIGNED (type) ? 5 : 9;
2479 dtype = TYPE_UNSIGNED (type) ? 25 : 26;
2485 dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
2489 if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
2490 && TYPE_VAX_FLOATING_POINT_P (type))
2491 switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2503 dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
2514 /* Get the CLASS value. */
2517 case By_Descriptor_A:
2518 case By_Short_Descriptor_A:
2521 case By_Descriptor_NCA:
2522 case By_Short_Descriptor_NCA:
2525 case By_Descriptor_SB:
2526 case By_Short_Descriptor_SB:
2530 case By_Short_Descriptor:
2531 case By_Descriptor_S:
2532 case By_Short_Descriptor_S:
2538 /* Make the type for a descriptor for VMS. The first four fields are the
2539 same for all types. */
2541 = make_descriptor_field ("LENGTH", gnat_type_for_size (16, 1), record_type,
2542 size_in_bytes ((mech == By_Descriptor_A
2543 || mech == By_Short_Descriptor_A)
2544 ? inner_type : type),
2547 = make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1), record_type,
2548 size_int (dtype), field_list);
2550 = make_descriptor_field ("CLASS", gnat_type_for_size (8, 1), record_type,
2551 size_int (klass), field_list);
2553 pointer32_type = build_pointer_type_for_mode (type, SImode, false);
2554 pointer64_type = build_pointer_type_for_mode (type, DImode, false);
2556 /* Ensure that only 32-bit pointers are passed in 32-bit descriptors. Note
2557 that we cannot build a template call to the CE routine as it would get a
2558 wrong source location; instead we use a second placeholder for it. */
2559 tem = build_unary_op (ADDR_EXPR, pointer64_type,
2560 build0 (PLACEHOLDER_EXPR, type));
2561 tem = build3 (COND_EXPR, pointer32_type,
2562 build_binary_op (GE_EXPR, boolean_type_node, tem,
2563 build_int_cstu (pointer64_type, 0x80000000)),
2564 build0 (PLACEHOLDER_EXPR, void_type_node),
2565 convert (pointer32_type, tem));
2568 = make_descriptor_field ("POINTER", pointer32_type, record_type, tem,
2574 case By_Short_Descriptor:
2575 case By_Descriptor_S:
2576 case By_Short_Descriptor_S:
2579 case By_Descriptor_SB:
2580 case By_Short_Descriptor_SB:
2582 = make_descriptor_field ("SB_L1", gnat_type_for_size (32, 1),
2584 (TREE_CODE (type) == ARRAY_TYPE
2585 ? TYPE_MIN_VALUE (TYPE_DOMAIN (type))
2589 = make_descriptor_field ("SB_U1", gnat_type_for_size (32, 1),
2591 (TREE_CODE (type) == ARRAY_TYPE
2592 ? TYPE_MAX_VALUE (TYPE_DOMAIN (type))
2597 case By_Descriptor_A:
2598 case By_Short_Descriptor_A:
2599 case By_Descriptor_NCA:
2600 case By_Short_Descriptor_NCA:
2602 = make_descriptor_field ("SCALE", gnat_type_for_size (8, 1),
2603 record_type, size_zero_node, field_list);
2606 = make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1),
2607 record_type, size_zero_node, field_list);
2610 = make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1),
2612 size_int ((mech == By_Descriptor_NCA
2613 || mech == By_Short_Descriptor_NCA)
2615 /* Set FL_COLUMN, FL_COEFF, and
2617 : (TREE_CODE (type) == ARRAY_TYPE
2618 && TYPE_CONVENTION_FORTRAN_P
2624 = make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1),
2625 record_type, size_int (ndim), field_list);
2628 = make_descriptor_field ("ARSIZE", gnat_type_for_size (32, 1),
2629 record_type, size_in_bytes (type),
2632 /* Now build a pointer to the 0,0,0... element. */
2633 tem = build0 (PLACEHOLDER_EXPR, type);
2634 for (i = 0, inner_type = type; i < ndim;
2635 i++, inner_type = TREE_TYPE (inner_type))
2636 tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
2637 convert (TYPE_DOMAIN (inner_type), size_zero_node),
2638 NULL_TREE, NULL_TREE);
2641 = make_descriptor_field ("A0", pointer32_type, record_type,
2642 build1 (ADDR_EXPR, pointer32_type, tem),
2645 /* Next come the addressing coefficients. */
2646 tem = size_one_node;
2647 for (i = 0; i < ndim; i++)
2651 = size_binop (MULT_EXPR, tem,
2652 size_binop (PLUS_EXPR,
2653 size_binop (MINUS_EXPR,
2654 TYPE_MAX_VALUE (idx_arr[i]),
2655 TYPE_MIN_VALUE (idx_arr[i])),
2658 fname[0] = ((mech == By_Descriptor_NCA ||
2659 mech == By_Short_Descriptor_NCA) ? 'S' : 'M');
2660 fname[1] = '0' + i, fname[2] = 0;
2662 = make_descriptor_field (fname, gnat_type_for_size (32, 1),
2663 record_type, idx_length, field_list);
2665 if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA)
2669 /* Finally here are the bounds. */
2670 for (i = 0; i < ndim; i++)
2674 fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
2676 = make_descriptor_field (fname, gnat_type_for_size (32, 1),
2677 record_type, TYPE_MIN_VALUE (idx_arr[i]),
2682 = make_descriptor_field (fname, gnat_type_for_size (32, 1),
2683 record_type, TYPE_MAX_VALUE (idx_arr[i]),
2689 post_error ("unsupported descriptor type for &", gnat_entity);
2692 TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC");
2693 finish_record_type (record_type, nreverse (field_list), 0, false);
2697 /* Build a 64-bit VMS descriptor from a Mechanism_Type, which must specify a
2698 descriptor type, and the GCC type of an object. Each FIELD_DECL in the
2699 type contains in its DECL_INITIAL the expression to use when a constructor
2700 is made for the type. GNAT_ENTITY is an entity used to print out an error
2701 message if the mechanism cannot be applied to an object of that type and
2702 also for the name. */
2705 build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
2707 tree record_type = make_node (RECORD_TYPE);
2708 tree pointer64_type;
2709 tree field_list = NULL_TREE;
2710 int klass, ndim, i, dtype = 0;
2711 tree inner_type, tem;
2714 /* If TYPE is an unconstrained array, use the underlying array type. */
2715 if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2716 type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2718 /* If this is an array, compute the number of dimensions in the array,
2719 get the index types, and point to the inner type. */
2720 if (TREE_CODE (type) != ARRAY_TYPE)
2723 for (ndim = 1, inner_type = type;
2724 TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
2725 && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
2726 ndim++, inner_type = TREE_TYPE (inner_type))
2729 idx_arr = XALLOCAVEC (tree, ndim);
2731 if (mech != By_Descriptor_NCA
2732 && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
2733 for (i = ndim - 1, inner_type = type;
2735 i--, inner_type = TREE_TYPE (inner_type))
2736 idx_arr[i] = TYPE_DOMAIN (inner_type);
2738 for (i = 0, inner_type = type;
2740 i++, inner_type = TREE_TYPE (inner_type))
2741 idx_arr[i] = TYPE_DOMAIN (inner_type);
2743 /* Now get the DTYPE value. */
2744 switch (TREE_CODE (type))
2749 if (TYPE_VAX_FLOATING_POINT_P (type))
2750 switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2763 switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
2766 dtype = TYPE_UNSIGNED (type) ? 2 : 6;
2769 dtype = TYPE_UNSIGNED (type) ? 3 : 7;
2772 dtype = TYPE_UNSIGNED (type) ? 4 : 8;
2775 dtype = TYPE_UNSIGNED (type) ? 5 : 9;
2778 dtype = TYPE_UNSIGNED (type) ? 25 : 26;
2784 dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
2788 if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
2789 && TYPE_VAX_FLOATING_POINT_P (type))
2790 switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2802 dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
2813 /* Get the CLASS value. */
2816 case By_Descriptor_A:
2819 case By_Descriptor_NCA:
2822 case By_Descriptor_SB:
2826 case By_Descriptor_S:
2832 /* Make the type for a 64-bit descriptor for VMS. The first six fields
2833 are the same for all types. */
2835 = make_descriptor_field ("MBO", gnat_type_for_size (16, 1),
2836 record_type, size_int (1), field_list);
2838 = make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1),
2839 record_type, size_int (dtype), field_list);
2841 = make_descriptor_field ("CLASS", gnat_type_for_size (8, 1),
2842 record_type, size_int (klass), field_list);
2844 = make_descriptor_field ("MBMO", gnat_type_for_size (32, 1),
2845 record_type, ssize_int (-1), field_list);
2847 = make_descriptor_field ("LENGTH", gnat_type_for_size (64, 1),
2849 size_in_bytes (mech == By_Descriptor_A
2850 ? inner_type : type),
2853 pointer64_type = build_pointer_type_for_mode (type, DImode, false);
2856 = make_descriptor_field ("POINTER", pointer64_type, record_type,
2857 build_unary_op (ADDR_EXPR, pointer64_type,
2858 build0 (PLACEHOLDER_EXPR, type)),
2864 case By_Descriptor_S:
2867 case By_Descriptor_SB:
2869 = make_descriptor_field ("SB_L1", gnat_type_for_size (64, 1),
2871 (TREE_CODE (type) == ARRAY_TYPE
2872 ? TYPE_MIN_VALUE (TYPE_DOMAIN (type))
2876 = make_descriptor_field ("SB_U1", gnat_type_for_size (64, 1),
2878 (TREE_CODE (type) == ARRAY_TYPE
2879 ? TYPE_MAX_VALUE (TYPE_DOMAIN (type))
2884 case By_Descriptor_A:
2885 case By_Descriptor_NCA:
2887 = make_descriptor_field ("SCALE", gnat_type_for_size (8, 1),
2888 record_type, size_zero_node, field_list);
2891 = make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1),
2892 record_type, size_zero_node, field_list);
2894 dtype = (mech == By_Descriptor_NCA
2896 /* Set FL_COLUMN, FL_COEFF, and
2898 : (TREE_CODE (type) == ARRAY_TYPE
2899 && TYPE_CONVENTION_FORTRAN_P (type)
2902 = make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1),
2903 record_type, size_int (dtype),
2907 = make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1),
2908 record_type, size_int (ndim), field_list);
2911 = make_descriptor_field ("MBZ", gnat_type_for_size (32, 1),
2912 record_type, size_int (0), field_list);
2914 = make_descriptor_field ("ARSIZE", gnat_type_for_size (64, 1),
2915 record_type, size_in_bytes (type),
2918 /* Now build a pointer to the 0,0,0... element. */
2919 tem = build0 (PLACEHOLDER_EXPR, type);
2920 for (i = 0, inner_type = type; i < ndim;
2921 i++, inner_type = TREE_TYPE (inner_type))
2922 tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
2923 convert (TYPE_DOMAIN (inner_type), size_zero_node),
2924 NULL_TREE, NULL_TREE);
2927 = make_descriptor_field ("A0", pointer64_type, record_type,
2928 build1 (ADDR_EXPR, pointer64_type, tem),
2931 /* Next come the addressing coefficients. */
2932 tem = size_one_node;
2933 for (i = 0; i < ndim; i++)
2937 = size_binop (MULT_EXPR, tem,
2938 size_binop (PLUS_EXPR,
2939 size_binop (MINUS_EXPR,
2940 TYPE_MAX_VALUE (idx_arr[i]),
2941 TYPE_MIN_VALUE (idx_arr[i])),
2944 fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
2945 fname[1] = '0' + i, fname[2] = 0;
2947 = make_descriptor_field (fname, gnat_type_for_size (64, 1),
2948 record_type, idx_length, field_list);
2950 if (mech == By_Descriptor_NCA)
2954 /* Finally here are the bounds. */
2955 for (i = 0; i < ndim; i++)
2959 fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
2961 = make_descriptor_field (fname, gnat_type_for_size (64, 1),
2963 TYPE_MIN_VALUE (idx_arr[i]), field_list);
2967 = make_descriptor_field (fname, gnat_type_for_size (64, 1),
2969 TYPE_MAX_VALUE (idx_arr[i]), field_list);
2974 post_error ("unsupported descriptor type for &", gnat_entity);
2977 TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC64");
2978 finish_record_type (record_type, nreverse (field_list), 0, false);
2982 /* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result.
2983 GNAT_ACTUAL is the actual parameter for which the descriptor is built. */
2986 fill_vms_descriptor (tree gnu_type, tree gnu_expr, Node_Id gnat_actual)
2988 VEC(constructor_elt,gc) *v = NULL;
2991 gnu_expr = maybe_unconstrained_array (gnu_expr);
2992 gnu_expr = gnat_protect_expr (gnu_expr);
2993 gnat_mark_addressable (gnu_expr);
2995 /* We may need to substitute both GNU_EXPR and a CALL_EXPR to the raise CE
2996 routine in case we have a 32-bit descriptor. */
2997 gnu_expr = build2 (COMPOUND_EXPR, void_type_node,
2998 build_call_raise (CE_Range_Check_Failed, gnat_actual,
2999 N_Raise_Constraint_Error),
3002 for (field = TYPE_FIELDS (gnu_type); field; field = DECL_CHAIN (field))
3005 = convert (TREE_TYPE (field),
3006 SUBSTITUTE_PLACEHOLDER_IN_EXPR (DECL_INITIAL (field),
3008 CONSTRUCTOR_APPEND_ELT (v, field, value);
3011 return gnat_build_constructor (gnu_type, v);
3014 /* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a
3015 regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to
3016 which the VMS descriptor is passed. */
3019 convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
3021 tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
3022 tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
3023 /* The CLASS field is the 3rd field in the descriptor. */
3024 tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type)));
3025 /* The POINTER field is the 6th field in the descriptor. */
3026 tree pointer = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (klass)));
3028 /* Retrieve the value of the POINTER field. */
3030 = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
3032 if (POINTER_TYPE_P (gnu_type))
3033 return convert (gnu_type, gnu_expr64);
3035 else if (TYPE_IS_FAT_POINTER_P (gnu_type))
3037 tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3038 tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
3039 tree template_type = TREE_TYPE (p_bounds_type);
3040 tree min_field = TYPE_FIELDS (template_type);
3041 tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type));
3042 tree template_tree, template_addr, aflags, dimct, t, u;
3043 /* See the head comment of build_vms_descriptor. */
3044 int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
3045 tree lfield, ufield;
3046 VEC(constructor_elt,gc) *v;
3048 /* Convert POINTER to the pointer-to-array type. */
3049 gnu_expr64 = convert (p_array_type, gnu_expr64);
3053 case 1: /* Class S */
3054 case 15: /* Class SB */
3055 /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */
3056 v = VEC_alloc (constructor_elt, gc, 2);
3057 t = DECL_CHAIN (DECL_CHAIN (klass));
3058 t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3059 CONSTRUCTOR_APPEND_ELT (v, min_field,
3060 convert (TREE_TYPE (min_field),
3062 CONSTRUCTOR_APPEND_ELT (v, max_field,
3063 convert (TREE_TYPE (max_field), t));
3064 template_tree = gnat_build_constructor (template_type, v);
3065 template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree);
3067 /* For class S, we are done. */
3071 /* Test that we really have a SB descriptor, like DEC Ada. */
3072 t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL);
3073 u = convert (TREE_TYPE (klass), DECL_INITIAL (klass));
3074 u = build_binary_op (EQ_EXPR, boolean_type_node, t, u);
3075 /* If so, there is already a template in the descriptor and
3076 it is located right after the POINTER field. The fields are
3077 64bits so they must be repacked. */
3078 t = TREE_CHAIN (pointer);
3079 lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3080 lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
3083 ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3085 (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield);
3087 /* Build the template in the form of a constructor. */
3088 v = VEC_alloc (constructor_elt, gc, 2);
3089 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield);
3090 CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (template_type)),
3092 template_tree = gnat_build_constructor (template_type, v);
3094 /* Otherwise use the {1, LENGTH} template we build above. */
3095 template_addr = build3 (COND_EXPR, p_bounds_type, u,
3096 build_unary_op (ADDR_EXPR, p_bounds_type,
3101 case 4: /* Class A */
3102 /* The AFLAGS field is the 3rd field after the pointer in the
3104 t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer)));
3105 aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3106 /* The DIMCT field is the next field in the descriptor after
3109 dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3110 /* Raise CONSTRAINT_ERROR if either more than 1 dimension
3111 or FL_COEFF or FL_BOUNDS not set. */
3112 u = build_int_cst (TREE_TYPE (aflags), 192);
3113 u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node,
3114 build_binary_op (NE_EXPR, boolean_type_node,
3116 convert (TREE_TYPE (dimct),
3118 build_binary_op (NE_EXPR, boolean_type_node,
3119 build2 (BIT_AND_EXPR,
3123 /* There is already a template in the descriptor and it is located
3124 in block 3. The fields are 64bits so they must be repacked. */
3125 t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN
3127 lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3128 lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
3131 ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3133 (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield);
3135 /* Build the template in the form of a constructor. */
3136 v = VEC_alloc (constructor_elt, gc, 2);
3137 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield);
3138 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (template_type)),
3140 template_tree = gnat_build_constructor (template_type, v);
3141 template_tree = build3 (COND_EXPR, template_type, u,
3142 build_call_raise (CE_Length_Check_Failed, Empty,
3143 N_Raise_Constraint_Error),
3146 = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree);
3149 case 10: /* Class NCA */
3151 post_error ("unsupported descriptor type for &", gnat_subprog);
3152 template_addr = integer_zero_node;
3156 /* Build the fat pointer in the form of a constructor. */
3157 v = VEC_alloc (constructor_elt, gc, 2);
3158 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr64);
3159 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)),
3161 return gnat_build_constructor (gnu_type, v);
3168 /* Convert GNU_EXPR, a pointer to a 32bit VMS descriptor, to GNU_TYPE, a
3169 regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to
3170 which the VMS descriptor is passed. */
3173 convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
3175 tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
3176 tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
3177 /* The CLASS field is the 3rd field in the descriptor. */
3178 tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type)));
3179 /* The POINTER field is the 4th field in the descriptor. */
3180 tree pointer = DECL_CHAIN (klass);
3182 /* Retrieve the value of the POINTER field. */
3184 = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
3186 if (POINTER_TYPE_P (gnu_type))
3187 return convert (gnu_type, gnu_expr32);
3189 else if (TYPE_IS_FAT_POINTER_P (gnu_type))
3191 tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3192 tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
3193 tree template_type = TREE_TYPE (p_bounds_type);
3194 tree min_field = TYPE_FIELDS (template_type);
3195 tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type));
3196 tree template_tree, template_addr, aflags, dimct, t, u;
3197 /* See the head comment of build_vms_descriptor. */
3198 int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
3199 VEC(constructor_elt,gc) *v;
3201 /* Convert POINTER to the pointer-to-array type. */
3202 gnu_expr32 = convert (p_array_type, gnu_expr32);
3206 case 1: /* Class S */
3207 case 15: /* Class SB */
3208 /* Build {1, LENGTH} template; LENGTH is the 1st field. */
3209 v = VEC_alloc (constructor_elt, gc, 2);
3210 t = TYPE_FIELDS (desc_type);
3211 t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3212 CONSTRUCTOR_APPEND_ELT (v, min_field,
3213 convert (TREE_TYPE (min_field),
3215 CONSTRUCTOR_APPEND_ELT (v, max_field,
3216 convert (TREE_TYPE (max_field), t));
3217 template_tree = gnat_build_constructor (template_type, v);
3218 template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree);
3220 /* For class S, we are done. */
3224 /* Test that we really have a SB descriptor, like DEC Ada. */
3225 t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL);
3226 u = convert (TREE_TYPE (klass), DECL_INITIAL (klass));
3227 u = build_binary_op (EQ_EXPR, boolean_type_node, t, u);
3228 /* If so, there is already a template in the descriptor and
3229 it is located right after the POINTER field. */
3230 t = TREE_CHAIN (pointer);
3232 = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3233 /* Otherwise use the {1, LENGTH} template we build above. */
3234 template_addr = build3 (COND_EXPR, p_bounds_type, u,
3235 build_unary_op (ADDR_EXPR, p_bounds_type,
3240 case 4: /* Class A */
3241 /* The AFLAGS field is the 7th field in the descriptor. */
3242 t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer)));
3243 aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3244 /* The DIMCT field is the 8th field in the descriptor. */
3246 dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3247 /* Raise CONSTRAINT_ERROR if either more than 1 dimension
3248 or FL_COEFF or FL_BOUNDS not set. */
3249 u = build_int_cst (TREE_TYPE (aflags), 192);
3250 u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node,
3251 build_binary_op (NE_EXPR, boolean_type_node,
3253 convert (TREE_TYPE (dimct),
3255 build_binary_op (NE_EXPR, boolean_type_node,
3256 build2 (BIT_AND_EXPR,
3260 /* There is already a template in the descriptor and it is
3261 located at the start of block 3 (12th field). */
3262 t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (t))));
3264 = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3265 template_tree = build3 (COND_EXPR, TREE_TYPE (t), u,
3266 build_call_raise (CE_Length_Check_Failed, Empty,
3267 N_Raise_Constraint_Error),
3270 = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree);
3273 case 10: /* Class NCA */
3275 post_error ("unsupported descriptor type for &", gnat_subprog);
3276 template_addr = integer_zero_node;
3280 /* Build the fat pointer in the form of a constructor. */
3281 v = VEC_alloc (constructor_elt, gc, 2);
3282 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr32);
3283 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)),
3286 return gnat_build_constructor (gnu_type, v);
3293 /* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular
3294 pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit)
3295 pointer type of GNU_EXPR. BY_REF is true if the result is to be used by
3296 reference. GNAT_SUBPROG is the subprogram to which the VMS descriptor is
3300 convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type,
3301 bool by_ref, Entity_Id gnat_subprog)
3303 tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
3304 tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
3305 tree mbo = TYPE_FIELDS (desc_type);
3306 const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo));
3307 tree mbmo = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (mbo)));
3308 tree real_type, is64bit, gnu_expr32, gnu_expr64;
3311 real_type = TREE_TYPE (gnu_type);
3313 real_type = gnu_type;
3315 /* If the field name is not MBO, it must be 32-bit and no alternate.
3316 Otherwise primary must be 64-bit and alternate 32-bit. */
3317 if (strcmp (mbostr, "MBO") != 0)
3319 tree ret = convert_vms_descriptor32 (real_type, gnu_expr, gnat_subprog);
3321 ret = build_unary_op (ADDR_EXPR, gnu_type, ret);
3325 /* Build the test for 64-bit descriptor. */
3326 mbo = build3 (COMPONENT_REF, TREE_TYPE (mbo), desc, mbo, NULL_TREE);
3327 mbmo = build3 (COMPONENT_REF, TREE_TYPE (mbmo), desc, mbmo, NULL_TREE);
3329 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
3330 build_binary_op (EQ_EXPR, boolean_type_node,
3331 convert (integer_type_node, mbo),
3333 build_binary_op (EQ_EXPR, boolean_type_node,
3334 convert (integer_type_node, mbmo),
3335 integer_minus_one_node));
3337 /* Build the 2 possible end results. */
3338 gnu_expr64 = convert_vms_descriptor64 (real_type, gnu_expr, gnat_subprog);
3340 gnu_expr64 = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr64);
3341 gnu_expr = fold_convert (gnu_expr_alt_type, gnu_expr);
3342 gnu_expr32 = convert_vms_descriptor32 (real_type, gnu_expr, gnat_subprog);
3344 gnu_expr32 = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr32);
3346 return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32);
3349 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
3350 and the GNAT node GNAT_SUBPROG. */
3353 build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
3355 tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
3356 tree gnu_subprog_param, gnu_stub_param, gnu_param;
3357 tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
3358 VEC(tree,gc) *gnu_param_vec = NULL;
3360 gnu_subprog_type = TREE_TYPE (gnu_subprog);
3362 /* Initialize the information structure for the function. */
3363 allocate_struct_function (gnu_stub_decl, false);
3366 begin_subprog_body (gnu_stub_decl);
3368 start_stmt_group ();
3371 /* Loop over the parameters of the stub and translate any of them
3372 passed by descriptor into a by reference one. */
3373 for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
3374 gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog);
3376 gnu_stub_param = TREE_CHAIN (gnu_stub_param),
3377 gnu_subprog_param = TREE_CHAIN (gnu_subprog_param))
3379 if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
3381 gcc_assert (DECL_BY_REF_P (gnu_subprog_param));
3383 = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param),
3385 DECL_PARM_ALT_TYPE (gnu_stub_param),
3386 DECL_BY_DOUBLE_REF_P (gnu_subprog_param),
3390 gnu_param = gnu_stub_param;
3392 VEC_safe_push (tree, gc, gnu_param_vec, gnu_param);
3395 /* Invoke the internal subprogram. */
3396 gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type),
3398 gnu_subprog_call = build_call_vec (TREE_TYPE (gnu_subprog_type),
3399 gnu_subprog_addr, gnu_param_vec);
3401 /* Propagate the return value, if any. */
3402 if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type)))
3403 add_stmt (gnu_subprog_call);
3405 add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl),
3409 end_subprog_body (end_stmt_group ());
3412 /* Build a type to be used to represent an aliased object whose nominal type
3413 is an unconstrained array. This consists of a RECORD_TYPE containing a
3414 field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE.
3415 If ARRAY_TYPE is that of an unconstrained array, this is used to represent
3416 an arbitrary unconstrained object. Use NAME as the name of the record.
3417 DEBUG_INFO_P is true if we need to write debug information for the type. */
3420 build_unc_object_type (tree template_type, tree object_type, tree name,
3423 tree type = make_node (RECORD_TYPE);
3425 = create_field_decl (get_identifier ("BOUNDS"), template_type, type,
3426 NULL_TREE, NULL_TREE, 0, 1);
3428 = create_field_decl (get_identifier ("ARRAY"), object_type, type,
3429 NULL_TREE, NULL_TREE, 0, 1);
3431 TYPE_NAME (type) = name;
3432 TYPE_CONTAINS_TEMPLATE_P (type) = 1;
3433 DECL_CHAIN (template_field) = array_field;
3434 finish_record_type (type, template_field, 0, true);
3436 /* Declare it now since it will never be declared otherwise. This is
3437 necessary to ensure that its subtrees are properly marked. */
3438 create_type_decl (name, type, NULL, true, debug_info_p, Empty);
3443 /* Same, taking a thin or fat pointer type instead of a template type. */
3446 build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
3447 tree name, bool debug_info_p)
3451 gcc_assert (TYPE_IS_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
3454 = (TYPE_IS_FAT_POINTER_P (thin_fat_ptr_type)
3455 ? TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (thin_fat_ptr_type))))
3456 : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type))));
3459 build_unc_object_type (template_type, object_type, name, debug_info_p);
3462 /* Shift the component offsets within an unconstrained object TYPE to make it
3463 suitable for use as a designated type for thin pointers. */
3466 shift_unc_components_for_thin_pointers (tree type)
3468 /* Thin pointer values designate the ARRAY data of an unconstrained object,
3469 allocated past the BOUNDS template. The designated type is adjusted to
3470 have ARRAY at position zero and the template at a negative offset, so
3471 that COMPONENT_REFs on (*thin_ptr) designate the proper location. */
3473 tree bounds_field = TYPE_FIELDS (type);
3474 tree array_field = DECL_CHAIN (TYPE_FIELDS (type));
3476 DECL_FIELD_OFFSET (bounds_field)
3477 = size_binop (MINUS_EXPR, size_zero_node, byte_position (array_field));
3479 DECL_FIELD_OFFSET (array_field) = size_zero_node;
3480 DECL_FIELD_BIT_OFFSET (array_field) = bitsize_zero_node;
3483 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.
3484 In the normal case this is just two adjustments, but we have more to
3485 do if NEW_TYPE is an UNCONSTRAINED_ARRAY_TYPE. */
3488 update_pointer_to (tree old_type, tree new_type)
3490 tree ptr = TYPE_POINTER_TO (old_type);
3491 tree ref = TYPE_REFERENCE_TO (old_type);
3494 /* If this is the main variant, process all the other variants first. */
3495 if (TYPE_MAIN_VARIANT (old_type) == old_type)
3496 for (t = TYPE_NEXT_VARIANT (old_type); t; t = TYPE_NEXT_VARIANT (t))
3497 update_pointer_to (t, new_type);
3499 /* If no pointers and no references, we are done. */
3503 /* Merge the old type qualifiers in the new type.
3505 Each old variant has qualifiers for specific reasons, and the new
3506 designated type as well. Each set of qualifiers represents useful
3507 information grabbed at some point, and merging the two simply unifies
3508 these inputs into the final type description.
3510 Consider for instance a volatile type frozen after an access to constant
3511 type designating it; after the designated type's freeze, we get here with
3512 a volatile NEW_TYPE and a dummy OLD_TYPE with a readonly variant, created
3513 when the access type was processed. We will make a volatile and readonly
3514 designated type, because that's what it really is.
3516 We might also get here for a non-dummy OLD_TYPE variant with different
3517 qualifiers than those of NEW_TYPE, for instance in some cases of pointers
3518 to private record type elaboration (see the comments around the call to
3519 this routine in gnat_to_gnu_entity <E_Access_Type>). We have to merge
3520 the qualifiers in those cases too, to avoid accidentally discarding the
3521 initial set, and will often end up with OLD_TYPE == NEW_TYPE then. */
3523 = build_qualified_type (new_type,
3524 TYPE_QUALS (old_type) | TYPE_QUALS (new_type));
3526 /* If old type and new type are identical, there is nothing to do. */
3527 if (old_type == new_type)
3530 /* Otherwise, first handle the simple case. */
3531 if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
3533 tree new_ptr, new_ref;
3535 /* If pointer or reference already points to new type, nothing to do.
3536 This can happen as update_pointer_to can be invoked multiple times
3537 on the same couple of types because of the type variants. */
3538 if ((ptr && TREE_TYPE (ptr) == new_type)
3539 || (ref && TREE_TYPE (ref) == new_type))
3542 /* Chain PTR and its variants at the end. */
3543 new_ptr = TYPE_POINTER_TO (new_type);
3546 while (TYPE_NEXT_PTR_TO (new_ptr))
3547 new_ptr = TYPE_NEXT_PTR_TO (new_ptr);
3548 TYPE_NEXT_PTR_TO (new_ptr) = ptr;
3551 TYPE_POINTER_TO (new_type) = ptr;
3553 /* Now adjust them. */
3554 for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr))
3555 for (t = TYPE_MAIN_VARIANT (ptr); t; t = TYPE_NEXT_VARIANT (t))
3556 TREE_TYPE (t) = new_type;
3558 /* If we have adjusted named types, finalize them. This is necessary
3559 since we had forced a DWARF typedef for them in gnat_pushdecl. */
3560 for (ptr = TYPE_POINTER_TO (old_type); ptr; ptr = TYPE_NEXT_PTR_TO (ptr))
3561 if (TYPE_NAME (ptr) && TREE_CODE (TYPE_NAME (ptr)) == TYPE_DECL)
3562 rest_of_type_decl_compilation (TYPE_NAME (ptr));
3564 /* Chain REF and its variants at the end. */
3565 new_ref = TYPE_REFERENCE_TO (new_type);
3568 while (TYPE_NEXT_REF_TO (new_ref))
3569 new_ref = TYPE_NEXT_REF_TO (new_ref);
3570 TYPE_NEXT_REF_TO (new_ref) = ref;
3573 TYPE_REFERENCE_TO (new_type) = ref;
3575 /* Now adjust them. */
3576 for (; ref; ref = TYPE_NEXT_REF_TO (ref))
3577 for (t = TYPE_MAIN_VARIANT (ref); t; t = TYPE_NEXT_VARIANT (t))
3578 TREE_TYPE (t) = new_type;
3580 TYPE_POINTER_TO (old_type) = NULL_TREE;
3581 TYPE_REFERENCE_TO (old_type) = NULL_TREE;
3584 /* Now deal with the unconstrained array case. In this case the pointer
3585 is actually a record where both fields are pointers to dummy nodes.
3586 Turn them into pointers to the correct types using update_pointer_to.
3587 Likewise for the pointer to the object record (thin pointer). */
3590 tree new_ptr = TYPE_POINTER_TO (new_type);
3592 gcc_assert (TYPE_IS_FAT_POINTER_P (ptr));
3594 /* If PTR already points to NEW_TYPE, nothing to do. This can happen
3595 since update_pointer_to can be invoked multiple times on the same
3596 couple of types because of the type variants. */
3597 if (TYPE_UNCONSTRAINED_ARRAY (ptr) == new_type)
3601 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
3602 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr))));
3605 (TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (ptr)))),
3606 TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (new_ptr)))));
3608 update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type),
3609 TYPE_OBJECT_RECORD_TYPE (new_type));
3611 TYPE_POINTER_TO (old_type) = NULL_TREE;
3615 /* Convert EXPR, a pointer to a constrained array, into a pointer to an
3616 unconstrained one. This involves making or finding a template. */
3619 convert_to_fat_pointer (tree type, tree expr)
3621 tree template_type = TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))));
3622 tree p_array_type = TREE_TYPE (TYPE_FIELDS (type));
3623 tree etype = TREE_TYPE (expr);
3625 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
3627 /* If EXPR is null, make a fat pointer that contains null pointers to the
3628 template and array. */
3629 if (integer_zerop (expr))
3631 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
3632 convert (p_array_type, expr));
3633 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
3634 convert (build_pointer_type (template_type),
3636 return gnat_build_constructor (type, v);
3639 /* If EXPR is a thin pointer, make template and data from the record.. */
3640 else if (TYPE_IS_THIN_POINTER_P (etype))
3642 tree fields = TYPE_FIELDS (TREE_TYPE (etype));
3644 expr = gnat_protect_expr (expr);
3645 if (TREE_CODE (expr) == ADDR_EXPR)
3646 expr = TREE_OPERAND (expr, 0);
3648 expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
3650 template_tree = build_component_ref (expr, NULL_TREE, fields, false);
3651 expr = build_unary_op (ADDR_EXPR, NULL_TREE,
3652 build_component_ref (expr, NULL_TREE,
3653 DECL_CHAIN (fields), false));
3656 /* Otherwise, build the constructor for the template. */
3658 template_tree = build_template (template_type, TREE_TYPE (etype), expr);
3660 /* The final result is a constructor for the fat pointer.
3662 If EXPR is an argument of a foreign convention subprogram, the type it
3663 points to is directly the component type. In this case, the expression
3664 type may not match the corresponding FIELD_DECL type at this point, so we
3665 call "convert" here to fix that up if necessary. This type consistency is
3666 required, for instance because it ensures that possible later folding of
3667 COMPONENT_REFs against this constructor always yields something of the
3668 same type as the initial reference.
3670 Note that the call to "build_template" above is still fine because it
3671 will only refer to the provided TEMPLATE_TYPE in this case. */
3672 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
3673 convert (p_array_type, expr));
3674 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
3675 build_unary_op (ADDR_EXPR, NULL_TREE,
3677 return gnat_build_constructor (type, v);
3680 /* Convert to a thin pointer type, TYPE. The only thing we know how to convert
3681 is something that is a fat pointer, so convert to it first if it EXPR
3682 is not already a fat pointer. */
3685 convert_to_thin_pointer (tree type, tree expr)
3687 if (!TYPE_IS_FAT_POINTER_P (TREE_TYPE (expr)))
3689 = convert_to_fat_pointer
3690 (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr);
3692 /* We get the pointer to the data and use a NOP_EXPR to make it the
3694 expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)),
3696 expr = build1 (NOP_EXPR, type, expr);
3701 /* Create an expression whose value is that of EXPR,
3702 converted to type TYPE. The TREE_TYPE of the value
3703 is always TYPE. This function implements all reasonable
3704 conversions; callers should filter out those that are
3705 not permitted by the language being compiled. */
3708 convert (tree type, tree expr)
3710 tree etype = TREE_TYPE (expr);
3711 enum tree_code ecode = TREE_CODE (etype);
3712 enum tree_code code = TREE_CODE (type);
3714 /* If the expression is already of the right type, we are done. */
3718 /* If both input and output have padding and are of variable size, do this
3719 as an unchecked conversion. Likewise if one is a mere variant of the
3720 other, so we avoid a pointless unpad/repad sequence. */
3721 else if (code == RECORD_TYPE && ecode == RECORD_TYPE
3722 && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype)
3723 && (!TREE_CONSTANT (TYPE_SIZE (type))
3724 || !TREE_CONSTANT (TYPE_SIZE (etype))
3725 || gnat_types_compatible_p (type, etype)
3726 || TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type)))
3727 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (etype)))))
3730 /* If the output type has padding, convert to the inner type and make a
3731 constructor to build the record, unless a variable size is involved. */
3732 else if (code == RECORD_TYPE && TYPE_PADDING_P (type))
3734 VEC(constructor_elt,gc) *v;
3736 /* If we previously converted from another type and our type is
3737 of variable size, remove the conversion to avoid the need for
3738 variable-sized temporaries. Likewise for a conversion between
3739 original and packable version. */
3740 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
3741 && (!TREE_CONSTANT (TYPE_SIZE (type))
3742 || (ecode == RECORD_TYPE
3743 && TYPE_NAME (etype)
3744 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (expr, 0))))))
3745 expr = TREE_OPERAND (expr, 0);
3747 /* If we are just removing the padding from expr, convert the original
3748 object if we have variable size in order to avoid the need for some
3749 variable-sized temporaries. Likewise if the padding is a variant
3750 of the other, so we avoid a pointless unpad/repad sequence. */
3751 if (TREE_CODE (expr) == COMPONENT_REF
3752 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
3753 && (!TREE_CONSTANT (TYPE_SIZE (type))
3754 || gnat_types_compatible_p (type,
3755 TREE_TYPE (TREE_OPERAND (expr, 0)))
3756 || (ecode == RECORD_TYPE
3757 && TYPE_NAME (etype)
3758 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type))))))
3759 return convert (type, TREE_OPERAND (expr, 0));
3761 /* If the inner type is of self-referential size and the expression type
3762 is a record, do this as an unchecked conversion. But first pad the
3763 expression if possible to have the same size on both sides. */
3764 if (ecode == RECORD_TYPE
3765 && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
3767 if (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST)
3768 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
3769 false, false, false, true),
3771 return unchecked_convert (type, expr, false);
3774 /* If we are converting between array types with variable size, do the
3775 final conversion as an unchecked conversion, again to avoid the need
3776 for some variable-sized temporaries. If valid, this conversion is
3777 very likely purely technical and without real effects. */
3778 if (ecode == ARRAY_TYPE
3779 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == ARRAY_TYPE
3780 && !TREE_CONSTANT (TYPE_SIZE (etype))
3781 && !TREE_CONSTANT (TYPE_SIZE (type)))
3782 return unchecked_convert (type,
3783 convert (TREE_TYPE (TYPE_FIELDS (type)),
3787 v = VEC_alloc (constructor_elt, gc, 1);
3788 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
3789 convert (TREE_TYPE (TYPE_FIELDS (type)), expr));
3790 return gnat_build_constructor (type, v);
3793 /* If the input type has padding, remove it and convert to the output type.
3794 The conditions ordering is arranged to ensure that the output type is not
3795 a padding type here, as it is not clear whether the conversion would
3796 always be correct if this was to happen. */
3797 else if (ecode == RECORD_TYPE && TYPE_PADDING_P (etype))
3801 /* If we have just converted to this padded type, just get the
3802 inner expression. */
3803 if (TREE_CODE (expr) == CONSTRUCTOR
3804 && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr))
3805 && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index
3806 == TYPE_FIELDS (etype))
3808 = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value;
3810 /* Otherwise, build an explicit component reference. */
3813 = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false);
3815 return convert (type, unpadded);
3818 /* If the input is a biased type, adjust first. */
3819 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
3820 return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype),
3821 fold_convert (TREE_TYPE (etype),
3823 TYPE_MIN_VALUE (etype)));
3825 /* If the input is a justified modular type, we need to extract the actual
3826 object before converting it to any other type with the exceptions of an
3827 unconstrained array or of a mere type variant. It is useful to avoid the
3828 extraction and conversion in the type variant case because it could end
3829 up replacing a VAR_DECL expr by a constructor and we might be about the
3830 take the address of the result. */
3831 if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
3832 && code != UNCONSTRAINED_ARRAY_TYPE
3833 && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype))
3834 return convert (type, build_component_ref (expr, NULL_TREE,
3835 TYPE_FIELDS (etype), false));
3837 /* If converting to a type that contains a template, convert to the data
3838 type and then build the template. */
3839 if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type))
3841 tree obj_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)));
3842 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2);
3844 /* If the source already has a template, get a reference to the
3845 associated array only, as we are going to rebuild a template
3846 for the target type anyway. */
3847 expr = maybe_unconstrained_array (expr);
3849 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
3850 build_template (TREE_TYPE (TYPE_FIELDS (type)),
3851 obj_type, NULL_TREE));
3852 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)),
3853 convert (obj_type, expr));
3854 return gnat_build_constructor (type, v);
3857 /* There are some special cases of expressions that we process
3859 switch (TREE_CODE (expr))
3865 /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
3866 conversion in gnat_expand_expr. NULL_EXPR does not represent
3867 and actual value, so no conversion is needed. */
3868 expr = copy_node (expr);
3869 TREE_TYPE (expr) = type;
3873 /* If we are converting a STRING_CST to another constrained array type,
3874 just make a new one in the proper type. */
3875 if (code == ecode && AGGREGATE_TYPE_P (etype)
3876 && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
3877 && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
3879 expr = copy_node (expr);
3880 TREE_TYPE (expr) = type;
3886 /* If we are converting a VECTOR_CST to a mere variant type, just make
3887 a new one in the proper type. */
3888 if (code == ecode && gnat_types_compatible_p (type, etype))
3890 expr = copy_node (expr);
3891 TREE_TYPE (expr) = type;
3896 /* If we are converting a CONSTRUCTOR to a mere variant type, just make
3897 a new one in the proper type. */
3898 if (code == ecode && gnat_types_compatible_p (type, etype))
3900 expr = copy_node (expr);
3901 TREE_TYPE (expr) = type;
3905 /* Likewise for a conversion between original and packable version, or
3906 conversion between types of the same size and with the same list of
3907 fields, but we have to work harder to preserve type consistency. */
3909 && code == RECORD_TYPE
3910 && (TYPE_NAME (type) == TYPE_NAME (etype)
3911 || tree_int_cst_equal (TYPE_SIZE (type), TYPE_SIZE (etype))))
3914 VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr);
3915 unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e);
3916 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, len);
3917 tree efield = TYPE_FIELDS (etype), field = TYPE_FIELDS (type);
3918 unsigned HOST_WIDE_INT idx;
3921 /* Whether we need to clear TREE_CONSTANT et al. on the output
3922 constructor when we convert in place. */
3923 bool clear_constant = false;
3925 FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value)
3927 constructor_elt *elt;
3928 /* We expect only simple constructors. */
3929 if (!SAME_FIELD_P (index, efield))
3931 /* The field must be the same. */
3932 if (!SAME_FIELD_P (efield, field))
3934 elt = VEC_quick_push (constructor_elt, v, NULL);
3936 elt->value = convert (TREE_TYPE (field), value);
3938 /* If packing has made this field a bitfield and the input
3939 value couldn't be emitted statically any more, we need to
3940 clear TREE_CONSTANT on our output. */
3942 && TREE_CONSTANT (expr)
3943 && !CONSTRUCTOR_BITFIELD_P (efield)
3944 && CONSTRUCTOR_BITFIELD_P (field)
3945 && !initializer_constant_valid_for_bitfield_p (value))
3946 clear_constant = true;
3948 efield = DECL_CHAIN (efield);
3949 field = DECL_CHAIN (field);
3952 /* If we have been able to match and convert all the input fields
3953 to their output type, convert in place now. We'll fallback to a
3954 view conversion downstream otherwise. */
3957 expr = copy_node (expr);
3958 TREE_TYPE (expr) = type;
3959 CONSTRUCTOR_ELTS (expr) = v;
3961 TREE_CONSTANT (expr) = TREE_STATIC (expr) = 0;
3966 /* Likewise for a conversion between array type and vector type with a
3967 compatible representative array. */
3968 else if (code == VECTOR_TYPE
3969 && ecode == ARRAY_TYPE
3970 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
3973 VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr);
3974 unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e);
3975 VEC(constructor_elt,gc) *v;
3976 unsigned HOST_WIDE_INT ix;
3979 /* Build a VECTOR_CST from a *constant* array constructor. */
3980 if (TREE_CONSTANT (expr))
3982 bool constant_p = true;
3984 /* Iterate through elements and check if all constructor
3985 elements are *_CSTs. */
3986 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
3987 if (!CONSTANT_CLASS_P (value))
3994 return build_vector_from_ctor (type,
3995 CONSTRUCTOR_ELTS (expr));
3998 /* Otherwise, build a regular vector constructor. */
3999 v = VEC_alloc (constructor_elt, gc, len);
4000 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
4002 constructor_elt *elt = VEC_quick_push (constructor_elt, v, NULL);
4003 elt->index = NULL_TREE;
4006 expr = copy_node (expr);
4007 TREE_TYPE (expr) = type;
4008 CONSTRUCTOR_ELTS (expr) = v;
4013 case UNCONSTRAINED_ARRAY_REF:
4014 /* Convert this to the type of the inner array by getting the address of
4015 the array from the template. */
4016 expr = TREE_OPERAND (expr, 0);
4017 expr = build_unary_op (INDIRECT_REF, NULL_TREE,
4018 build_component_ref (expr, NULL_TREE,
4022 etype = TREE_TYPE (expr);
4023 ecode = TREE_CODE (etype);
4026 case VIEW_CONVERT_EXPR:
4028 /* GCC 4.x is very sensitive to type consistency overall, and view
4029 conversions thus are very frequent. Even though just "convert"ing
4030 the inner operand to the output type is fine in most cases, it
4031 might expose unexpected input/output type mismatches in special
4032 circumstances so we avoid such recursive calls when we can. */
4033 tree op0 = TREE_OPERAND (expr, 0);
4035 /* If we are converting back to the original type, we can just
4036 lift the input conversion. This is a common occurrence with
4037 switches back-and-forth amongst type variants. */
4038 if (type == TREE_TYPE (op0))
4041 /* Otherwise, if we're converting between two aggregate or vector
4042 types, we might be allowed to substitute the VIEW_CONVERT_EXPR
4043 target type in place or to just convert the inner expression. */
4044 if ((AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
4045 || (VECTOR_TYPE_P (type) && VECTOR_TYPE_P (etype)))
4047 /* If we are converting between mere variants, we can just
4048 substitute the VIEW_CONVERT_EXPR in place. */
4049 if (gnat_types_compatible_p (type, etype))
4050 return build1 (VIEW_CONVERT_EXPR, type, op0);
4052 /* Otherwise, we may just bypass the input view conversion unless
4053 one of the types is a fat pointer, which is handled by
4054 specialized code below which relies on exact type matching. */
4055 else if (!TYPE_IS_FAT_POINTER_P (type)
4056 && !TYPE_IS_FAT_POINTER_P (etype))
4057 return convert (type, op0);
4066 /* Check for converting to a pointer to an unconstrained array. */
4067 if (TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype))
4068 return convert_to_fat_pointer (type, expr);
4070 /* If we are converting between two aggregate or vector types that are mere
4071 variants, just make a VIEW_CONVERT_EXPR. Likewise when we are converting
4072 to a vector type from its representative array type. */
4073 else if ((code == ecode
4074 && (AGGREGATE_TYPE_P (type) || VECTOR_TYPE_P (type))
4075 && gnat_types_compatible_p (type, etype))
4076 || (code == VECTOR_TYPE
4077 && ecode == ARRAY_TYPE
4078 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
4080 return build1 (VIEW_CONVERT_EXPR, type, expr);
4082 /* If we are converting between tagged types, try to upcast properly. */
4083 else if (ecode == RECORD_TYPE && code == RECORD_TYPE
4084 && TYPE_ALIGN_OK (etype) && TYPE_ALIGN_OK (type))
4086 tree child_etype = etype;
4088 tree field = TYPE_FIELDS (child_etype);
4089 if (DECL_NAME (field) == parent_name_id && TREE_TYPE (field) == type)
4090 return build_component_ref (expr, NULL_TREE, field, false);
4091 child_etype = TREE_TYPE (field);
4092 } while (TREE_CODE (child_etype) == RECORD_TYPE);
4095 /* If we are converting from a smaller form of record type back to it, just
4096 make a VIEW_CONVERT_EXPR. But first pad the expression to have the same
4097 size on both sides. */
4098 else if (ecode == RECORD_TYPE && code == RECORD_TYPE
4099 && smaller_form_type_p (etype, type))
4101 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
4102 false, false, false, true),
4104 return build1 (VIEW_CONVERT_EXPR, type, expr);
4107 /* In all other cases of related types, make a NOP_EXPR. */
4108 else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
4109 return fold_convert (type, expr);
4114 return fold_build1 (CONVERT_EXPR, type, expr);
4117 if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
4118 && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
4119 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
4120 return unchecked_convert (type, expr, false);
4121 else if (TYPE_BIASED_REPRESENTATION_P (type))
4122 return fold_convert (type,
4123 fold_build2 (MINUS_EXPR, TREE_TYPE (type),
4124 convert (TREE_TYPE (type), expr),
4125 TYPE_MIN_VALUE (type)));
4127 /* ... fall through ... */
4131 /* If we are converting an additive expression to an integer type
4132 with lower precision, be wary of the optimization that can be
4133 applied by convert_to_integer. There are 2 problematic cases:
4134 - if the first operand was originally of a biased type,
4135 because we could be recursively called to convert it
4136 to an intermediate type and thus rematerialize the
4137 additive operator endlessly,
4138 - if the expression contains a placeholder, because an
4139 intermediate conversion that changes the sign could
4140 be inserted and thus introduce an artificial overflow
4141 at compile time when the placeholder is substituted. */
4142 if (code == INTEGER_TYPE
4143 && ecode == INTEGER_TYPE
4144 && TYPE_PRECISION (type) < TYPE_PRECISION (etype)
4145 && (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR))
4147 tree op0 = get_unwidened (TREE_OPERAND (expr, 0), type);
4149 if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE
4150 && TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0)))
4151 || CONTAINS_PLACEHOLDER_P (expr))
4152 return build1 (NOP_EXPR, type, expr);
4155 return fold (convert_to_integer (type, expr));
4158 case REFERENCE_TYPE:
4159 /* If converting between two pointers to records denoting
4160 both a template and type, adjust if needed to account
4161 for any differing offsets, since one might be negative. */
4162 if (TYPE_IS_THIN_POINTER_P (etype) && TYPE_IS_THIN_POINTER_P (type))
4165 = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))),
4166 bit_position (TYPE_FIELDS (TREE_TYPE (type))));
4168 = size_binop (CEIL_DIV_EXPR, bit_diff, sbitsize_unit_node);
4169 expr = build1 (NOP_EXPR, type, expr);
4170 TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0));
4171 if (integer_zerop (byte_diff))
4174 return build_binary_op (POINTER_PLUS_EXPR, type, expr,
4175 fold (convert (sizetype, byte_diff)));
4178 /* If converting to a thin pointer, handle specially. */
4179 if (TYPE_IS_THIN_POINTER_P (type)
4180 && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
4181 return convert_to_thin_pointer (type, expr);
4183 /* If converting fat pointer to normal pointer, get the pointer to the
4184 array and then convert it. */
4185 else if (TYPE_IS_FAT_POINTER_P (etype))
4187 = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false);
4189 return fold (convert_to_pointer (type, expr));
4192 return fold (convert_to_real (type, expr));
4195 if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype))
4197 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1);
4199 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type),
4200 convert (TREE_TYPE (TYPE_FIELDS (type)),
4202 return gnat_build_constructor (type, v);
4205 /* ... fall through ... */
4208 /* In these cases, assume the front-end has validated the conversion.
4209 If the conversion is valid, it will be a bit-wise conversion, so
4210 it can be viewed as an unchecked conversion. */
4211 return unchecked_convert (type, expr, false);
4214 /* This is a either a conversion between a tagged type and some
4215 subtype, which we have to mark as a UNION_TYPE because of
4216 overlapping fields or a conversion of an Unchecked_Union. */
4217 return unchecked_convert (type, expr, false);
4219 case UNCONSTRAINED_ARRAY_TYPE:
4220 /* If the input is a VECTOR_TYPE, convert to the representative
4221 array type first. */
4222 if (ecode == VECTOR_TYPE)
4224 expr = convert (TYPE_REPRESENTATIVE_ARRAY (etype), expr);
4225 etype = TREE_TYPE (expr);
4226 ecode = TREE_CODE (etype);
4229 /* If EXPR is a constrained array, take its address, convert it to a
4230 fat pointer, and then dereference it. Likewise if EXPR is a
4231 record containing both a template and a constrained array.
4232 Note that a record representing a justified modular type
4233 always represents a packed constrained array. */
4234 if (ecode == ARRAY_TYPE
4235 || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
4236 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
4237 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))
4240 (INDIRECT_REF, NULL_TREE,
4241 convert_to_fat_pointer (TREE_TYPE (type),
4242 build_unary_op (ADDR_EXPR,
4245 /* Do something very similar for converting one unconstrained
4246 array to another. */
4247 else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
4249 build_unary_op (INDIRECT_REF, NULL_TREE,
4250 convert (TREE_TYPE (type),
4251 build_unary_op (ADDR_EXPR,
4257 return fold (convert_to_complex (type, expr));
4264 /* Remove all conversions that are done in EXP. This includes converting
4265 from a padded type or to a justified modular type. If TRUE_ADDRESS
4266 is true, always return the address of the containing object even if
4267 the address is not bit-aligned. */
4270 remove_conversions (tree exp, bool true_address)
4272 switch (TREE_CODE (exp))
4276 && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
4277 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
4279 remove_conversions (VEC_index (constructor_elt,
4280 CONSTRUCTOR_ELTS (exp), 0)->value,
4285 if (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
4286 return remove_conversions (TREE_OPERAND (exp, 0), true_address);
4289 case VIEW_CONVERT_EXPR: case NON_LVALUE_EXPR:
4291 return remove_conversions (TREE_OPERAND (exp, 0), true_address);
4300 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
4301 refers to the underlying array. If it has TYPE_CONTAINS_TEMPLATE_P,
4302 likewise return an expression pointing to the underlying array. */
4305 maybe_unconstrained_array (tree exp)
4307 enum tree_code code = TREE_CODE (exp);
4310 switch (TREE_CODE (TREE_TYPE (exp)))
4312 case UNCONSTRAINED_ARRAY_TYPE:
4313 if (code == UNCONSTRAINED_ARRAY_REF)
4315 new_exp = TREE_OPERAND (exp, 0);
4317 = build_unary_op (INDIRECT_REF, NULL_TREE,
4318 build_component_ref (new_exp, NULL_TREE,
4320 (TREE_TYPE (new_exp)),
4322 TREE_READONLY (new_exp) = TREE_READONLY (exp);
4326 else if (code == NULL_EXPR)
4327 return build1 (NULL_EXPR,
4328 TREE_TYPE (TREE_TYPE (TYPE_FIELDS
4329 (TREE_TYPE (TREE_TYPE (exp))))),
4330 TREE_OPERAND (exp, 0));
4333 /* If this is a padded type, convert to the unpadded type and see if
4334 it contains a template. */
4335 if (TYPE_PADDING_P (TREE_TYPE (exp)))
4337 new_exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
4338 if (TREE_CODE (TREE_TYPE (new_exp)) == RECORD_TYPE
4339 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new_exp)))
4341 build_component_ref (new_exp, NULL_TREE,
4343 (TYPE_FIELDS (TREE_TYPE (new_exp))),
4346 else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
4348 build_component_ref (exp, NULL_TREE,
4349 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))),
4360 /* If EXP's type is a VECTOR_TYPE, return EXP converted to the associated
4361 TYPE_REPRESENTATIVE_ARRAY. */
4364 maybe_vector_array (tree exp)
4366 tree etype = TREE_TYPE (exp);
4368 if (VECTOR_TYPE_P (etype))
4369 exp = convert (TYPE_REPRESENTATIVE_ARRAY (etype), exp);
4374 /* Return true if EXPR is an expression that can be folded as an operand
4375 of a VIEW_CONVERT_EXPR. See ada-tree.h for a complete rationale. */
4378 can_fold_for_view_convert_p (tree expr)
4382 /* The folder will fold NOP_EXPRs between integral types with the same
4383 precision (in the middle-end's sense). We cannot allow it if the
4384 types don't have the same precision in the Ada sense as well. */
4385 if (TREE_CODE (expr) != NOP_EXPR)
4388 t1 = TREE_TYPE (expr);
4389 t2 = TREE_TYPE (TREE_OPERAND (expr, 0));
4391 /* Defer to the folder for non-integral conversions. */
4392 if (!(INTEGRAL_TYPE_P (t1) && INTEGRAL_TYPE_P (t2)))
4395 /* Only fold conversions that preserve both precisions. */
4396 if (TYPE_PRECISION (t1) == TYPE_PRECISION (t2)
4397 && operand_equal_p (rm_size (t1), rm_size (t2), 0))
4403 /* Return an expression that does an unchecked conversion of EXPR to TYPE.
4404 If NOTRUNC_P is true, truncation operations should be suppressed.
4406 Special care is required with (source or target) integral types whose
4407 precision is not equal to their size, to make sure we fetch or assign
4408 the value bits whose location might depend on the endianness, e.g.
4410 Rmsize : constant := 8;
4411 subtype Int is Integer range 0 .. 2 ** Rmsize - 1;
4413 type Bit_Array is array (1 .. Rmsize) of Boolean;
4414 pragma Pack (Bit_Array);
4416 function To_Bit_Array is new Unchecked_Conversion (Int, Bit_Array);
4418 Value : Int := 2#1000_0001#;
4419 Vbits : Bit_Array := To_Bit_Array (Value);
4421 we expect the 8 bits at Vbits'Address to always contain Value, while
4422 their original location depends on the endianness, at Value'Address
4423 on a little-endian architecture but not on a big-endian one. */
4426 unchecked_convert (tree type, tree expr, bool notrunc_p)
4428 tree etype = TREE_TYPE (expr);
4429 enum tree_code ecode = TREE_CODE (etype);
4430 enum tree_code code = TREE_CODE (type);
4433 /* If the expression is already of the right type, we are done. */
4437 /* If both types types are integral just do a normal conversion.
4438 Likewise for a conversion to an unconstrained array. */
4439 if ((((INTEGRAL_TYPE_P (type)
4440 && !(code == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (type)))
4441 || (POINTER_TYPE_P (type) && ! TYPE_IS_THIN_POINTER_P (type))
4442 || (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type)))
4443 && ((INTEGRAL_TYPE_P (etype)
4444 && !(ecode == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (etype)))
4445 || (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype))
4446 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))))
4447 || code == UNCONSTRAINED_ARRAY_TYPE)
4449 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
4451 tree ntype = copy_type (etype);
4452 TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
4453 TYPE_MAIN_VARIANT (ntype) = ntype;
4454 expr = build1 (NOP_EXPR, ntype, expr);
4457 if (code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
4459 tree rtype = copy_type (type);
4460 TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
4461 TYPE_MAIN_VARIANT (rtype) = rtype;
4462 expr = convert (rtype, expr);
4463 expr = build1 (NOP_EXPR, type, expr);
4466 expr = convert (type, expr);
4469 /* If we are converting to an integral type whose precision is not equal
4470 to its size, first unchecked convert to a record that contains an
4471 object of the output type. Then extract the field. */
4472 else if (INTEGRAL_TYPE_P (type)
4473 && TYPE_RM_SIZE (type)
4474 && 0 != compare_tree_int (TYPE_RM_SIZE (type),
4475 GET_MODE_BITSIZE (TYPE_MODE (type))))
4477 tree rec_type = make_node (RECORD_TYPE);
4478 tree field = create_field_decl (get_identifier ("OBJ"), type, rec_type,
4479 NULL_TREE, NULL_TREE, 1, 0);
4481 TYPE_FIELDS (rec_type) = field;
4482 layout_type (rec_type);
4484 expr = unchecked_convert (rec_type, expr, notrunc_p);
4485 expr = build_component_ref (expr, NULL_TREE, field, false);
4488 /* Similarly if we are converting from an integral type whose precision
4489 is not equal to its size. */
4490 else if (INTEGRAL_TYPE_P (etype)
4491 && TYPE_RM_SIZE (etype)
4492 && 0 != compare_tree_int (TYPE_RM_SIZE (etype),
4493 GET_MODE_BITSIZE (TYPE_MODE (etype))))
4495 tree rec_type = make_node (RECORD_TYPE);
4496 tree field = create_field_decl (get_identifier ("OBJ"), etype, rec_type,
4497 NULL_TREE, NULL_TREE, 1, 0);
4498 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1);
4500 TYPE_FIELDS (rec_type) = field;
4501 layout_type (rec_type);
4503 CONSTRUCTOR_APPEND_ELT (v, field, expr);
4504 expr = gnat_build_constructor (rec_type, v);
4505 expr = unchecked_convert (type, expr, notrunc_p);
4508 /* If we are converting from a scalar type to a type with a different size,
4509 we need to pad to have the same size on both sides.
4511 ??? We cannot do it unconditionally because unchecked conversions are
4512 used liberally by the front-end to implement polymorphism, e.g. in:
4514 S191s : constant ada__tags__addr_ptr := ada__tags__addr_ptr!(S190s);
4515 return p___size__4 (p__object!(S191s.all));
4517 so we skip all expressions that are references. */
4518 else if (!REFERENCE_CLASS_P (expr)
4519 && !AGGREGATE_TYPE_P (etype)
4520 && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST
4521 && (c = tree_int_cst_compare (TYPE_SIZE (etype), TYPE_SIZE (type))))
4525 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
4526 false, false, false, true),
4528 expr = unchecked_convert (type, expr, notrunc_p);
4532 tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty,
4533 false, false, false, true);
4534 expr = unchecked_convert (rec_type, expr, notrunc_p);
4535 expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (rec_type),
4540 /* We have a special case when we are converting between two unconstrained
4541 array types. In that case, take the address, convert the fat pointer
4542 types, and dereference. */
4543 else if (ecode == code && code == UNCONSTRAINED_ARRAY_TYPE)
4544 expr = build_unary_op (INDIRECT_REF, NULL_TREE,
4545 build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type),
4546 build_unary_op (ADDR_EXPR, NULL_TREE,
4549 /* Another special case is when we are converting to a vector type from its
4550 representative array type; this a regular conversion. */
4551 else if (code == VECTOR_TYPE
4552 && ecode == ARRAY_TYPE
4553 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
4555 expr = convert (type, expr);
4559 expr = maybe_unconstrained_array (expr);
4560 etype = TREE_TYPE (expr);
4561 ecode = TREE_CODE (etype);
4562 if (can_fold_for_view_convert_p (expr))
4563 expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr);
4565 expr = build1 (VIEW_CONVERT_EXPR, type, expr);
4568 /* If the result is an integral type whose precision is not equal to its
4569 size, sign- or zero-extend the result. We need not do this if the input
4570 is an integral type of the same precision and signedness or if the output
4571 is a biased type or if both the input and output are unsigned. */
4573 && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
4574 && !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
4575 && 0 != compare_tree_int (TYPE_RM_SIZE (type),
4576 GET_MODE_BITSIZE (TYPE_MODE (type)))
4577 && !(INTEGRAL_TYPE_P (etype)
4578 && TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype)
4579 && operand_equal_p (TYPE_RM_SIZE (type),
4580 (TYPE_RM_SIZE (etype) != 0
4581 ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)),
4583 && !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype)))
4586 = gnat_type_for_mode (TYPE_MODE (type), TYPE_UNSIGNED (type));
4588 = convert (base_type,
4589 size_binop (MINUS_EXPR,
4591 (GET_MODE_BITSIZE (TYPE_MODE (type))),
4592 TYPE_RM_SIZE (type)));
4595 build_binary_op (RSHIFT_EXPR, base_type,
4596 build_binary_op (LSHIFT_EXPR, base_type,
4597 convert (base_type, expr),
4602 /* An unchecked conversion should never raise Constraint_Error. The code
4603 below assumes that GCC's conversion routines overflow the same way that
4604 the underlying hardware does. This is probably true. In the rare case
4605 when it is false, we can rely on the fact that such conversions are
4606 erroneous anyway. */
4607 if (TREE_CODE (expr) == INTEGER_CST)
4608 TREE_OVERFLOW (expr) = 0;
4610 /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
4611 show no longer constant. */
4612 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
4613 && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype),
4615 TREE_CONSTANT (expr) = 0;
4620 /* Return the appropriate GCC tree code for the specified GNAT_TYPE,
4621 the latter being a record type as predicated by Is_Record_Type. */
4624 tree_code_for_record_type (Entity_Id gnat_type)
4626 Node_Id component_list
4627 = Component_List (Type_Definition
4629 (Implementation_Base_Type (gnat_type))));
4632 /* Make this a UNION_TYPE unless it's either not an Unchecked_Union or
4633 we have a non-discriminant field outside a variant. In either case,
4634 it's a RECORD_TYPE. */
4636 if (!Is_Unchecked_Union (gnat_type))
4639 for (component = First_Non_Pragma (Component_Items (component_list));
4640 Present (component);
4641 component = Next_Non_Pragma (component))
4642 if (Ekind (Defining_Entity (component)) == E_Component)
4648 /* Return true if GNAT_TYPE is a "double" floating-point type, i.e. whose
4649 size is equal to 64 bits, or an array of such a type. Set ALIGN_CLAUSE
4650 according to the presence of an alignment clause on the type or, if it
4651 is an array, on the component type. */
4654 is_double_float_or_array (Entity_Id gnat_type, bool *align_clause)
4656 gnat_type = Underlying_Type (gnat_type);
4658 *align_clause = Present (Alignment_Clause (gnat_type));
4660 if (Is_Array_Type (gnat_type))
4662 gnat_type = Underlying_Type (Component_Type (gnat_type));
4663 if (Present (Alignment_Clause (gnat_type)))
4664 *align_clause = true;
4667 if (!Is_Floating_Point_Type (gnat_type))
4670 if (UI_To_Int (Esize (gnat_type)) != 64)
4676 /* Return true if GNAT_TYPE is a "double" or larger scalar type, i.e. whose
4677 size is greater or equal to 64 bits, or an array of such a type. Set
4678 ALIGN_CLAUSE according to the presence of an alignment clause on the
4679 type or, if it is an array, on the component type. */
4682 is_double_scalar_or_array (Entity_Id gnat_type, bool *align_clause)
4684 gnat_type = Underlying_Type (gnat_type);
4686 *align_clause = Present (Alignment_Clause (gnat_type));
4688 if (Is_Array_Type (gnat_type))
4690 gnat_type = Underlying_Type (Component_Type (gnat_type));
4691 if (Present (Alignment_Clause (gnat_type)))
4692 *align_clause = true;
4695 if (!Is_Scalar_Type (gnat_type))
4698 if (UI_To_Int (Esize (gnat_type)) < 64)
4704 /* Return true if GNU_TYPE is suitable as the type of a non-aliased
4705 component of an aggregate type. */
4708 type_for_nonaliased_component_p (tree gnu_type)
4710 /* If the type is passed by reference, we may have pointers to the
4711 component so it cannot be made non-aliased. */
4712 if (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type))
4715 /* We used to say that any component of aggregate type is aliased
4716 because the front-end may take 'Reference of it. The front-end
4717 has been enhanced in the meantime so as to use a renaming instead
4718 in most cases, but the back-end can probably take the address of
4719 such a component too so we go for the conservative stance.
4721 For instance, we might need the address of any array type, even
4722 if normally passed by copy, to construct a fat pointer if the
4723 component is used as an actual for an unconstrained formal.
4725 Likewise for record types: even if a specific record subtype is
4726 passed by copy, the parent type might be passed by ref (e.g. if
4727 it's of variable size) and we might take the address of a child
4728 component to pass to a parent formal. We have no way to check
4729 for such conditions here. */
4730 if (AGGREGATE_TYPE_P (gnu_type))
4736 /* Return true if TYPE is a smaller form of ORIG_TYPE. */
4739 smaller_form_type_p (tree type, tree orig_type)
4743 /* We're not interested in variants here. */
4744 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (orig_type))
4747 /* Like a variant, a packable version keeps the original TYPE_NAME. */
4748 if (TYPE_NAME (type) != TYPE_NAME (orig_type))
4751 size = TYPE_SIZE (type);
4752 osize = TYPE_SIZE (orig_type);
4754 if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (osize) == INTEGER_CST))
4757 return tree_int_cst_lt (size, osize) != 0;
4760 /* Perform final processing on global variables. */
4762 static GTY (()) tree dummy_global;
4765 gnat_write_global_declarations (void)
4767 /* If we have declared types as used at the global level, insert them in
4768 the global hash table. We use a dummy variable for this purpose. */
4769 if (!VEC_empty (tree, types_used_by_cur_var_decl))
4772 = build_decl (BUILTINS_LOCATION, VAR_DECL, NULL_TREE, void_type_node);
4773 TREE_STATIC (dummy_global) = 1;
4774 TREE_ASM_WRITTEN (dummy_global) = 1;
4775 varpool_mark_needed_node (varpool_node (dummy_global));
4777 while (!VEC_empty (tree, types_used_by_cur_var_decl))
4779 tree t = VEC_pop (tree, types_used_by_cur_var_decl);
4780 types_used_by_var_decl_insert (t, dummy_global);
4784 /* Proceed to optimize and emit assembly.
4785 FIXME: shouldn't be the front end's responsibility to call this. */
4786 cgraph_finalize_compilation_unit ();
4788 /* Emit debug info for all global declarations. */
4789 emit_debug_global_declarations (VEC_address (tree, global_decls),
4790 VEC_length (tree, global_decls));
4793 /* ************************************************************************
4794 * * GCC builtins support *
4795 * ************************************************************************ */
4797 /* The general scheme is fairly simple:
4799 For each builtin function/type to be declared, gnat_install_builtins calls
4800 internal facilities which eventually get to gnat_push_decl, which in turn
4801 tracks the so declared builtin function decls in the 'builtin_decls' global
4802 datastructure. When an Intrinsic subprogram declaration is processed, we
4803 search this global datastructure to retrieve the associated BUILT_IN DECL
4806 /* Search the chain of currently available builtin declarations for a node
4807 corresponding to function NAME (an IDENTIFIER_NODE). Return the first node
4808 found, if any, or NULL_TREE otherwise. */
4810 builtin_decl_for (tree name)
4815 FOR_EACH_VEC_ELT (tree, builtin_decls, i, decl)
4816 if (DECL_NAME (decl) == name)
4822 /* The code below eventually exposes gnat_install_builtins, which declares
4823 the builtin types and functions we might need, either internally or as
4824 user accessible facilities.
4826 ??? This is a first implementation shot, still in rough shape. It is
4827 heavily inspired from the "C" family implementation, with chunks copied
4828 verbatim from there.
4830 Two obvious TODO candidates are
4831 o Use a more efficient name/decl mapping scheme
4832 o Devise a middle-end infrastructure to avoid having to copy
4833 pieces between front-ends. */
4835 /* ----------------------------------------------------------------------- *
4836 * BUILTIN ELEMENTARY TYPES *
4837 * ----------------------------------------------------------------------- */
4839 /* Standard data types to be used in builtin argument declarations. */
4843 CTI_SIGNED_SIZE_TYPE, /* For format checking only. */
4845 CTI_CONST_STRING_TYPE,
4850 static tree c_global_trees[CTI_MAX];
4852 #define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE]
4853 #define string_type_node c_global_trees[CTI_STRING_TYPE]
4854 #define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE]
4856 /* ??? In addition some attribute handlers, we currently don't support a
4857 (small) number of builtin-types, which in turns inhibits support for a
4858 number of builtin functions. */
4859 #define wint_type_node void_type_node
4860 #define intmax_type_node void_type_node
4861 #define uintmax_type_node void_type_node
4863 /* Build the void_list_node (void_type_node having been created). */
4866 build_void_list_node (void)
4868 tree t = build_tree_list (NULL_TREE, void_type_node);
4872 /* Used to help initialize the builtin-types.def table. When a type of
4873 the correct size doesn't exist, use error_mark_node instead of NULL.
4874 The later results in segfaults even when a decl using the type doesn't
4878 builtin_type_for_size (int size, bool unsignedp)
4880 tree type = gnat_type_for_size (size, unsignedp);
4881 return type ? type : error_mark_node;
4884 /* Build/push the elementary type decls that builtin functions/types
4888 install_builtin_elementary_types (void)
4890 signed_size_type_node = gnat_signed_type (size_type_node);
4891 pid_type_node = integer_type_node;
4892 void_list_node = build_void_list_node ();
4894 string_type_node = build_pointer_type (char_type_node);
4895 const_string_type_node
4896 = build_pointer_type (build_qualified_type
4897 (char_type_node, TYPE_QUAL_CONST));
4900 /* ----------------------------------------------------------------------- *
4901 * BUILTIN FUNCTION TYPES *
4902 * ----------------------------------------------------------------------- */
4904 /* Now, builtin function types per se. */
4908 #define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
4909 #define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
4910 #define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
4911 #define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
4912 #define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
4913 #define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
4914 #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
4915 #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME,
4916 #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME,
4917 #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
4918 #define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME,
4919 #define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME,
4920 #define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
4921 #define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
4922 #define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG6) \
4924 #define DEF_POINTER_TYPE(NAME, TYPE) NAME,
4925 #include "builtin-types.def"
4926 #undef DEF_PRIMITIVE_TYPE
4927 #undef DEF_FUNCTION_TYPE_0
4928 #undef DEF_FUNCTION_TYPE_1
4929 #undef DEF_FUNCTION_TYPE_2
4930 #undef DEF_FUNCTION_TYPE_3
4931 #undef DEF_FUNCTION_TYPE_4
4932 #undef DEF_FUNCTION_TYPE_5
4933 #undef DEF_FUNCTION_TYPE_6
4934 #undef DEF_FUNCTION_TYPE_7
4935 #undef DEF_FUNCTION_TYPE_VAR_0
4936 #undef DEF_FUNCTION_TYPE_VAR_1
4937 #undef DEF_FUNCTION_TYPE_VAR_2
4938 #undef DEF_FUNCTION_TYPE_VAR_3
4939 #undef DEF_FUNCTION_TYPE_VAR_4
4940 #undef DEF_FUNCTION_TYPE_VAR_5
4941 #undef DEF_POINTER_TYPE
4945 typedef enum c_builtin_type builtin_type;
4947 /* A temporary array used in communication with def_fn_type. */
4948 static GTY(()) tree builtin_types[(int) BT_LAST + 1];
4950 /* A helper function for install_builtin_types. Build function type
4951 for DEF with return type RET and N arguments. If VAR is true, then the
4952 function should be variadic after those N arguments.
4954 Takes special care not to ICE if any of the types involved are
4955 error_mark_node, which indicates that said type is not in fact available
4956 (see builtin_type_for_size). In which case the function type as a whole
4957 should be error_mark_node. */
4960 def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...)
4962 tree args = NULL, t;
4967 for (i = 0; i < n; ++i)
4969 builtin_type a = (builtin_type) va_arg (list, int);
4970 t = builtin_types[a];
4971 if (t == error_mark_node)
4973 args = tree_cons (NULL_TREE, t, args);
4977 args = nreverse (args);
4979 args = chainon (args, void_list_node);
4981 t = builtin_types[ret];
4982 if (t == error_mark_node)
4984 t = build_function_type (t, args);
4987 builtin_types[def] = t;
4991 /* Build the builtin function types and install them in the builtin_types
4992 array for later use in builtin function decls. */
4995 install_builtin_function_types (void)
4997 tree va_list_ref_type_node;
4998 tree va_list_arg_type_node;
5000 if (TREE_CODE (va_list_type_node) == ARRAY_TYPE)
5002 va_list_arg_type_node = va_list_ref_type_node =
5003 build_pointer_type (TREE_TYPE (va_list_type_node));
5007 va_list_arg_type_node = va_list_type_node;
5008 va_list_ref_type_node = build_reference_type (va_list_type_node);
5011 #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
5012 builtin_types[ENUM] = VALUE;
5013 #define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \
5014 def_fn_type (ENUM, RETURN, 0, 0);
5015 #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \
5016 def_fn_type (ENUM, RETURN, 0, 1, ARG1);
5017 #define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \
5018 def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2);
5019 #define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
5020 def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3);
5021 #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
5022 def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4);
5023 #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5024 def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
5025 #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5027 def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6);
5028 #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
5030 def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7);
5031 #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \
5032 def_fn_type (ENUM, RETURN, 1, 0);
5033 #define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \
5034 def_fn_type (ENUM, RETURN, 1, 1, ARG1);
5035 #define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \
5036 def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2);
5037 #define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
5038 def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3);
5039 #define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
5040 def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4);
5041 #define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
5042 def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
5043 #define DEF_POINTER_TYPE(ENUM, TYPE) \
5044 builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]);
5046 #include "builtin-types.def"
5048 #undef DEF_PRIMITIVE_TYPE
5049 #undef DEF_FUNCTION_TYPE_1
5050 #undef DEF_FUNCTION_TYPE_2
5051 #undef DEF_FUNCTION_TYPE_3
5052 #undef DEF_FUNCTION_TYPE_4
5053 #undef DEF_FUNCTION_TYPE_5
5054 #undef DEF_FUNCTION_TYPE_6
5055 #undef DEF_FUNCTION_TYPE_VAR_0
5056 #undef DEF_FUNCTION_TYPE_VAR_1
5057 #undef DEF_FUNCTION_TYPE_VAR_2
5058 #undef DEF_FUNCTION_TYPE_VAR_3
5059 #undef DEF_FUNCTION_TYPE_VAR_4
5060 #undef DEF_FUNCTION_TYPE_VAR_5
5061 #undef DEF_POINTER_TYPE
5062 builtin_types[(int) BT_LAST] = NULL_TREE;
5065 /* ----------------------------------------------------------------------- *
5066 * BUILTIN ATTRIBUTES *
5067 * ----------------------------------------------------------------------- */
5069 enum built_in_attribute
5071 #define DEF_ATTR_NULL_TREE(ENUM) ENUM,
5072 #define DEF_ATTR_INT(ENUM, VALUE) ENUM,
5073 #define DEF_ATTR_IDENT(ENUM, STRING) ENUM,
5074 #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM,
5075 #include "builtin-attrs.def"
5076 #undef DEF_ATTR_NULL_TREE
5078 #undef DEF_ATTR_IDENT
5079 #undef DEF_ATTR_TREE_LIST
5083 static GTY(()) tree built_in_attributes[(int) ATTR_LAST];
5086 install_builtin_attributes (void)
5088 /* Fill in the built_in_attributes array. */
5089 #define DEF_ATTR_NULL_TREE(ENUM) \
5090 built_in_attributes[(int) ENUM] = NULL_TREE;
5091 #define DEF_ATTR_INT(ENUM, VALUE) \
5092 built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE);
5093 #define DEF_ATTR_IDENT(ENUM, STRING) \
5094 built_in_attributes[(int) ENUM] = get_identifier (STRING);
5095 #define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \
5096 built_in_attributes[(int) ENUM] \
5097 = tree_cons (built_in_attributes[(int) PURPOSE], \
5098 built_in_attributes[(int) VALUE], \
5099 built_in_attributes[(int) CHAIN]);
5100 #include "builtin-attrs.def"
5101 #undef DEF_ATTR_NULL_TREE
5103 #undef DEF_ATTR_IDENT
5104 #undef DEF_ATTR_TREE_LIST
5107 /* Handle a "const" attribute; arguments as in
5108 struct attribute_spec.handler. */
5111 handle_const_attribute (tree *node, tree ARG_UNUSED (name),
5112 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5115 if (TREE_CODE (*node) == FUNCTION_DECL)
5116 TREE_READONLY (*node) = 1;
5118 *no_add_attrs = true;
5123 /* Handle a "nothrow" attribute; arguments as in
5124 struct attribute_spec.handler. */
5127 handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name),
5128 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5131 if (TREE_CODE (*node) == FUNCTION_DECL)
5132 TREE_NOTHROW (*node) = 1;
5134 *no_add_attrs = true;
5139 /* Handle a "pure" attribute; arguments as in
5140 struct attribute_spec.handler. */
5143 handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args),
5144 int ARG_UNUSED (flags), bool *no_add_attrs)
5146 if (TREE_CODE (*node) == FUNCTION_DECL)
5147 DECL_PURE_P (*node) = 1;
5148 /* ??? TODO: Support types. */
5151 warning (OPT_Wattributes, "%qs attribute ignored",
5152 IDENTIFIER_POINTER (name));
5153 *no_add_attrs = true;
5159 /* Handle a "no vops" attribute; arguments as in
5160 struct attribute_spec.handler. */
5163 handle_novops_attribute (tree *node, tree ARG_UNUSED (name),
5164 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5165 bool *ARG_UNUSED (no_add_attrs))
5167 gcc_assert (TREE_CODE (*node) == FUNCTION_DECL);
5168 DECL_IS_NOVOPS (*node) = 1;
5172 /* Helper for nonnull attribute handling; fetch the operand number
5173 from the attribute argument list. */
5176 get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp)
5178 /* Verify the arg number is a constant. */
5179 if (TREE_CODE (arg_num_expr) != INTEGER_CST
5180 || TREE_INT_CST_HIGH (arg_num_expr) != 0)
5183 *valp = TREE_INT_CST_LOW (arg_num_expr);
5187 /* Handle the "nonnull" attribute. */
5189 handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name),
5190 tree args, int ARG_UNUSED (flags),
5194 unsigned HOST_WIDE_INT attr_arg_num;
5196 /* If no arguments are specified, all pointer arguments should be
5197 non-null. Verify a full prototype is given so that the arguments
5198 will have the correct types when we actually check them later. */
5201 if (!prototype_p (type))
5203 error ("nonnull attribute without arguments on a non-prototype");
5204 *no_add_attrs = true;
5209 /* Argument list specified. Verify that each argument number references
5210 a pointer argument. */
5211 for (attr_arg_num = 1; args; args = TREE_CHAIN (args))
5213 unsigned HOST_WIDE_INT arg_num = 0, ck_num;
5215 if (!get_nonnull_operand (TREE_VALUE (args), &arg_num))
5217 error ("nonnull argument has invalid operand number (argument %lu)",
5218 (unsigned long) attr_arg_num);
5219 *no_add_attrs = true;
5223 if (prototype_p (type))
5225 function_args_iterator iter;
5228 function_args_iter_init (&iter, type);
5229 for (ck_num = 1; ; ck_num++, function_args_iter_next (&iter))
5231 argument = function_args_iter_cond (&iter);
5232 if (!argument || ck_num == arg_num)
5237 || TREE_CODE (argument) == VOID_TYPE)
5239 error ("nonnull argument with out-of-range operand number "
5240 "(argument %lu, operand %lu)",
5241 (unsigned long) attr_arg_num, (unsigned long) arg_num);
5242 *no_add_attrs = true;
5246 if (TREE_CODE (argument) != POINTER_TYPE)
5248 error ("nonnull argument references non-pointer operand "
5249 "(argument %lu, operand %lu)",
5250 (unsigned long) attr_arg_num, (unsigned long) arg_num);
5251 *no_add_attrs = true;
5260 /* Handle a "sentinel" attribute. */
5263 handle_sentinel_attribute (tree *node, tree name, tree args,
5264 int ARG_UNUSED (flags), bool *no_add_attrs)
5266 if (!prototype_p (*node))
5268 warning (OPT_Wattributes,
5269 "%qs attribute requires prototypes with named arguments",
5270 IDENTIFIER_POINTER (name));
5271 *no_add_attrs = true;
5275 if (!stdarg_p (*node))
5277 warning (OPT_Wattributes,
5278 "%qs attribute only applies to variadic functions",
5279 IDENTIFIER_POINTER (name));
5280 *no_add_attrs = true;
5286 tree position = TREE_VALUE (args);
5288 if (TREE_CODE (position) != INTEGER_CST)
5290 warning (0, "requested position is not an integer constant");
5291 *no_add_attrs = true;
5295 if (tree_int_cst_lt (position, integer_zero_node))
5297 warning (0, "requested position is less than zero");
5298 *no_add_attrs = true;
5306 /* Handle a "noreturn" attribute; arguments as in
5307 struct attribute_spec.handler. */
5310 handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args),
5311 int ARG_UNUSED (flags), bool *no_add_attrs)
5313 tree type = TREE_TYPE (*node);
5315 /* See FIXME comment in c_common_attribute_table. */
5316 if (TREE_CODE (*node) == FUNCTION_DECL)
5317 TREE_THIS_VOLATILE (*node) = 1;
5318 else if (TREE_CODE (type) == POINTER_TYPE
5319 && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
5321 = build_pointer_type
5322 (build_type_variant (TREE_TYPE (type),
5323 TYPE_READONLY (TREE_TYPE (type)), 1));
5326 warning (OPT_Wattributes, "%qs attribute ignored",
5327 IDENTIFIER_POINTER (name));
5328 *no_add_attrs = true;
5334 /* Handle a "leaf" attribute; arguments as in
5335 struct attribute_spec.handler. */
5338 handle_leaf_attribute (tree *node, tree name,
5339 tree ARG_UNUSED (args),
5340 int ARG_UNUSED (flags), bool *no_add_attrs)
5342 if (TREE_CODE (*node) != FUNCTION_DECL)
5344 warning (OPT_Wattributes, "%qE attribute ignored", name);
5345 *no_add_attrs = true;
5347 if (!TREE_PUBLIC (*node))
5349 warning (OPT_Wattributes, "%qE attribute has no effect", name);
5350 *no_add_attrs = true;
5356 /* Handle a "malloc" attribute; arguments as in
5357 struct attribute_spec.handler. */
5360 handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args),
5361 int ARG_UNUSED (flags), bool *no_add_attrs)
5363 if (TREE_CODE (*node) == FUNCTION_DECL
5364 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node))))
5365 DECL_IS_MALLOC (*node) = 1;
5368 warning (OPT_Wattributes, "%qs attribute ignored",
5369 IDENTIFIER_POINTER (name));
5370 *no_add_attrs = true;
5376 /* Fake handler for attributes we don't properly support. */
5379 fake_attribute_handler (tree * ARG_UNUSED (node),
5380 tree ARG_UNUSED (name),
5381 tree ARG_UNUSED (args),
5382 int ARG_UNUSED (flags),
5383 bool * ARG_UNUSED (no_add_attrs))
5388 /* Handle a "type_generic" attribute. */
5391 handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name),
5392 tree ARG_UNUSED (args), int ARG_UNUSED (flags),
5393 bool * ARG_UNUSED (no_add_attrs))
5395 /* Ensure we have a function type. */
5396 gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE);
5398 /* Ensure we have a variadic function. */
5399 gcc_assert (!prototype_p (*node) || stdarg_p (*node));
5404 /* Handle a "vector_size" attribute; arguments as in
5405 struct attribute_spec.handler. */
5408 handle_vector_size_attribute (tree *node, tree name, tree args,
5409 int ARG_UNUSED (flags),
5412 unsigned HOST_WIDE_INT vecsize, nunits;
5413 enum machine_mode orig_mode;
5414 tree type = *node, new_type, size;
5416 *no_add_attrs = true;
5418 size = TREE_VALUE (args);
5420 if (!host_integerp (size, 1))
5422 warning (OPT_Wattributes, "%qs attribute ignored",
5423 IDENTIFIER_POINTER (name));
5427 /* Get the vector size (in bytes). */
5428 vecsize = tree_low_cst (size, 1);
5430 /* We need to provide for vector pointers, vector arrays, and
5431 functions returning vectors. For example:
5433 __attribute__((vector_size(16))) short *foo;
5435 In this case, the mode is SI, but the type being modified is
5436 HI, so we need to look further. */
5438 while (POINTER_TYPE_P (type)
5439 || TREE_CODE (type) == FUNCTION_TYPE
5440 || TREE_CODE (type) == ARRAY_TYPE)
5441 type = TREE_TYPE (type);
5443 /* Get the mode of the type being modified. */
5444 orig_mode = TYPE_MODE (type);
5446 if ((!INTEGRAL_TYPE_P (type)
5447 && !SCALAR_FLOAT_TYPE_P (type)
5448 && !FIXED_POINT_TYPE_P (type))
5449 || (!SCALAR_FLOAT_MODE_P (orig_mode)
5450 && GET_MODE_CLASS (orig_mode) != MODE_INT
5451 && !ALL_SCALAR_FIXED_POINT_MODE_P (orig_mode))
5452 || !host_integerp (TYPE_SIZE_UNIT (type), 1)
5453 || TREE_CODE (type) == BOOLEAN_TYPE)
5455 error ("invalid vector type for attribute %qs",
5456 IDENTIFIER_POINTER (name));
5460 if (vecsize % tree_low_cst (TYPE_SIZE_UNIT (type), 1))
5462 error ("vector size not an integral multiple of component size");
5468 error ("zero vector size");
5472 /* Calculate how many units fit in the vector. */
5473 nunits = vecsize / tree_low_cst (TYPE_SIZE_UNIT (type), 1);
5474 if (nunits & (nunits - 1))
5476 error ("number of components of the vector not a power of two");
5480 new_type = build_vector_type (type, nunits);
5482 /* Build back pointers if needed. */
5483 *node = reconstruct_complex_type (*node, new_type);
5488 /* Handle a "vector_type" attribute; arguments as in
5489 struct attribute_spec.handler. */
5492 handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args),
5493 int ARG_UNUSED (flags),
5496 /* Vector representative type and size. */
5497 tree rep_type = *node;
5498 tree rep_size = TYPE_SIZE_UNIT (rep_type);
5501 /* Vector size in bytes and number of units. */
5502 unsigned HOST_WIDE_INT vec_bytes, vec_units;
5504 /* Vector element type and mode. */
5506 enum machine_mode elem_mode;
5508 *no_add_attrs = true;
5510 /* Get the representative array type, possibly nested within a
5511 padding record e.g. for alignment purposes. */
5513 if (TYPE_IS_PADDING_P (rep_type))
5514 rep_type = TREE_TYPE (TYPE_FIELDS (rep_type));
5516 if (TREE_CODE (rep_type) != ARRAY_TYPE)
5518 error ("attribute %qs applies to array types only",
5519 IDENTIFIER_POINTER (name));
5523 /* Silently punt on variable sizes. We can't make vector types for them,
5524 need to ignore them on front-end generated subtypes of unconstrained
5525 bases, and this attribute is for binding implementors, not end-users, so
5526 we should never get there from legitimate explicit uses. */
5528 if (!host_integerp (rep_size, 1))
5531 /* Get the element type/mode and check this is something we know
5532 how to make vectors of. */
5534 elem_type = TREE_TYPE (rep_type);
5535 elem_mode = TYPE_MODE (elem_type);
5537 if ((!INTEGRAL_TYPE_P (elem_type)
5538 && !SCALAR_FLOAT_TYPE_P (elem_type)
5539 && !FIXED_POINT_TYPE_P (elem_type))
5540 || (!SCALAR_FLOAT_MODE_P (elem_mode)
5541 && GET_MODE_CLASS (elem_mode) != MODE_INT
5542 && !ALL_SCALAR_FIXED_POINT_MODE_P (elem_mode))
5543 || !host_integerp (TYPE_SIZE_UNIT (elem_type), 1))
5545 error ("invalid element type for attribute %qs",
5546 IDENTIFIER_POINTER (name));
5550 /* Sanity check the vector size and element type consistency. */
5552 vec_bytes = tree_low_cst (rep_size, 1);
5554 if (vec_bytes % tree_low_cst (TYPE_SIZE_UNIT (elem_type), 1))
5556 error ("vector size not an integral multiple of component size");
5562 error ("zero vector size");
5566 vec_units = vec_bytes / tree_low_cst (TYPE_SIZE_UNIT (elem_type), 1);
5567 if (vec_units & (vec_units - 1))
5569 error ("number of components of the vector not a power of two");
5573 /* Build the vector type and replace. */
5575 *node = build_vector_type (elem_type, vec_units);
5576 rep_name = TYPE_NAME (rep_type);
5577 if (TREE_CODE (rep_name) == TYPE_DECL)
5578 rep_name = DECL_NAME (rep_name);
5579 TYPE_NAME (*node) = rep_name;
5580 TYPE_REPRESENTATIVE_ARRAY (*node) = rep_type;
5585 /* ----------------------------------------------------------------------- *
5586 * BUILTIN FUNCTIONS *
5587 * ----------------------------------------------------------------------- */
5589 /* Worker for DEF_BUILTIN. Possibly define a builtin function with one or two
5590 names. Does not declare a non-__builtin_ function if flag_no_builtin, or
5591 if nonansi_p and flag_no_nonansi_builtin. */
5594 def_builtin_1 (enum built_in_function fncode,
5596 enum built_in_class fnclass,
5597 tree fntype, tree libtype,
5598 bool both_p, bool fallback_p,
5599 bool nonansi_p ATTRIBUTE_UNUSED,
5600 tree fnattrs, bool implicit_p)
5603 const char *libname;
5605 /* Preserve an already installed decl. It most likely was setup in advance
5606 (e.g. as part of the internal builtins) for specific reasons. */
5607 if (built_in_decls[(int) fncode] != NULL_TREE)
5610 gcc_assert ((!both_p && !fallback_p)
5611 || !strncmp (name, "__builtin_",
5612 strlen ("__builtin_")));
5614 libname = name + strlen ("__builtin_");
5615 decl = add_builtin_function (name, fntype, fncode, fnclass,
5616 (fallback_p ? libname : NULL),
5619 /* ??? This is normally further controlled by command-line options
5620 like -fno-builtin, but we don't have them for Ada. */
5621 add_builtin_function (libname, libtype, fncode, fnclass,
5624 built_in_decls[(int) fncode] = decl;
5626 implicit_built_in_decls[(int) fncode] = decl;
5629 static int flag_isoc94 = 0;
5630 static int flag_isoc99 = 0;
5632 /* Install what the common builtins.def offers. */
5635 install_builtin_functions (void)
5637 #define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \
5638 NONANSI_P, ATTRS, IMPLICIT, COND) \
5640 def_builtin_1 (ENUM, NAME, CLASS, \
5641 builtin_types[(int) TYPE], \
5642 builtin_types[(int) LIBTYPE], \
5643 BOTH_P, FALLBACK_P, NONANSI_P, \
5644 built_in_attributes[(int) ATTRS], IMPLICIT);
5645 #include "builtins.def"
5649 /* ----------------------------------------------------------------------- *
5650 * BUILTIN FUNCTIONS *
5651 * ----------------------------------------------------------------------- */
5653 /* Install the builtin functions we might need. */
5656 gnat_install_builtins (void)
5658 install_builtin_elementary_types ();
5659 install_builtin_function_types ();
5660 install_builtin_attributes ();
5662 /* Install builtins used by generic middle-end pieces first. Some of these
5663 know about internal specificities and control attributes accordingly, for
5664 instance __builtin_alloca vs no-throw and -fstack-check. We will ignore
5665 the generic definition from builtins.def. */
5666 build_common_builtin_nodes ();
5668 /* Now, install the target specific builtins, such as the AltiVec family on
5669 ppc, and the common set as exposed by builtins.def. */
5670 targetm.init_builtins ();
5671 install_builtin_functions ();
5674 #include "gt-ada-utils.h"
5675 #include "gtype-ada.h"