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"
35 #include "tree-inline.h"
53 /* Convention_Stdcall should be processed in a specific way on 32 bits
54 Windows targets only. The macro below is a helper to avoid having to
55 check for a Windows specific attribute throughout this unit. */
57 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
59 #define Has_Stdcall_Convention(E) \
60 (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
62 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
65 #define Has_Stdcall_Convention(E) 0
68 /* Stack realignment is necessary for functions with foreign conventions when
69 the ABI doesn't mandate as much as what the compiler assumes - that is, up
70 to PREFERRED_STACK_BOUNDARY.
72 Such realignment can be requested with a dedicated function type attribute
73 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
74 characterize the situations where the attribute should be set. We rely on
75 compiler configuration settings for 'main' to decide. */
77 #ifdef MAIN_STACK_BOUNDARY
78 #define FOREIGN_FORCE_REALIGN_STACK \
79 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
81 #define FOREIGN_FORCE_REALIGN_STACK 0
86 struct incomplete *next;
91 /* These variables are used to defer recursively expanding incomplete types
92 while we are processing an array, a record or a subprogram type. */
93 static int defer_incomplete_level = 0;
94 static struct incomplete *defer_incomplete_list;
96 /* This variable is used to delay expanding From_With_Type types until the
98 static struct incomplete *defer_limited_with;
100 /* These variables are used to defer finalizing types. The element of the
101 list is the TYPE_DECL associated with the type. */
102 static int defer_finalize_level = 0;
103 static VEC (tree,heap) *defer_finalize_list;
105 typedef struct subst_pair_d {
110 DEF_VEC_O(subst_pair);
111 DEF_VEC_ALLOC_O(subst_pair,heap);
113 typedef struct variant_desc_d {
114 /* The type of the variant. */
117 /* The associated field. */
120 /* The value of the qualifier. */
123 /* The record associated with this variant. */
127 DEF_VEC_O(variant_desc);
128 DEF_VEC_ALLOC_O(variant_desc,heap);
130 /* A hash table used to cache the result of annotate_value. */
131 static GTY ((if_marked ("tree_int_map_marked_p"),
132 param_is (struct tree_int_map))) htab_t annotate_value_cache;
141 static void relate_alias_sets (tree, tree, enum alias_set_op);
143 static bool allocatable_size_p (tree, bool);
144 static void prepend_one_attribute_to (struct attrib **,
145 enum attr_type, tree, tree, Node_Id);
146 static void prepend_attributes (Entity_Id, struct attrib **);
147 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
148 static bool is_variable_size (tree);
149 static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool);
150 static tree elaborate_expression_2 (tree, Entity_Id, tree, bool, bool,
152 static tree make_packable_type (tree, bool);
153 static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
154 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
156 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
157 static bool same_discriminant_p (Entity_Id, Entity_Id);
158 static bool array_type_has_nonaliased_component (tree, Entity_Id);
159 static bool compile_time_known_address_p (Node_Id);
160 static bool cannot_be_superflat_p (Node_Id);
161 static bool constructor_address_p (tree);
162 static void components_to_record (tree, Node_Id, tree, int, bool, bool, bool,
163 bool, bool, bool, bool, tree *);
164 static Uint annotate_value (tree);
165 static void annotate_rep (Entity_Id, tree);
166 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
167 static VEC(subst_pair,heap) *build_subst_list (Entity_Id, Entity_Id, bool);
168 static VEC(variant_desc,heap) *build_variant_list (tree,
169 VEC(subst_pair,heap) *,
170 VEC(variant_desc,heap) *);
171 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
172 static void set_rm_size (Uint, tree, Entity_Id);
173 static tree make_type_from_size (tree, tree, bool);
174 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
175 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
176 static void check_ok_for_atomic (tree, Entity_Id, bool);
177 static tree create_field_decl_from (tree, tree, tree, tree, tree,
178 VEC(subst_pair,heap) *);
179 static tree get_rep_part (tree);
180 static tree create_variant_part_from (tree, VEC(variant_desc,heap) *, tree,
181 tree, VEC(subst_pair,heap) *);
182 static void copy_and_substitute_in_size (tree, tree, VEC(subst_pair,heap) *);
183 static void rest_of_type_decl_compilation_no_defer (tree);
185 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
186 to pass around calls performing profile compatibility checks. */
189 Entity_Id gnat_entity; /* The Ada subprogram entity. */
190 tree ada_fntype; /* The corresponding GCC type node. */
191 tree btin_fntype; /* The GCC builtin function type node. */
194 static bool intrin_profiles_compatible_p (intrin_binding_t *);
196 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
197 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
198 and associate the ..._DECL node with the input GNAT defining identifier.
200 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
201 initial value (in GCC tree form). This is optional for a variable. For
202 a renamed entity, GNU_EXPR gives the object being renamed.
204 DEFINITION is nonzero if this call is intended for a definition. This is
205 used for separate compilation where it is necessary to know whether an
206 external declaration or a definition must be created if the GCC equivalent
207 was not created previously. The value of 1 is normally used for a nonzero
208 DEFINITION, but a value of 2 is used in special circumstances, defined in
212 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
214 /* Contains the kind of the input GNAT node. */
215 const Entity_Kind kind = Ekind (gnat_entity);
216 /* True if this is a type. */
217 const bool is_type = IN (kind, Type_Kind);
218 /* True if debug info is requested for this entity. */
219 const bool debug_info_p = Needs_Debug_Info (gnat_entity);
220 /* True if this entity is to be considered as imported. */
221 const bool imported_p
222 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
223 /* For a type, contains the equivalent GNAT node to be used in gigi. */
224 Entity_Id gnat_equiv_type = Empty;
225 /* Temporary used to walk the GNAT tree. */
227 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
228 This node will be associated with the GNAT node by calling at the end
229 of the `switch' statement. */
230 tree gnu_decl = NULL_TREE;
231 /* Contains the GCC type to be used for the GCC node. */
232 tree gnu_type = NULL_TREE;
233 /* Contains the GCC size tree to be used for the GCC node. */
234 tree gnu_size = NULL_TREE;
235 /* Contains the GCC name to be used for the GCC node. */
236 tree gnu_entity_name;
237 /* True if we have already saved gnu_decl as a GNAT association. */
239 /* True if we incremented defer_incomplete_level. */
240 bool this_deferred = false;
241 /* True if we incremented force_global. */
242 bool this_global = false;
243 /* True if we should check to see if elaborated during processing. */
244 bool maybe_present = false;
245 /* True if we made GNU_DECL and its type here. */
246 bool this_made_decl = false;
247 /* Size and alignment of the GCC node, if meaningful. */
248 unsigned int esize = 0, align = 0;
249 /* Contains the list of attributes directly attached to the entity. */
250 struct attrib *attr_list = NULL;
252 /* Since a use of an Itype is a definition, process it as such if it
253 is not in a with'ed unit. */
256 && Is_Itype (gnat_entity)
257 && !present_gnu_tree (gnat_entity)
258 && In_Extended_Main_Code_Unit (gnat_entity))
260 /* Ensure that we are in a subprogram mentioned in the Scope chain of
261 this entity, our current scope is global, or we encountered a task
262 or entry (where we can't currently accurately check scoping). */
263 if (!current_function_decl
264 || DECL_ELABORATION_PROC_P (current_function_decl))
266 process_type (gnat_entity);
267 return get_gnu_tree (gnat_entity);
270 for (gnat_temp = Scope (gnat_entity);
272 gnat_temp = Scope (gnat_temp))
274 if (Is_Type (gnat_temp))
275 gnat_temp = Underlying_Type (gnat_temp);
277 if (Ekind (gnat_temp) == E_Subprogram_Body)
279 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
281 if (IN (Ekind (gnat_temp), Subprogram_Kind)
282 && Present (Protected_Body_Subprogram (gnat_temp)))
283 gnat_temp = Protected_Body_Subprogram (gnat_temp);
285 if (Ekind (gnat_temp) == E_Entry
286 || Ekind (gnat_temp) == E_Entry_Family
287 || Ekind (gnat_temp) == E_Task_Type
288 || (IN (Ekind (gnat_temp), Subprogram_Kind)
289 && present_gnu_tree (gnat_temp)
290 && (current_function_decl
291 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
293 process_type (gnat_entity);
294 return get_gnu_tree (gnat_entity);
298 /* This abort means the Itype has an incorrect scope, i.e. that its
299 scope does not correspond to the subprogram it is declared in. */
303 /* If we've already processed this entity, return what we got last time.
304 If we are defining the node, we should not have already processed it.
305 In that case, we will abort below when we try to save a new GCC tree
306 for this object. We also need to handle the case of getting a dummy
307 type when a Full_View exists. */
308 if ((!definition || (is_type && imported_p))
309 && present_gnu_tree (gnat_entity))
311 gnu_decl = get_gnu_tree (gnat_entity);
313 if (TREE_CODE (gnu_decl) == TYPE_DECL
314 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
315 && IN (kind, Incomplete_Or_Private_Kind)
316 && Present (Full_View (gnat_entity)))
319 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
320 save_gnu_tree (gnat_entity, NULL_TREE, false);
321 save_gnu_tree (gnat_entity, gnu_decl, false);
327 /* If this is a numeric or enumeral type, or an access type, a nonzero
328 Esize must be specified unless it was specified by the programmer. */
329 gcc_assert (!Unknown_Esize (gnat_entity)
330 || Has_Size_Clause (gnat_entity)
331 || (!IN (kind, Numeric_Kind)
332 && !IN (kind, Enumeration_Kind)
333 && (!IN (kind, Access_Kind)
334 || kind == E_Access_Protected_Subprogram_Type
335 || kind == E_Anonymous_Access_Protected_Subprogram_Type
336 || kind == E_Access_Subtype)));
338 /* The RM size must be specified for all discrete and fixed-point types. */
339 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
340 && Unknown_RM_Size (gnat_entity)));
342 /* If we get here, it means we have not yet done anything with this entity.
343 If we are not defining it, it must be a type or an entity that is defined
344 elsewhere or externally, otherwise we should have defined it already. */
345 gcc_assert (definition
346 || type_annotate_only
348 || kind == E_Discriminant
349 || kind == E_Component
351 || (kind == E_Constant && Present (Full_View (gnat_entity)))
352 || Is_Public (gnat_entity));
354 /* Get the name of the entity and set up the line number and filename of
355 the original definition for use in any decl we make. */
356 gnu_entity_name = get_entity_name (gnat_entity);
357 Sloc_to_locus (Sloc (gnat_entity), &input_location);
359 /* For cases when we are not defining (i.e., we are referencing from
360 another compilation unit) public entities, show we are at global level
361 for the purpose of computing scopes. Don't do this for components or
362 discriminants since the relevant test is whether or not the record is
363 being defined. Don't do this for constants either as we'll look into
364 their defining expression in the local context. */
366 && kind != E_Component
367 && kind != E_Discriminant
368 && kind != E_Constant
369 && Is_Public (gnat_entity)
370 && !Is_Statically_Allocated (gnat_entity))
371 force_global++, this_global = true;
373 /* Handle any attributes directly attached to the entity. */
374 if (Has_Gigi_Rep_Item (gnat_entity))
375 prepend_attributes (gnat_entity, &attr_list);
377 /* Do some common processing for types. */
380 /* Compute the equivalent type to be used in gigi. */
381 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
383 /* Machine_Attributes on types are expected to be propagated to
384 subtypes. The corresponding Gigi_Rep_Items are only attached
385 to the first subtype though, so we handle the propagation here. */
386 if (Base_Type (gnat_entity) != gnat_entity
387 && !Is_First_Subtype (gnat_entity)
388 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
389 prepend_attributes (First_Subtype (Base_Type (gnat_entity)),
392 /* Compute a default value for the size of the type. */
393 if (Known_Esize (gnat_entity)
394 && UI_Is_In_Int_Range (Esize (gnat_entity)))
396 unsigned int max_esize;
397 esize = UI_To_Int (Esize (gnat_entity));
399 if (IN (kind, Float_Kind))
400 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
401 else if (IN (kind, Access_Kind))
402 max_esize = POINTER_SIZE * 2;
404 max_esize = LONG_LONG_TYPE_SIZE;
406 if (esize > max_esize)
414 /* If this is a use of a deferred constant without address clause,
415 get its full definition. */
417 && No (Address_Clause (gnat_entity))
418 && Present (Full_View (gnat_entity)))
421 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
426 /* If we have an external constant that we are not defining, get the
427 expression that is was defined to represent. We may throw it away
428 later if it is not a constant. But do not retrieve the expression
429 if it is an allocator because the designated type might be dummy
432 && !No_Initialization (Declaration_Node (gnat_entity))
433 && Present (Expression (Declaration_Node (gnat_entity)))
434 && Nkind (Expression (Declaration_Node (gnat_entity)))
437 bool went_into_elab_proc = false;
439 /* The expression may contain N_Expression_With_Actions nodes and
440 thus object declarations from other units. In this case, even
441 though the expression will eventually be discarded since not a
442 constant, the declarations would be stuck either in the global
443 varpool or in the current scope. Therefore we force the local
444 context and create a fake scope that we'll zap at the end. */
445 if (!current_function_decl)
447 current_function_decl = get_elaboration_procedure ();
448 went_into_elab_proc = true;
452 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
455 if (went_into_elab_proc)
456 current_function_decl = NULL_TREE;
459 /* Ignore deferred constant definitions without address clause since
460 they are processed fully in the front-end. If No_Initialization
461 is set, this is not a deferred constant but a constant whose value
462 is built manually. And constants that are renamings are handled
466 && No (Address_Clause (gnat_entity))
467 && !No_Initialization (Declaration_Node (gnat_entity))
468 && No (Renamed_Object (gnat_entity)))
470 gnu_decl = error_mark_node;
475 /* Ignore constant definitions already marked with the error node. See
476 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
479 && present_gnu_tree (gnat_entity)
480 && get_gnu_tree (gnat_entity) == error_mark_node)
482 maybe_present = true;
489 /* We used to special case VMS exceptions here to directly map them to
490 their associated condition code. Since this code had to be masked
491 dynamically to strip off the severity bits, this caused trouble in
492 the GCC/ZCX case because the "type" pointers we store in the tables
493 have to be static. We now don't special case here anymore, and let
494 the regular processing take place, which leaves us with a regular
495 exception data object for VMS exceptions too. The condition code
496 mapping is taken care of by the front end and the bitmasking by the
503 /* The GNAT record where the component was defined. */
504 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
506 /* If the variable is an inherited record component (in the case of
507 extended record types), just return the inherited entity, which
508 must be a FIELD_DECL. Likewise for discriminants.
509 For discriminants of untagged records which have explicit
510 stored discriminants, return the entity for the corresponding
511 stored discriminant. Also use Original_Record_Component
512 if the record has a private extension. */
513 if (Present (Original_Record_Component (gnat_entity))
514 && Original_Record_Component (gnat_entity) != gnat_entity)
517 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
518 gnu_expr, definition);
523 /* If the enclosing record has explicit stored discriminants,
524 then it is an untagged record. If the Corresponding_Discriminant
525 is not empty then this must be a renamed discriminant and its
526 Original_Record_Component must point to the corresponding explicit
527 stored discriminant (i.e. we should have taken the previous
529 else if (Present (Corresponding_Discriminant (gnat_entity))
530 && Is_Tagged_Type (gnat_record))
532 /* A tagged record has no explicit stored discriminants. */
533 gcc_assert (First_Discriminant (gnat_record)
534 == First_Stored_Discriminant (gnat_record));
536 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
537 gnu_expr, definition);
542 else if (Present (CR_Discriminant (gnat_entity))
543 && type_annotate_only)
545 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
546 gnu_expr, definition);
551 /* If the enclosing record has explicit stored discriminants, then
552 it is an untagged record. If the Corresponding_Discriminant
553 is not empty then this must be a renamed discriminant and its
554 Original_Record_Component must point to the corresponding explicit
555 stored discriminant (i.e. we should have taken the first
557 else if (Present (Corresponding_Discriminant (gnat_entity))
558 && (First_Discriminant (gnat_record)
559 != First_Stored_Discriminant (gnat_record)))
562 /* Otherwise, if we are not defining this and we have no GCC type
563 for the containing record, make one for it. Then we should
564 have made our own equivalent. */
565 else if (!definition && !present_gnu_tree (gnat_record))
567 /* ??? If this is in a record whose scope is a protected
568 type and we have an Original_Record_Component, use it.
569 This is a workaround for major problems in protected type
571 Entity_Id Scop = Scope (Scope (gnat_entity));
572 if ((Is_Protected_Type (Scop)
573 || (Is_Private_Type (Scop)
574 && Present (Full_View (Scop))
575 && Is_Protected_Type (Full_View (Scop))))
576 && Present (Original_Record_Component (gnat_entity)))
579 = gnat_to_gnu_entity (Original_Record_Component
586 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
587 gnu_decl = get_gnu_tree (gnat_entity);
593 /* Here we have no GCC type and this is a reference rather than a
594 definition. This should never happen. Most likely the cause is
595 reference before declaration in the gnat tree for gnat_entity. */
599 case E_Loop_Parameter:
600 case E_Out_Parameter:
603 /* Simple variables, loop variables, Out parameters and exceptions. */
607 = ((kind == E_Constant || kind == E_Variable)
608 && Is_True_Constant (gnat_entity)
609 && !Treat_As_Volatile (gnat_entity)
610 && (((Nkind (Declaration_Node (gnat_entity))
611 == N_Object_Declaration)
612 && Present (Expression (Declaration_Node (gnat_entity))))
613 || Present (Renamed_Object (gnat_entity))
615 bool inner_const_flag = const_flag;
616 bool static_p = Is_Statically_Allocated (gnat_entity);
617 bool mutable_p = false;
618 bool used_by_ref = false;
619 tree gnu_ext_name = NULL_TREE;
620 tree renamed_obj = NULL_TREE;
621 tree gnu_object_size;
623 if (Present (Renamed_Object (gnat_entity)) && !definition)
625 if (kind == E_Exception)
626 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
629 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
632 /* Get the type after elaborating the renamed object. */
633 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
635 /* If this is a standard exception definition, then use the standard
636 exception type. This is necessary to make sure that imported and
637 exported views of exceptions are properly merged in LTO mode. */
638 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
639 && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
640 gnu_type = except_type_node;
642 /* For a debug renaming declaration, build a debug-only entity. */
643 if (Present (Debug_Renaming_Link (gnat_entity)))
645 /* Force a non-null value to make sure the symbol is retained. */
646 tree value = build1 (INDIRECT_REF, gnu_type,
648 build_pointer_type (gnu_type),
649 integer_minus_one_node));
650 gnu_decl = build_decl (input_location,
651 VAR_DECL, gnu_entity_name, gnu_type);
652 SET_DECL_VALUE_EXPR (gnu_decl, value);
653 DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
654 gnat_pushdecl (gnu_decl, gnat_entity);
658 /* If this is a loop variable, its type should be the base type.
659 This is because the code for processing a loop determines whether
660 a normal loop end test can be done by comparing the bounds of the
661 loop against those of the base type, which is presumed to be the
662 size used for computation. But this is not correct when the size
663 of the subtype is smaller than the type. */
664 if (kind == E_Loop_Parameter)
665 gnu_type = get_base_type (gnu_type);
667 /* Reject non-renamed objects whose type is an unconstrained array or
668 any object whose type is a dummy type or void. */
669 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
670 && No (Renamed_Object (gnat_entity)))
671 || TYPE_IS_DUMMY_P (gnu_type)
672 || TREE_CODE (gnu_type) == VOID_TYPE)
674 gcc_assert (type_annotate_only);
677 return error_mark_node;
680 /* If an alignment is specified, use it if valid. Note that exceptions
681 are objects but don't have an alignment. We must do this before we
682 validate the size, since the alignment can affect the size. */
683 if (kind != E_Exception && Known_Alignment (gnat_entity))
685 gcc_assert (Present (Alignment (gnat_entity)));
687 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
688 TYPE_ALIGN (gnu_type));
690 /* No point in changing the type if there is an address clause
691 as the final type of the object will be a reference type. */
692 if (Present (Address_Clause (gnat_entity)))
696 tree orig_type = gnu_type;
699 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
700 false, false, definition, true);
702 /* If a padding record was made, declare it now since it will
703 never be declared otherwise. This is necessary to ensure
704 that its subtrees are properly marked. */
705 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
706 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
707 debug_info_p, gnat_entity);
711 /* If we are defining the object, see if it has a Size and validate it
712 if so. If we are not defining the object and a Size clause applies,
713 simply retrieve the value. We don't want to ignore the clause and
714 it is expected to have been validated already. Then get the new
717 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
718 gnat_entity, VAR_DECL, false,
719 Has_Size_Clause (gnat_entity));
720 else if (Has_Size_Clause (gnat_entity))
721 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
726 = make_type_from_size (gnu_type, gnu_size,
727 Has_Biased_Representation (gnat_entity));
729 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
730 gnu_size = NULL_TREE;
733 /* If this object has self-referential size, it must be a record with
734 a default discriminant. We are supposed to allocate an object of
735 the maximum size in this case, unless it is a constant with an
736 initializing expression, in which case we can get the size from
737 that. Note that the resulting size may still be a variable, so
738 this may end up with an indirect allocation. */
739 if (No (Renamed_Object (gnat_entity))
740 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
742 if (gnu_expr && kind == E_Constant)
744 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
745 if (CONTAINS_PLACEHOLDER_P (size))
747 /* If the initializing expression is itself a constant,
748 despite having a nominal type with self-referential
749 size, we can get the size directly from it. */
750 if (TREE_CODE (gnu_expr) == COMPONENT_REF
752 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
753 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
754 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
755 || DECL_READONLY_ONCE_ELAB
756 (TREE_OPERAND (gnu_expr, 0))))
757 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
760 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
765 /* We may have no GNU_EXPR because No_Initialization is
766 set even though there's an Expression. */
767 else if (kind == E_Constant
768 && (Nkind (Declaration_Node (gnat_entity))
769 == N_Object_Declaration)
770 && Present (Expression (Declaration_Node (gnat_entity))))
772 = TYPE_SIZE (gnat_to_gnu_type
774 (Expression (Declaration_Node (gnat_entity)))));
777 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
782 /* If the size is zero byte, make it one byte since some linkers have
783 troubles with zero-sized objects. If the object will have a
784 template, that will make it nonzero so don't bother. Also avoid
785 doing that for an object renaming or an object with an address
786 clause, as we would lose useful information on the view size
787 (e.g. for null array slices) and we are not allocating the object
790 && integer_zerop (gnu_size)
791 && !TREE_OVERFLOW (gnu_size))
792 || (TYPE_SIZE (gnu_type)
793 && integer_zerop (TYPE_SIZE (gnu_type))
794 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
795 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
796 || !Is_Array_Type (Etype (gnat_entity)))
797 && No (Renamed_Object (gnat_entity))
798 && No (Address_Clause (gnat_entity)))
799 gnu_size = bitsize_unit_node;
801 /* If this is an object with no specified size and alignment, and
802 if either it is atomic or we are not optimizing alignment for
803 space and it is composite and not an exception, an Out parameter
804 or a reference to another object, and the size of its type is a
805 constant, set the alignment to the smallest one which is not
806 smaller than the size, with an appropriate cap. */
807 if (!gnu_size && align == 0
808 && (Is_Atomic (gnat_entity)
809 || (!Optimize_Alignment_Space (gnat_entity)
810 && kind != E_Exception
811 && kind != E_Out_Parameter
812 && Is_Composite_Type (Etype (gnat_entity))
813 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
814 && !Is_Exported (gnat_entity)
816 && No (Renamed_Object (gnat_entity))
817 && No (Address_Clause (gnat_entity))))
818 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
820 /* No point in jumping through all the hoops needed in order
821 to support BIGGEST_ALIGNMENT if we don't really have to.
822 So we cap to the smallest alignment that corresponds to
823 a known efficient memory access pattern of the target. */
824 unsigned int align_cap = Is_Atomic (gnat_entity)
826 : get_mode_alignment (ptr_mode);
828 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
829 || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
832 align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
834 /* But make sure not to under-align the object. */
835 if (align <= TYPE_ALIGN (gnu_type))
838 /* And honor the minimum valid atomic alignment, if any. */
839 #ifdef MINIMUM_ATOMIC_ALIGNMENT
840 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
841 align = MINIMUM_ATOMIC_ALIGNMENT;
845 /* If the object is set to have atomic components, find the component
846 type and validate it.
848 ??? Note that we ignore Has_Volatile_Components on objects; it's
849 not at all clear what to do in that case. */
850 if (Has_Atomic_Components (gnat_entity))
852 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
853 ? TREE_TYPE (gnu_type) : gnu_type);
855 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
856 && TYPE_MULTI_ARRAY_P (gnu_inner))
857 gnu_inner = TREE_TYPE (gnu_inner);
859 check_ok_for_atomic (gnu_inner, gnat_entity, true);
862 /* Now check if the type of the object allows atomic access. Note
863 that we must test the type, even if this object has size and
864 alignment to allow such access, because we will be going inside
865 the padded record to assign to the object. We could fix this by
866 always copying via an intermediate value, but it's not clear it's
868 if (Is_Atomic (gnat_entity))
869 check_ok_for_atomic (gnu_type, gnat_entity, false);
871 /* If this is an aliased object with an unconstrained nominal subtype,
872 make a type that includes the template. */
873 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
874 && Is_Array_Type (Etype (gnat_entity))
875 && !type_annotate_only)
878 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
880 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
881 concat_name (gnu_entity_name,
886 #ifdef MINIMUM_ATOMIC_ALIGNMENT
887 /* If the size is a constant and no alignment is specified, force
888 the alignment to be the minimum valid atomic alignment. The
889 restriction on constant size avoids problems with variable-size
890 temporaries; if the size is variable, there's no issue with
891 atomic access. Also don't do this for a constant, since it isn't
892 necessary and can interfere with constant replacement. Finally,
893 do not do it for Out parameters since that creates an
894 size inconsistency with In parameters. */
895 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
896 && !FLOAT_TYPE_P (gnu_type)
897 && !const_flag && No (Renamed_Object (gnat_entity))
898 && !imported_p && No (Address_Clause (gnat_entity))
899 && kind != E_Out_Parameter
900 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
901 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
902 align = MINIMUM_ATOMIC_ALIGNMENT;
905 /* Make a new type with the desired size and alignment, if needed.
906 But do not take into account alignment promotions to compute the
907 size of the object. */
908 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
909 if (gnu_size || align > 0)
911 tree orig_type = gnu_type;
913 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
914 false, false, definition,
915 gnu_size ? true : false);
917 /* If a padding record was made, declare it now since it will
918 never be declared otherwise. This is necessary to ensure
919 that its subtrees are properly marked. */
920 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
921 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
922 debug_info_p, gnat_entity);
925 /* If this is a renaming, avoid as much as possible to create a new
926 object. However, in several cases, creating it is required.
927 This processing needs to be applied to the raw expression so
928 as to make it more likely to rename the underlying object. */
929 if (Present (Renamed_Object (gnat_entity)))
931 bool create_normal_object = false;
933 /* If the renamed object had padding, strip off the reference
934 to the inner object and reset our type. */
935 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
936 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
937 /* Strip useless conversions around the object. */
938 || (TREE_CODE (gnu_expr) == NOP_EXPR
939 && gnat_types_compatible_p
940 (TREE_TYPE (gnu_expr),
941 TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
943 gnu_expr = TREE_OPERAND (gnu_expr, 0);
944 gnu_type = TREE_TYPE (gnu_expr);
947 /* Case 1: If this is a constant renaming stemming from a function
948 call, treat it as a normal object whose initial value is what
949 is being renamed. RM 3.3 says that the result of evaluating a
950 function call is a constant object. As a consequence, it can
951 be the inner object of a constant renaming. In this case, the
952 renaming must be fully instantiated, i.e. it cannot be a mere
953 reference to (part of) an existing object. */
956 tree inner_object = gnu_expr;
957 while (handled_component_p (inner_object))
958 inner_object = TREE_OPERAND (inner_object, 0);
959 if (TREE_CODE (inner_object) == CALL_EXPR)
960 create_normal_object = true;
963 /* Otherwise, see if we can proceed with a stabilized version of
964 the renamed entity or if we need to make a new object. */
965 if (!create_normal_object)
967 tree maybe_stable_expr = NULL_TREE;
970 /* Case 2: If the renaming entity need not be materialized and
971 the renamed expression is something we can stabilize, use
972 that for the renaming. At the global level, we can only do
973 this if we know no SAVE_EXPRs need be made, because the
974 expression we return might be used in arbitrary conditional
975 branches so we must force the evaluation of the SAVE_EXPRs
976 immediately and this requires a proper function context.
977 Note that an external constant is at the global level. */
978 if (!Materialize_Entity (gnat_entity)
979 && (!((!definition && kind == E_Constant)
980 || global_bindings_p ())
981 || (staticp (gnu_expr)
982 && !TREE_SIDE_EFFECTS (gnu_expr))))
985 = gnat_stabilize_reference (gnu_expr, true, &stable);
989 /* ??? No DECL_EXPR is created so we need to mark
990 the expression manually lest it is shared. */
991 if ((!definition && kind == E_Constant)
992 || global_bindings_p ())
993 MARK_VISITED (maybe_stable_expr);
994 gnu_decl = maybe_stable_expr;
995 save_gnu_tree (gnat_entity, gnu_decl, true);
997 annotate_object (gnat_entity, gnu_type, NULL_TREE,
1002 /* The stabilization failed. Keep maybe_stable_expr
1003 untouched here to let the pointer case below know
1004 about that failure. */
1007 /* Case 3: If this is a constant renaming and creating a
1008 new object is allowed and cheap, treat it as a normal
1009 object whose initial value is what is being renamed. */
1011 && !Is_Composite_Type
1012 (Underlying_Type (Etype (gnat_entity))))
1015 /* Case 4: Make this into a constant pointer to the object we
1016 are to rename and attach the object to the pointer if it is
1017 something we can stabilize.
1019 From the proper scope, attached objects will be referenced
1020 directly instead of indirectly via the pointer to avoid
1021 subtle aliasing problems with non-addressable entities.
1022 They have to be stable because we must not evaluate the
1023 variables in the expression every time the renaming is used.
1024 The pointer is called a "renaming" pointer in this case.
1026 In the rare cases where we cannot stabilize the renamed
1027 object, we just make a "bare" pointer, and the renamed
1028 entity is always accessed indirectly through it. */
1031 gnu_type = build_reference_type (gnu_type);
1032 inner_const_flag = TREE_READONLY (gnu_expr);
1035 /* If the previous attempt at stabilizing failed, there
1036 is no point in trying again and we reuse the result
1037 without attaching it to the pointer. In this case it
1038 will only be used as the initializing expression of
1039 the pointer and thus needs no special treatment with
1040 regard to multiple evaluations. */
1041 if (maybe_stable_expr)
1044 /* Otherwise, try to stabilize and attach the expression
1045 to the pointer if the stabilization succeeds.
1047 Note that this might introduce SAVE_EXPRs and we don't
1048 check whether we're at the global level or not. This
1049 is fine since we are building a pointer initializer and
1050 neither the pointer nor the initializing expression can
1051 be accessed before the pointer elaboration has taken
1052 place in a correct program.
1054 These SAVE_EXPRs will be evaluated at the right place
1055 by either the evaluation of the initializer for the
1056 non-global case or the elaboration code for the global
1057 case, and will be attached to the elaboration procedure
1058 in the latter case. */
1062 = gnat_stabilize_reference (gnu_expr, true, &stable);
1065 renamed_obj = maybe_stable_expr;
1067 /* Attaching is actually performed downstream, as soon
1068 as we have a VAR_DECL for the pointer we make. */
1071 gnu_expr = build_unary_op (ADDR_EXPR, gnu_type,
1074 gnu_size = NULL_TREE;
1080 /* Make a volatile version of this object's type if we are to make
1081 the object volatile. We also interpret 13.3(19) conservatively
1082 and disallow any optimizations for such a non-constant object. */
1083 if ((Treat_As_Volatile (gnat_entity)
1085 && gnu_type != except_type_node
1086 && (Is_Exported (gnat_entity)
1088 || Present (Address_Clause (gnat_entity)))))
1089 && !TYPE_VOLATILE (gnu_type))
1090 gnu_type = build_qualified_type (gnu_type,
1091 (TYPE_QUALS (gnu_type)
1092 | TYPE_QUAL_VOLATILE));
1094 /* If we are defining an aliased object whose nominal subtype is
1095 unconstrained, the object is a record that contains both the
1096 template and the object. If there is an initializer, it will
1097 have already been converted to the right type, but we need to
1098 create the template if there is no initializer. */
1101 && TREE_CODE (gnu_type) == RECORD_TYPE
1102 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1103 /* Beware that padding might have been introduced above. */
1104 || (TYPE_PADDING_P (gnu_type)
1105 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1107 && TYPE_CONTAINS_TEMPLATE_P
1108 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1111 = TYPE_PADDING_P (gnu_type)
1112 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1113 : TYPE_FIELDS (gnu_type);
1114 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1);
1115 tree t = build_template (TREE_TYPE (template_field),
1116 TREE_TYPE (DECL_CHAIN (template_field)),
1118 CONSTRUCTOR_APPEND_ELT (v, template_field, t);
1119 gnu_expr = gnat_build_constructor (gnu_type, v);
1122 /* Convert the expression to the type of the object except in the
1123 case where the object's type is unconstrained or the object's type
1124 is a padded record whose field is of self-referential size. In
1125 the former case, converting will generate unnecessary evaluations
1126 of the CONSTRUCTOR to compute the size and in the latter case, we
1127 want to only copy the actual data. */
1129 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1130 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1131 && !(TYPE_IS_PADDING_P (gnu_type)
1132 && CONTAINS_PLACEHOLDER_P
1133 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1134 gnu_expr = convert (gnu_type, gnu_expr);
1136 /* If this is a pointer that doesn't have an initializing expression,
1137 initialize it to NULL, unless the object is imported. */
1139 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1141 && !Is_Imported (gnat_entity))
1142 gnu_expr = integer_zero_node;
1144 /* If we are defining the object and it has an Address clause, we must
1145 either get the address expression from the saved GCC tree for the
1146 object if it has a Freeze node, or elaborate the address expression
1147 here since the front-end has guaranteed that the elaboration has no
1148 effects in this case. */
1149 if (definition && Present (Address_Clause (gnat_entity)))
1151 Node_Id gnat_expr = Expression (Address_Clause (gnat_entity));
1153 = present_gnu_tree (gnat_entity)
1154 ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
1156 save_gnu_tree (gnat_entity, NULL_TREE, false);
1158 /* Ignore the size. It's either meaningless or was handled
1160 gnu_size = NULL_TREE;
1161 /* Convert the type of the object to a reference type that can
1162 alias everything as per 13.3(19). */
1164 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1165 gnu_address = convert (gnu_type, gnu_address);
1168 = !Is_Public (gnat_entity)
1169 || compile_time_known_address_p (gnat_expr);
1171 /* If this is a deferred constant, the initializer is attached to
1173 if (kind == E_Constant && Present (Full_View (gnat_entity)))
1176 (Expression (Declaration_Node (Full_View (gnat_entity))));
1178 /* If we don't have an initializing expression for the underlying
1179 variable, the initializing expression for the pointer is the
1180 specified address. Otherwise, we have to make a COMPOUND_EXPR
1181 to assign both the address and the initial value. */
1183 gnu_expr = gnu_address;
1186 = build2 (COMPOUND_EXPR, gnu_type,
1188 (MODIFY_EXPR, NULL_TREE,
1189 build_unary_op (INDIRECT_REF, NULL_TREE,
1195 /* If it has an address clause and we are not defining it, mark it
1196 as an indirect object. Likewise for Stdcall objects that are
1198 if ((!definition && Present (Address_Clause (gnat_entity)))
1199 || (Is_Imported (gnat_entity)
1200 && Has_Stdcall_Convention (gnat_entity)))
1202 /* Convert the type of the object to a reference type that can
1203 alias everything as per 13.3(19). */
1205 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1206 gnu_size = NULL_TREE;
1208 /* No point in taking the address of an initializing expression
1209 that isn't going to be used. */
1210 gnu_expr = NULL_TREE;
1212 /* If it has an address clause whose value is known at compile
1213 time, make the object a CONST_DECL. This will avoid a
1214 useless dereference. */
1215 if (Present (Address_Clause (gnat_entity)))
1217 Node_Id gnat_address
1218 = Expression (Address_Clause (gnat_entity));
1220 if (compile_time_known_address_p (gnat_address))
1222 gnu_expr = gnat_to_gnu (gnat_address);
1230 /* If we are at top level and this object is of variable size,
1231 make the actual type a hidden pointer to the real type and
1232 make the initializer be a memory allocation and initialization.
1233 Likewise for objects we aren't defining (presumed to be
1234 external references from other packages), but there we do
1235 not set up an initialization.
1237 If the object's size overflows, make an allocator too, so that
1238 Storage_Error gets raised. Note that we will never free
1239 such memory, so we presume it never will get allocated. */
1240 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1241 global_bindings_p ()
1244 || (gnu_size && !allocatable_size_p (gnu_size,
1245 global_bindings_p ()
1249 gnu_type = build_reference_type (gnu_type);
1250 gnu_size = NULL_TREE;
1253 /* In case this was a aliased object whose nominal subtype is
1254 unconstrained, the pointer above will be a thin pointer and
1255 build_allocator will automatically make the template.
1257 If we have a template initializer only (that we made above),
1258 pretend there is none and rely on what build_allocator creates
1259 again anyway. Otherwise (if we have a full initializer), get
1260 the data part and feed that to build_allocator.
1262 If we are elaborating a mutable object, tell build_allocator to
1263 ignore a possibly simpler size from the initializer, if any, as
1264 we must allocate the maximum possible size in this case. */
1265 if (definition && !imported_p)
1267 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1269 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1270 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1273 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1275 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1276 && 1 == VEC_length (constructor_elt,
1277 CONSTRUCTOR_ELTS (gnu_expr)))
1281 = build_component_ref
1282 (gnu_expr, NULL_TREE,
1283 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1287 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1288 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)))
1289 post_error ("?`Storage_Error` will be raised at run time!",
1293 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1294 Empty, Empty, gnat_entity, mutable_p);
1299 gnu_expr = NULL_TREE;
1304 /* If this object would go into the stack and has an alignment larger
1305 than the largest stack alignment the back-end can honor, resort to
1306 a variable of "aligning type". */
1307 if (!global_bindings_p () && !static_p && definition
1308 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1310 /* Create the new variable. No need for extra room before the
1311 aligned field as this is in automatic storage. */
1313 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1314 TYPE_SIZE_UNIT (gnu_type),
1315 BIGGEST_ALIGNMENT, 0);
1317 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1318 NULL_TREE, gnu_new_type, NULL_TREE, false,
1319 false, false, false, NULL, gnat_entity);
1321 /* Initialize the aligned field if we have an initializer. */
1324 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1326 (gnu_new_var, NULL_TREE,
1327 TYPE_FIELDS (gnu_new_type), false),
1331 /* And setup this entity as a reference to the aligned field. */
1332 gnu_type = build_reference_type (gnu_type);
1335 (ADDR_EXPR, gnu_type,
1336 build_component_ref (gnu_new_var, NULL_TREE,
1337 TYPE_FIELDS (gnu_new_type), false));
1339 gnu_size = NULL_TREE;
1345 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1346 | TYPE_QUAL_CONST));
1348 /* Convert the expression to the type of the object except in the
1349 case where the object's type is unconstrained or the object's type
1350 is a padded record whose field is of self-referential size. In
1351 the former case, converting will generate unnecessary evaluations
1352 of the CONSTRUCTOR to compute the size and in the latter case, we
1353 want to only copy the actual data. */
1355 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1356 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1357 && !(TYPE_IS_PADDING_P (gnu_type)
1358 && CONTAINS_PLACEHOLDER_P
1359 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1360 gnu_expr = convert (gnu_type, gnu_expr);
1362 /* If this name is external or there was a name specified, use it,
1363 unless this is a VMS exception object since this would conflict
1364 with the symbol we need to export in addition. Don't use the
1365 Interface_Name if there is an address clause (see CD30005). */
1366 if (!Is_VMS_Exception (gnat_entity)
1367 && ((Present (Interface_Name (gnat_entity))
1368 && No (Address_Clause (gnat_entity)))
1369 || (Is_Public (gnat_entity)
1370 && (!Is_Imported (gnat_entity)
1371 || Is_Exported (gnat_entity)))))
1372 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1374 /* If this is an aggregate constant initialized to a constant, force it
1375 to be statically allocated. This saves an initialization copy. */
1378 && gnu_expr && TREE_CONSTANT (gnu_expr)
1379 && AGGREGATE_TYPE_P (gnu_type)
1380 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1381 && !(TYPE_IS_PADDING_P (gnu_type)
1382 && !host_integerp (TYPE_SIZE_UNIT
1383 (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
1386 /* Now create the variable or the constant and set various flags. */
1388 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1389 gnu_expr, const_flag, Is_Public (gnat_entity),
1390 imported_p || !definition, static_p, attr_list,
1392 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1393 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1395 /* If we are defining an Out parameter and optimization isn't enabled,
1396 create a fake PARM_DECL for debugging purposes and make it point to
1397 the VAR_DECL. Suppress debug info for the latter but make sure it
1398 will live on the stack so that it can be accessed from within the
1399 debugger through the PARM_DECL. */
1400 if (kind == E_Out_Parameter && definition && !optimize && debug_info_p)
1402 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1403 gnat_pushdecl (param, gnat_entity);
1404 SET_DECL_VALUE_EXPR (param, gnu_decl);
1405 DECL_HAS_VALUE_EXPR_P (param) = 1;
1406 DECL_IGNORED_P (gnu_decl) = 1;
1407 TREE_ADDRESSABLE (gnu_decl) = 1;
1410 /* If this is a renaming pointer, attach the renamed object to it and
1411 register it if we are at the global level. Note that an external
1412 constant is at the global level. */
1413 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1415 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1416 if ((!definition && kind == E_Constant) || global_bindings_p ())
1418 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1419 record_global_renaming_pointer (gnu_decl);
1423 /* If this is a constant and we are defining it or it generates a real
1424 symbol at the object level and we are referencing it, we may want
1425 or need to have a true variable to represent it:
1426 - if optimization isn't enabled, for debugging purposes,
1427 - if the constant is public and not overlaid on something else,
1428 - if its address is taken,
1429 - if either itself or its type is aliased. */
1430 if (TREE_CODE (gnu_decl) == CONST_DECL
1431 && (definition || Sloc (gnat_entity) > Standard_Location)
1432 && ((!optimize && debug_info_p)
1433 || (Is_Public (gnat_entity)
1434 && No (Address_Clause (gnat_entity)))
1435 || Address_Taken (gnat_entity)
1436 || Is_Aliased (gnat_entity)
1437 || Is_Aliased (Etype (gnat_entity))))
1440 = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1441 gnu_expr, true, Is_Public (gnat_entity),
1442 !definition, static_p, attr_list,
1445 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1447 /* As debugging information will be generated for the variable,
1448 do not generate debugging information for the constant. */
1450 DECL_IGNORED_P (gnu_decl) = 1;
1452 DECL_IGNORED_P (gnu_corr_var) = 1;
1455 /* If this is a constant, even if we don't need a true variable, we
1456 may need to avoid returning the initializer in every case. That
1457 can happen for the address of a (constant) constructor because,
1458 upon dereferencing it, the constructor will be reinjected in the
1459 tree, which may not be valid in every case; see lvalue_required_p
1460 for more details. */
1461 if (TREE_CODE (gnu_decl) == CONST_DECL)
1462 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1464 /* If this object is declared in a block that contains a block with an
1465 exception handler, and we aren't using the GCC exception mechanism,
1466 we must force this variable in memory in order to avoid an invalid
1468 if (Exception_Mechanism != Back_End_Exceptions
1469 && Has_Nested_Block_With_Handler (Scope (gnat_entity)))
1470 TREE_ADDRESSABLE (gnu_decl) = 1;
1472 /* If we are defining an object with variable size or an object with
1473 fixed size that will be dynamically allocated, and we are using the
1474 setjmp/longjmp exception mechanism, update the setjmp buffer. */
1476 && Exception_Mechanism == Setjmp_Longjmp
1477 && get_block_jmpbuf_decl ()
1478 && DECL_SIZE_UNIT (gnu_decl)
1479 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1480 || (flag_stack_check == GENERIC_STACK_CHECK
1481 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1482 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1483 add_stmt_with_node (build_call_1_expr
1484 (update_setjmp_buf_decl,
1485 build_unary_op (ADDR_EXPR, NULL_TREE,
1486 get_block_jmpbuf_decl ())),
1489 /* Back-annotate Esize and Alignment of the object if not already
1490 known. Note that we pick the values of the type, not those of
1491 the object, to shield ourselves from low-level platform-dependent
1492 adjustments like alignment promotion. This is both consistent with
1493 all the treatment above, where alignment and size are set on the
1494 type of the object and not on the object directly, and makes it
1495 possible to support all confirming representation clauses. */
1496 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1497 used_by_ref, false);
1502 /* Return a TYPE_DECL for "void" that we previously made. */
1503 gnu_decl = TYPE_NAME (void_type_node);
1506 case E_Enumeration_Type:
1507 /* A special case: for the types Character and Wide_Character in
1508 Standard, we do not list all the literals. So if the literals
1509 are not specified, make this an unsigned type. */
1510 if (No (First_Literal (gnat_entity)))
1512 gnu_type = make_unsigned_type (esize);
1513 TYPE_NAME (gnu_type) = gnu_entity_name;
1515 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1516 This is needed by the DWARF-2 back-end to distinguish between
1517 unsigned integer types and character types. */
1518 TYPE_STRING_FLAG (gnu_type) = 1;
1523 /* We have a list of enumeral constants in First_Literal. We make a
1524 CONST_DECL for each one and build into GNU_LITERAL_LIST the list to
1525 be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST
1526 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1527 value of the literal. But when we have a regular boolean type, we
1528 simplify this a little by using a BOOLEAN_TYPE. */
1529 bool is_boolean = Is_Boolean_Type (gnat_entity)
1530 && !Has_Non_Standard_Rep (gnat_entity);
1531 tree gnu_literal_list = NULL_TREE;
1532 Entity_Id gnat_literal;
1534 if (Is_Unsigned_Type (gnat_entity))
1535 gnu_type = make_unsigned_type (esize);
1537 gnu_type = make_signed_type (esize);
1539 TREE_SET_CODE (gnu_type, is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1541 for (gnat_literal = First_Literal (gnat_entity);
1542 Present (gnat_literal);
1543 gnat_literal = Next_Literal (gnat_literal))
1546 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1548 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1549 gnu_type, gnu_value, true, false, false,
1550 false, NULL, gnat_literal);
1551 /* Do not generate debug info for individual enumerators. */
1552 DECL_IGNORED_P (gnu_literal) = 1;
1553 save_gnu_tree (gnat_literal, gnu_literal, false);
1554 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1555 gnu_value, gnu_literal_list);
1559 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1561 /* Note that the bounds are updated at the end of this function
1562 to avoid an infinite recursion since they refer to the type. */
1566 case E_Signed_Integer_Type:
1567 case E_Ordinary_Fixed_Point_Type:
1568 case E_Decimal_Fixed_Point_Type:
1569 /* For integer types, just make a signed type the appropriate number
1571 gnu_type = make_signed_type (esize);
1574 case E_Modular_Integer_Type:
1576 /* For modular types, make the unsigned type of the proper number
1577 of bits and then set up the modulus, if required. */
1578 tree gnu_modulus, gnu_high = NULL_TREE;
1580 /* Packed array types are supposed to be subtypes only. */
1581 gcc_assert (!Is_Packed_Array_Type (gnat_entity));
1583 gnu_type = make_unsigned_type (esize);
1585 /* Get the modulus in this type. If it overflows, assume it is because
1586 it is equal to 2**Esize. Note that there is no overflow checking
1587 done on unsigned type, so we detect the overflow by looking for
1588 a modulus of zero, which is otherwise invalid. */
1589 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1591 if (!integer_zerop (gnu_modulus))
1593 TYPE_MODULAR_P (gnu_type) = 1;
1594 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1595 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1596 convert (gnu_type, integer_one_node));
1599 /* If the upper bound is not maximal, make an extra subtype. */
1601 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1603 tree gnu_subtype = make_unsigned_type (esize);
1604 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1605 TREE_TYPE (gnu_subtype) = gnu_type;
1606 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1607 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1608 gnu_type = gnu_subtype;
1613 case E_Signed_Integer_Subtype:
1614 case E_Enumeration_Subtype:
1615 case E_Modular_Integer_Subtype:
1616 case E_Ordinary_Fixed_Point_Subtype:
1617 case E_Decimal_Fixed_Point_Subtype:
1619 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1620 not want to call create_range_type since we would like each subtype
1621 node to be distinct. ??? Historically this was in preparation for
1622 when memory aliasing is implemented, but that's obsolete now given
1623 the call to relate_alias_sets below.
1625 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1626 this fact is used by the arithmetic conversion functions.
1628 We elaborate the Ancestor_Subtype if it is not in the current unit
1629 and one of our bounds is non-static. We do this to ensure consistent
1630 naming in the case where several subtypes share the same bounds, by
1631 elaborating the first such subtype first, thus using its name. */
1634 && Present (Ancestor_Subtype (gnat_entity))
1635 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1636 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1637 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1638 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1640 /* Set the precision to the Esize except for bit-packed arrays. */
1641 if (Is_Packed_Array_Type (gnat_entity)
1642 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1643 esize = UI_To_Int (RM_Size (gnat_entity));
1645 /* This should be an unsigned type if the base type is unsigned or
1646 if the lower bound is constant and non-negative or if the type
1648 if (Is_Unsigned_Type (Etype (gnat_entity))
1649 || Is_Unsigned_Type (gnat_entity)
1650 || Has_Biased_Representation (gnat_entity))
1651 gnu_type = make_unsigned_type (esize);
1653 gnu_type = make_signed_type (esize);
1654 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1656 SET_TYPE_RM_MIN_VALUE
1658 convert (TREE_TYPE (gnu_type),
1659 elaborate_expression (Type_Low_Bound (gnat_entity),
1660 gnat_entity, get_identifier ("L"),
1662 Needs_Debug_Info (gnat_entity))));
1664 SET_TYPE_RM_MAX_VALUE
1666 convert (TREE_TYPE (gnu_type),
1667 elaborate_expression (Type_High_Bound (gnat_entity),
1668 gnat_entity, get_identifier ("U"),
1670 Needs_Debug_Info (gnat_entity))));
1672 /* One of the above calls might have caused us to be elaborated,
1673 so don't blow up if so. */
1674 if (present_gnu_tree (gnat_entity))
1676 maybe_present = true;
1680 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1681 = Has_Biased_Representation (gnat_entity);
1683 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1684 TYPE_STUB_DECL (gnu_type)
1685 = create_type_stub_decl (gnu_entity_name, gnu_type);
1687 /* Inherit our alias set from what we're a subtype of. Subtypes
1688 are not different types and a pointer can designate any instance
1689 within a subtype hierarchy. */
1690 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1692 /* For a packed array, make the original array type a parallel type. */
1694 && Is_Packed_Array_Type (gnat_entity)
1695 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1696 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1698 (Original_Array_Type (gnat_entity)));
1702 /* We have to handle clauses that under-align the type specially. */
1703 if ((Present (Alignment_Clause (gnat_entity))
1704 || (Is_Packed_Array_Type (gnat_entity)
1706 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1707 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1709 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1710 if (align >= TYPE_ALIGN (gnu_type))
1714 /* If the type we are dealing with represents a bit-packed array,
1715 we need to have the bits left justified on big-endian targets
1716 and right justified on little-endian targets. We also need to
1717 ensure that when the value is read (e.g. for comparison of two
1718 such values), we only get the good bits, since the unused bits
1719 are uninitialized. Both goals are accomplished by wrapping up
1720 the modular type in an enclosing record type. */
1721 if (Is_Packed_Array_Type (gnat_entity)
1722 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1724 tree gnu_field_type, gnu_field;
1726 /* Set the RM size before wrapping up the original type. */
1727 SET_TYPE_RM_SIZE (gnu_type,
1728 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1729 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1731 /* Create a stripped-down declaration, mainly for debugging. */
1732 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1733 debug_info_p, gnat_entity);
1735 /* Now save it and build the enclosing record type. */
1736 gnu_field_type = gnu_type;
1738 gnu_type = make_node (RECORD_TYPE);
1739 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1740 TYPE_PACKED (gnu_type) = 1;
1741 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1742 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1743 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1745 /* Propagate the alignment of the modular type to the record type,
1746 unless there is an alignment clause that under-aligns the type.
1747 This means that bit-packed arrays are given "ceil" alignment for
1748 their size by default, which may seem counter-intuitive but makes
1749 it possible to overlay them on modular types easily. */
1750 TYPE_ALIGN (gnu_type)
1751 = align > 0 ? align : TYPE_ALIGN (gnu_field_type);
1753 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1755 /* Don't declare the field as addressable since we won't be taking
1756 its address and this would prevent create_field_decl from making
1759 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
1760 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1762 /* Do not emit debug info until after the parallel type is added. */
1763 finish_record_type (gnu_type, gnu_field, 2, false);
1764 compute_record_mode (gnu_type);
1765 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1769 /* Make the original array type a parallel type. */
1770 if (present_gnu_tree (Original_Array_Type (gnat_entity)))
1771 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1773 (Original_Array_Type (gnat_entity)));
1775 rest_of_record_type_compilation (gnu_type);
1779 /* If the type we are dealing with has got a smaller alignment than the
1780 natural one, we need to wrap it up in a record type and under-align
1781 the latter. We reuse the padding machinery for this purpose. */
1784 tree gnu_field_type, gnu_field;
1786 /* Set the RM size before wrapping up the type. */
1787 SET_TYPE_RM_SIZE (gnu_type,
1788 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1790 /* Create a stripped-down declaration, mainly for debugging. */
1791 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1792 debug_info_p, gnat_entity);
1794 /* Now save it and build the enclosing record type. */
1795 gnu_field_type = gnu_type;
1797 gnu_type = make_node (RECORD_TYPE);
1798 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1799 TYPE_PACKED (gnu_type) = 1;
1800 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1801 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1802 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1803 TYPE_ALIGN (gnu_type) = align;
1804 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1806 /* Don't declare the field as addressable since we won't be taking
1807 its address and this would prevent create_field_decl from making
1810 = create_field_decl (get_identifier ("F"), gnu_field_type,
1811 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1813 finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
1814 compute_record_mode (gnu_type);
1815 TYPE_PADDING_P (gnu_type) = 1;
1820 case E_Floating_Point_Type:
1821 /* If this is a VAX floating-point type, use an integer of the proper
1822 size. All the operations will be handled with ASM statements. */
1823 if (Vax_Float (gnat_entity))
1825 gnu_type = make_signed_type (esize);
1826 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1827 SET_TYPE_DIGITS_VALUE (gnu_type,
1828 UI_To_gnu (Digits_Value (gnat_entity),
1833 /* The type of the Low and High bounds can be our type if this is
1834 a type from Standard, so set them at the end of the function. */
1835 gnu_type = make_node (REAL_TYPE);
1836 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1837 layout_type (gnu_type);
1840 case E_Floating_Point_Subtype:
1841 if (Vax_Float (gnat_entity))
1843 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1849 && Present (Ancestor_Subtype (gnat_entity))
1850 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1851 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1852 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1853 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1856 gnu_type = make_node (REAL_TYPE);
1857 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1858 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1859 TYPE_GCC_MIN_VALUE (gnu_type)
1860 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1861 TYPE_GCC_MAX_VALUE (gnu_type)
1862 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1863 layout_type (gnu_type);
1865 SET_TYPE_RM_MIN_VALUE
1867 convert (TREE_TYPE (gnu_type),
1868 elaborate_expression (Type_Low_Bound (gnat_entity),
1869 gnat_entity, get_identifier ("L"),
1871 Needs_Debug_Info (gnat_entity))));
1873 SET_TYPE_RM_MAX_VALUE
1875 convert (TREE_TYPE (gnu_type),
1876 elaborate_expression (Type_High_Bound (gnat_entity),
1877 gnat_entity, get_identifier ("U"),
1879 Needs_Debug_Info (gnat_entity))));
1881 /* One of the above calls might have caused us to be elaborated,
1882 so don't blow up if so. */
1883 if (present_gnu_tree (gnat_entity))
1885 maybe_present = true;
1889 /* Inherit our alias set from what we're a subtype of, as for
1890 integer subtypes. */
1891 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1895 /* Array and String Types and Subtypes
1897 Unconstrained array types are represented by E_Array_Type and
1898 constrained array types are represented by E_Array_Subtype. There
1899 are no actual objects of an unconstrained array type; all we have
1900 are pointers to that type.
1902 The following fields are defined on array types and subtypes:
1904 Component_Type Component type of the array.
1905 Number_Dimensions Number of dimensions (an int).
1906 First_Index Type of first index. */
1911 const bool convention_fortran_p
1912 = (Convention (gnat_entity) == Convention_Fortran);
1913 const int ndim = Number_Dimensions (gnat_entity);
1914 tree gnu_template_type = make_node (RECORD_TYPE);
1915 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1916 tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
1917 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
1918 tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
1919 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem, t;
1920 Entity_Id gnat_index, gnat_name;
1923 /* We complete an existing dummy fat pointer type in place. This both
1924 avoids further complex adjustments in update_pointer_to and yields
1925 better debugging information in DWARF by leveraging the support for
1926 incomplete declarations of "tagged" types in the DWARF back-end. */
1927 gnu_type = get_dummy_type (gnat_entity);
1928 if (gnu_type && TYPE_POINTER_TO (gnu_type))
1930 gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
1931 TYPE_NAME (gnu_fat_type) = NULL_TREE;
1932 /* Save the contents of the dummy type for update_pointer_to. */
1933 TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
1936 gnu_fat_type = make_node (RECORD_TYPE);
1938 /* Make a node for the array. If we are not defining the array
1939 suppress expanding incomplete types. */
1940 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1944 defer_incomplete_level++;
1945 this_deferred = true;
1948 /* Build the fat pointer type. Use a "void *" object instead of
1949 a pointer to the array type since we don't have the array type
1950 yet (it will reference the fat pointer via the bounds). */
1952 = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node,
1953 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
1955 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
1956 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
1958 if (COMPLETE_TYPE_P (gnu_fat_type))
1960 /* We are going to lay it out again so reset the alias set. */
1961 alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type);
1962 TYPE_ALIAS_SET (gnu_fat_type) = -1;
1963 finish_fat_pointer_type (gnu_fat_type, tem);
1964 TYPE_ALIAS_SET (gnu_fat_type) = alias_set;
1965 for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
1967 TYPE_FIELDS (t) = tem;
1968 SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
1973 finish_fat_pointer_type (gnu_fat_type, tem);
1974 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1977 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1978 is the fat pointer. This will be used to access the individual
1979 fields once we build them. */
1980 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1981 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1982 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1983 gnu_template_reference
1984 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1985 TREE_READONLY (gnu_template_reference) = 1;
1987 /* Now create the GCC type for each index and add the fields for that
1988 index to the template. */
1989 for (index = (convention_fortran_p ? ndim - 1 : 0),
1990 gnat_index = First_Index (gnat_entity);
1991 0 <= index && index < ndim;
1992 index += (convention_fortran_p ? - 1 : 1),
1993 gnat_index = Next_Index (gnat_index))
1995 char field_name[16];
1996 tree gnu_index_base_type
1997 = get_unpadded_type (Base_Type (Etype (gnat_index)));
1998 tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
1999 tree gnu_min, gnu_max, gnu_high;
2001 /* Make the FIELD_DECLs for the low and high bounds of this
2002 type and then make extractions of these fields from the
2004 sprintf (field_name, "LB%d", index);
2005 gnu_lb_field = create_field_decl (get_identifier (field_name),
2006 gnu_index_base_type,
2007 gnu_template_type, NULL_TREE,
2009 Sloc_to_locus (Sloc (gnat_entity),
2010 &DECL_SOURCE_LOCATION (gnu_lb_field));
2012 field_name[0] = 'U';
2013 gnu_hb_field = create_field_decl (get_identifier (field_name),
2014 gnu_index_base_type,
2015 gnu_template_type, NULL_TREE,
2017 Sloc_to_locus (Sloc (gnat_entity),
2018 &DECL_SOURCE_LOCATION (gnu_hb_field));
2020 gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
2022 /* We can't use build_component_ref here since the template type
2023 isn't complete yet. */
2024 gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type,
2025 gnu_template_reference, gnu_lb_field,
2027 gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type,
2028 gnu_template_reference, gnu_hb_field,
2030 TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
2032 gnu_min = convert (sizetype, gnu_orig_min);
2033 gnu_max = convert (sizetype, gnu_orig_max);
2035 /* Compute the size of this dimension. See the E_Array_Subtype
2036 case below for the rationale. */
2038 = build3 (COND_EXPR, sizetype,
2039 build2 (GE_EXPR, boolean_type_node,
2040 gnu_orig_max, gnu_orig_min),
2042 size_binop (MINUS_EXPR, gnu_min, size_one_node));
2044 /* Make a range type with the new range in the Ada base type.
2045 Then make an index type with the size range in sizetype. */
2046 gnu_index_types[index]
2047 = create_index_type (gnu_min, gnu_high,
2048 create_range_type (gnu_index_base_type,
2053 /* Update the maximum size of the array in elements. */
2056 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2058 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
2060 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
2062 = size_binop (MAX_EXPR,
2063 size_binop (PLUS_EXPR, size_one_node,
2064 size_binop (MINUS_EXPR,
2068 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2069 && TREE_OVERFLOW (gnu_this_max))
2070 gnu_max_size = NULL_TREE;
2073 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2076 TYPE_NAME (gnu_index_types[index])
2077 = create_concat_name (gnat_entity, field_name);
2080 /* Install all the fields into the template. */
2081 TYPE_NAME (gnu_template_type)
2082 = create_concat_name (gnat_entity, "XUB");
2083 gnu_template_fields = NULL_TREE;
2084 for (index = 0; index < ndim; index++)
2086 = chainon (gnu_template_fields, gnu_temp_fields[index]);
2087 finish_record_type (gnu_template_type, gnu_template_fields, 0,
2089 TYPE_READONLY (gnu_template_type) = 1;
2091 /* Now make the array of arrays and update the pointer to the array
2092 in the fat pointer. Note that it is the first field. */
2094 = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
2096 /* If Component_Size is not already specified, annotate it with the
2097 size of the component. */
2098 if (Unknown_Component_Size (gnat_entity))
2099 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
2101 /* Compute the maximum size of the array in units and bits. */
2104 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2105 TYPE_SIZE_UNIT (tem));
2106 gnu_max_size = size_binop (MULT_EXPR,
2107 convert (bitsizetype, gnu_max_size),
2111 gnu_max_size_unit = NULL_TREE;
2113 /* Now build the array type. */
2114 for (index = ndim - 1; index >= 0; index--)
2116 tem = build_nonshared_array_type (tem, gnu_index_types[index]);
2117 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2118 if (array_type_has_nonaliased_component (tem, gnat_entity))
2119 TYPE_NONALIASED_COMPONENT (tem) = 1;
2122 /* If an alignment is specified, use it if valid. But ignore it
2123 for the original type of packed array types. If the alignment
2124 was requested with an explicit alignment clause, state so. */
2125 if (No (Packed_Array_Type (gnat_entity))
2126 && Known_Alignment (gnat_entity))
2129 = validate_alignment (Alignment (gnat_entity), gnat_entity,
2131 if (Present (Alignment_Clause (gnat_entity)))
2132 TYPE_USER_ALIGN (tem) = 1;
2135 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2137 /* Adjust the type of the pointer-to-array field of the fat pointer
2138 and record the aliasing relationships if necessary. */
2139 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2140 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
2141 record_component_aliases (gnu_fat_type);
2143 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2144 corresponding fat pointer. */
2145 TREE_TYPE (gnu_type) = gnu_fat_type;
2146 TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
2147 TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2148 SET_TYPE_MODE (gnu_type, BLKmode);
2149 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
2151 /* If the maximum size doesn't overflow, use it. */
2153 && TREE_CODE (gnu_max_size) == INTEGER_CST
2154 && !TREE_OVERFLOW (gnu_max_size)
2155 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2156 && !TREE_OVERFLOW (gnu_max_size_unit))
2158 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2160 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2161 TYPE_SIZE_UNIT (tem));
2164 create_type_decl (create_concat_name (gnat_entity, "XUA"),
2165 tem, NULL, !Comes_From_Source (gnat_entity),
2166 debug_info_p, gnat_entity);
2168 /* Give the fat pointer type a name. If this is a packed type, tell
2169 the debugger how to interpret the underlying bits. */
2170 if (Present (Packed_Array_Type (gnat_entity)))
2171 gnat_name = Packed_Array_Type (gnat_entity);
2173 gnat_name = gnat_entity;
2174 create_type_decl (create_concat_name (gnat_name, "XUP"),
2175 gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
2176 debug_info_p, gnat_entity);
2178 /* Create the type to be used as what a thin pointer designates:
2179 a record type for the object and its template with the fields
2180 shifted to have the template at a negative offset. */
2181 tem = build_unc_object_type (gnu_template_type, tem,
2182 create_concat_name (gnat_name, "XUT"),
2184 shift_unc_components_for_thin_pointers (tem);
2186 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2187 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2191 case E_String_Subtype:
2192 case E_Array_Subtype:
2194 /* This is the actual data type for array variables. Multidimensional
2195 arrays are implemented as arrays of arrays. Note that arrays which
2196 have sparse enumeration subtypes as index components create sparse
2197 arrays, which is obviously space inefficient but so much easier to
2200 Also note that the subtype never refers to the unconstrained array
2201 type, which is somewhat at variance with Ada semantics.
2203 First check to see if this is simply a renaming of the array type.
2204 If so, the result is the array type. */
2206 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2207 if (!Is_Constrained (gnat_entity))
2211 Entity_Id gnat_index, gnat_base_index;
2212 const bool convention_fortran_p
2213 = (Convention (gnat_entity) == Convention_Fortran);
2214 const int ndim = Number_Dimensions (gnat_entity);
2215 tree gnu_base_type = gnu_type;
2216 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2217 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2218 bool need_index_type_struct = false;
2221 /* First create the GCC type for each index and find out whether
2222 special types are needed for debugging information. */
2223 for (index = (convention_fortran_p ? ndim - 1 : 0),
2224 gnat_index = First_Index (gnat_entity),
2226 = First_Index (Implementation_Base_Type (gnat_entity));
2227 0 <= index && index < ndim;
2228 index += (convention_fortran_p ? - 1 : 1),
2229 gnat_index = Next_Index (gnat_index),
2230 gnat_base_index = Next_Index (gnat_base_index))
2232 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2233 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2234 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2235 tree gnu_min = convert (sizetype, gnu_orig_min);
2236 tree gnu_max = convert (sizetype, gnu_orig_max);
2237 tree gnu_base_index_type
2238 = get_unpadded_type (Etype (gnat_base_index));
2239 tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2240 tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2243 /* See if the base array type is already flat. If it is, we
2244 are probably compiling an ACATS test but it will cause the
2245 code below to malfunction if we don't handle it specially. */
2246 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2247 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2248 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2250 gnu_min = size_one_node;
2251 gnu_max = size_zero_node;
2255 /* Similarly, if one of the values overflows in sizetype and the
2256 range is null, use 1..0 for the sizetype bounds. */
2257 else if (TREE_CODE (gnu_min) == INTEGER_CST
2258 && TREE_CODE (gnu_max) == INTEGER_CST
2259 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2260 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2262 gnu_min = size_one_node;
2263 gnu_max = size_zero_node;
2267 /* If the minimum and maximum values both overflow in sizetype,
2268 but the difference in the original type does not overflow in
2269 sizetype, ignore the overflow indication. */
2270 else if (TREE_CODE (gnu_min) == INTEGER_CST
2271 && TREE_CODE (gnu_max) == INTEGER_CST
2272 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2275 fold_build2 (MINUS_EXPR, gnu_index_type,
2279 TREE_OVERFLOW (gnu_min) = 0;
2280 TREE_OVERFLOW (gnu_max) = 0;
2284 /* Compute the size of this dimension in the general case. We
2285 need to provide GCC with an upper bound to use but have to
2286 deal with the "superflat" case. There are three ways to do
2287 this. If we can prove that the array can never be superflat,
2288 we can just use the high bound of the index type. */
2289 else if ((Nkind (gnat_index) == N_Range
2290 && cannot_be_superflat_p (gnat_index))
2291 /* Packed Array Types are never superflat. */
2292 || Is_Packed_Array_Type (gnat_entity))
2295 /* Otherwise, if the high bound is constant but the low bound is
2296 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2297 lower bound. Note that the comparison must be done in the
2298 original type to avoid any overflow during the conversion. */
2299 else if (TREE_CODE (gnu_max) == INTEGER_CST
2300 && TREE_CODE (gnu_min) != INTEGER_CST)
2304 = build_cond_expr (sizetype,
2305 build_binary_op (GE_EXPR,
2310 size_binop (PLUS_EXPR, gnu_max,
2314 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2315 in all the other cases. Note that, here as well as above,
2316 the condition used in the comparison must be equivalent to
2317 the condition (length != 0). This is relied upon in order
2318 to optimize array comparisons in compare_arrays. */
2321 = build_cond_expr (sizetype,
2322 build_binary_op (GE_EXPR,
2327 size_binop (MINUS_EXPR, gnu_min,
2330 /* Reuse the index type for the range type. Then make an index
2331 type with the size range in sizetype. */
2332 gnu_index_types[index]
2333 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2336 /* Update the maximum size of the array in elements. Here we
2337 see if any constraint on the index type of the base type
2338 can be used in the case of self-referential bound on the
2339 index type of the subtype. We look for a non-"infinite"
2340 and non-self-referential bound from any type involved and
2341 handle each bound separately. */
2344 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2345 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2346 tree gnu_base_index_base_type
2347 = get_base_type (gnu_base_index_type);
2348 tree gnu_base_base_min
2349 = convert (sizetype,
2350 TYPE_MIN_VALUE (gnu_base_index_base_type));
2351 tree gnu_base_base_max
2352 = convert (sizetype,
2353 TYPE_MAX_VALUE (gnu_base_index_base_type));
2355 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2356 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2357 && !TREE_OVERFLOW (gnu_base_min)))
2358 gnu_base_min = gnu_min;
2360 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2361 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2362 && !TREE_OVERFLOW (gnu_base_max)))
2363 gnu_base_max = gnu_max;
2365 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2366 && TREE_OVERFLOW (gnu_base_min))
2367 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2368 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2369 && TREE_OVERFLOW (gnu_base_max))
2370 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2371 gnu_max_size = NULL_TREE;
2375 = size_binop (MAX_EXPR,
2376 size_binop (PLUS_EXPR, size_one_node,
2377 size_binop (MINUS_EXPR,
2382 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2383 && TREE_OVERFLOW (gnu_this_max))
2384 gnu_max_size = NULL_TREE;
2387 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2391 /* We need special types for debugging information to point to
2392 the index types if they have variable bounds, are not integer
2393 types, are biased or are wider than sizetype. */
2394 if (!integer_onep (gnu_orig_min)
2395 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2396 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2397 || (TREE_TYPE (gnu_index_type)
2398 && TREE_CODE (TREE_TYPE (gnu_index_type))
2400 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
2401 || compare_tree_int (rm_size (gnu_index_type),
2402 TYPE_PRECISION (sizetype)) > 0)
2403 need_index_type_struct = true;
2406 /* Then flatten: create the array of arrays. For an array type
2407 used to implement a packed array, get the component type from
2408 the original array type since the representation clauses that
2409 can affect it are on the latter. */
2410 if (Is_Packed_Array_Type (gnat_entity)
2411 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2413 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2414 for (index = ndim - 1; index >= 0; index--)
2415 gnu_type = TREE_TYPE (gnu_type);
2417 /* One of the above calls might have caused us to be elaborated,
2418 so don't blow up if so. */
2419 if (present_gnu_tree (gnat_entity))
2421 maybe_present = true;
2427 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2430 /* One of the above calls might have caused us to be elaborated,
2431 so don't blow up if so. */
2432 if (present_gnu_tree (gnat_entity))
2434 maybe_present = true;
2439 /* Compute the maximum size of the array in units and bits. */
2442 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2443 TYPE_SIZE_UNIT (gnu_type));
2444 gnu_max_size = size_binop (MULT_EXPR,
2445 convert (bitsizetype, gnu_max_size),
2446 TYPE_SIZE (gnu_type));
2449 gnu_max_size_unit = NULL_TREE;
2451 /* Now build the array type. */
2452 for (index = ndim - 1; index >= 0; index --)
2454 gnu_type = build_nonshared_array_type (gnu_type,
2455 gnu_index_types[index]);
2456 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2457 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2458 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2461 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2462 TYPE_STUB_DECL (gnu_type)
2463 = create_type_stub_decl (gnu_entity_name, gnu_type);
2465 /* If we are at file level and this is a multi-dimensional array,
2466 we need to make a variable corresponding to the stride of the
2467 inner dimensions. */
2468 if (global_bindings_p () && ndim > 1)
2470 tree gnu_st_name = get_identifier ("ST");
2473 for (gnu_arr_type = TREE_TYPE (gnu_type);
2474 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2475 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2476 gnu_st_name = concat_name (gnu_st_name, "ST"))
2478 tree eltype = TREE_TYPE (gnu_arr_type);
2480 TYPE_SIZE (gnu_arr_type)
2481 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2482 gnat_entity, gnu_st_name,
2485 /* ??? For now, store the size as a multiple of the
2486 alignment of the element type in bytes so that we
2487 can see the alignment from the tree. */
2488 TYPE_SIZE_UNIT (gnu_arr_type)
2489 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type),
2491 concat_name (gnu_st_name, "A_U"),
2493 TYPE_ALIGN (eltype));
2495 /* ??? create_type_decl is not invoked on the inner types so
2496 the MULT_EXPR node built above will never be marked. */
2497 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2501 /* If we need to write out a record type giving the names of the
2502 bounds for debugging purposes, do it now and make the record
2503 type a parallel type. This is not needed for a packed array
2504 since the bounds are conveyed by the original array type. */
2505 if (need_index_type_struct
2507 && !Is_Packed_Array_Type (gnat_entity))
2509 tree gnu_bound_rec = make_node (RECORD_TYPE);
2510 tree gnu_field_list = NULL_TREE;
2513 TYPE_NAME (gnu_bound_rec)
2514 = create_concat_name (gnat_entity, "XA");
2516 for (index = ndim - 1; index >= 0; index--)
2518 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2519 tree gnu_index_name = TYPE_NAME (gnu_index);
2521 if (TREE_CODE (gnu_index_name) == TYPE_DECL)
2522 gnu_index_name = DECL_NAME (gnu_index_name);
2524 /* Make sure to reference the types themselves, and not just
2525 their names, as the debugger may fall back on them. */
2526 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2527 gnu_bound_rec, NULL_TREE,
2529 DECL_CHAIN (gnu_field) = gnu_field_list;
2530 gnu_field_list = gnu_field;
2533 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2534 add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
2537 /* If this is a packed array type, make the original array type a
2538 parallel type. Otherwise, do it for the base array type if it
2539 isn't artificial to make sure it is kept in the debug info. */
2542 if (Is_Packed_Array_Type (gnat_entity)
2543 && present_gnu_tree (Original_Array_Type (gnat_entity)))
2544 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2546 (Original_Array_Type (gnat_entity)));
2550 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0);
2551 if (!DECL_ARTIFICIAL (gnu_base_decl))
2552 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2553 TREE_TYPE (TREE_TYPE (gnu_base_decl)));
2557 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2558 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2559 = (Is_Packed_Array_Type (gnat_entity)
2560 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2562 /* If the size is self-referential and the maximum size doesn't
2563 overflow, use it. */
2564 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2566 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2567 && TREE_OVERFLOW (gnu_max_size))
2568 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2569 && TREE_OVERFLOW (gnu_max_size_unit)))
2571 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2572 TYPE_SIZE (gnu_type));
2573 TYPE_SIZE_UNIT (gnu_type)
2574 = size_binop (MIN_EXPR, gnu_max_size_unit,
2575 TYPE_SIZE_UNIT (gnu_type));
2578 /* Set our alias set to that of our base type. This gives all
2579 array subtypes the same alias set. */
2580 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2582 /* If this is a packed type, make this type the same as the packed
2583 array type, but do some adjusting in the type first. */
2584 if (Present (Packed_Array_Type (gnat_entity)))
2586 Entity_Id gnat_index;
2589 /* First finish the type we had been making so that we output
2590 debugging information for it. */
2591 if (Treat_As_Volatile (gnat_entity))
2593 = build_qualified_type (gnu_type,
2594 TYPE_QUALS (gnu_type)
2595 | TYPE_QUAL_VOLATILE);
2597 /* Make it artificial only if the base type was artificial too.
2598 That's sort of "morally" true and will make it possible for
2599 the debugger to look it up by name in DWARF, which is needed
2600 in order to decode the packed array type. */
2602 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
2603 !Comes_From_Source (Etype (gnat_entity))
2604 && !Comes_From_Source (gnat_entity),
2605 debug_info_p, gnat_entity);
2607 /* Save it as our equivalent in case the call below elaborates
2609 save_gnu_tree (gnat_entity, gnu_decl, false);
2611 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2613 this_made_decl = true;
2614 gnu_type = TREE_TYPE (gnu_decl);
2615 save_gnu_tree (gnat_entity, NULL_TREE, false);
2617 gnu_inner = gnu_type;
2618 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2619 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2620 || TYPE_PADDING_P (gnu_inner)))
2621 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2623 /* We need to attach the index type to the type we just made so
2624 that the actual bounds can later be put into a template. */
2625 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2626 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2627 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2628 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2630 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2632 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2633 TYPE_MODULUS for modular types so we make an extra
2634 subtype if necessary. */
2635 if (TYPE_MODULAR_P (gnu_inner))
2638 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2639 TREE_TYPE (gnu_subtype) = gnu_inner;
2640 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2641 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2642 TYPE_MIN_VALUE (gnu_inner));
2643 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2644 TYPE_MAX_VALUE (gnu_inner));
2645 gnu_inner = gnu_subtype;
2648 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2650 #ifdef ENABLE_CHECKING
2651 /* Check for other cases of overloading. */
2652 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2656 for (gnat_index = First_Index (gnat_entity);
2657 Present (gnat_index);
2658 gnat_index = Next_Index (gnat_index))
2659 SET_TYPE_ACTUAL_BOUNDS
2661 tree_cons (NULL_TREE,
2662 get_unpadded_type (Etype (gnat_index)),
2663 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2665 if (Convention (gnat_entity) != Convention_Fortran)
2666 SET_TYPE_ACTUAL_BOUNDS
2667 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2669 if (TREE_CODE (gnu_type) == RECORD_TYPE
2670 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2671 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2676 /* Abort if packed array with no Packed_Array_Type field set. */
2677 gcc_assert (!Is_Packed (gnat_entity));
2681 case E_String_Literal_Subtype:
2682 /* Create the type for a string literal. */
2684 Entity_Id gnat_full_type
2685 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2686 && Present (Full_View (Etype (gnat_entity)))
2687 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2688 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2689 tree gnu_string_array_type
2690 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2691 tree gnu_string_index_type
2692 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2693 (TYPE_DOMAIN (gnu_string_array_type))));
2694 tree gnu_lower_bound
2695 = convert (gnu_string_index_type,
2696 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2697 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2698 tree gnu_length = ssize_int (length - 1);
2699 tree gnu_upper_bound
2700 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2702 convert (gnu_string_index_type, gnu_length));
2704 = create_index_type (convert (sizetype, gnu_lower_bound),
2705 convert (sizetype, gnu_upper_bound),
2706 create_range_type (gnu_string_index_type,
2712 = build_nonshared_array_type (gnat_to_gnu_type
2713 (Component_Type (gnat_entity)),
2715 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2716 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2717 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2721 /* Record Types and Subtypes
2723 The following fields are defined on record types:
2725 Has_Discriminants True if the record has discriminants
2726 First_Discriminant Points to head of list of discriminants
2727 First_Entity Points to head of list of fields
2728 Is_Tagged_Type True if the record is tagged
2730 Implementation of Ada records and discriminated records:
2732 A record type definition is transformed into the equivalent of a C
2733 struct definition. The fields that are the discriminants which are
2734 found in the Full_Type_Declaration node and the elements of the
2735 Component_List found in the Record_Type_Definition node. The
2736 Component_List can be a recursive structure since each Variant of
2737 the Variant_Part of the Component_List has a Component_List.
2739 Processing of a record type definition comprises starting the list of
2740 field declarations here from the discriminants and the calling the
2741 function components_to_record to add the rest of the fields from the
2742 component list and return the gnu type node. The function
2743 components_to_record will call itself recursively as it traverses
2747 if (Has_Complex_Representation (gnat_entity))
2750 = build_complex_type
2752 (Etype (Defining_Entity
2753 (First (Component_Items
2756 (Declaration_Node (gnat_entity)))))))));
2762 Node_Id full_definition = Declaration_Node (gnat_entity);
2763 Node_Id record_definition = Type_Definition (full_definition);
2764 Entity_Id gnat_field;
2765 tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
2766 /* Set PACKED in keeping with gnat_to_gnu_field. */
2768 = Is_Packed (gnat_entity)
2770 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2772 : (Known_Alignment (gnat_entity)
2773 || (Strict_Alignment (gnat_entity)
2774 && Known_RM_Size (gnat_entity)))
2777 bool has_discr = Has_Discriminants (gnat_entity);
2778 bool has_rep = Has_Specified_Layout (gnat_entity);
2779 bool all_rep = has_rep;
2781 = (Is_Tagged_Type (gnat_entity)
2782 && Nkind (record_definition) == N_Derived_Type_Definition);
2783 bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2785 /* See if all fields have a rep clause. Stop when we find one
2788 for (gnat_field = First_Entity (gnat_entity);
2789 Present (gnat_field);
2790 gnat_field = Next_Entity (gnat_field))
2791 if ((Ekind (gnat_field) == E_Component
2792 || Ekind (gnat_field) == E_Discriminant)
2793 && No (Component_Clause (gnat_field)))
2799 /* If this is a record extension, go a level further to find the
2800 record definition. Also, verify we have a Parent_Subtype. */
2803 if (!type_annotate_only
2804 || Present (Record_Extension_Part (record_definition)))
2805 record_definition = Record_Extension_Part (record_definition);
2807 gcc_assert (type_annotate_only
2808 || Present (Parent_Subtype (gnat_entity)));
2811 /* Make a node for the record. If we are not defining the record,
2812 suppress expanding incomplete types. */
2813 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2814 TYPE_NAME (gnu_type) = gnu_entity_name;
2815 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2819 defer_incomplete_level++;
2820 this_deferred = true;
2823 /* If both a size and rep clause was specified, put the size in
2824 the record type now so that it can get the proper mode. */
2825 if (has_rep && Known_RM_Size (gnat_entity))
2826 TYPE_SIZE (gnu_type)
2827 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
2829 /* Always set the alignment here so that it can be used to
2830 set the mode, if it is making the alignment stricter. If
2831 it is invalid, it will be checked again below. If this is to
2832 be Atomic, choose a default alignment of a word unless we know
2833 the size and it's smaller. */
2834 if (Known_Alignment (gnat_entity))
2835 TYPE_ALIGN (gnu_type)
2836 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2837 else if (Is_Atomic (gnat_entity))
2838 TYPE_ALIGN (gnu_type)
2839 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2840 /* If a type needs strict alignment, the minimum size will be the
2841 type size instead of the RM size (see validate_size). Cap the
2842 alignment, lest it causes this type size to become too large. */
2843 else if (Strict_Alignment (gnat_entity)
2844 && Known_RM_Size (gnat_entity))
2846 unsigned int raw_size = UI_To_Int (RM_Size (gnat_entity));
2847 unsigned int raw_align = raw_size & -raw_size;
2848 if (raw_align < BIGGEST_ALIGNMENT)
2849 TYPE_ALIGN (gnu_type) = raw_align;
2852 TYPE_ALIGN (gnu_type) = 0;
2854 /* If we have a Parent_Subtype, make a field for the parent. If
2855 this record has rep clauses, force the position to zero. */
2856 if (Present (Parent_Subtype (gnat_entity)))
2858 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2861 /* A major complexity here is that the parent subtype will
2862 reference our discriminants in its Discriminant_Constraint
2863 list. But those must reference the parent component of this
2864 record which is of the parent subtype we have not built yet!
2865 To break the circle we first build a dummy COMPONENT_REF which
2866 represents the "get to the parent" operation and initialize
2867 each of those discriminants to a COMPONENT_REF of the above
2868 dummy parent referencing the corresponding discriminant of the
2869 base type of the parent subtype. */
2870 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2871 build0 (PLACEHOLDER_EXPR, gnu_type),
2872 build_decl (input_location,
2873 FIELD_DECL, NULL_TREE,
2878 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2879 Present (gnat_field);
2880 gnat_field = Next_Stored_Discriminant (gnat_field))
2881 if (Present (Corresponding_Discriminant (gnat_field)))
2884 = gnat_to_gnu_field_decl (Corresponding_Discriminant
2888 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2889 gnu_get_parent, gnu_field, NULL_TREE),
2893 /* Then we build the parent subtype. If it has discriminants but
2894 the type itself has unknown discriminants, this means that it
2895 doesn't contain information about how the discriminants are
2896 derived from those of the ancestor type, so it cannot be used
2897 directly. Instead it is built by cloning the parent subtype
2898 of the underlying record view of the type, for which the above
2899 derivation of discriminants has been made explicit. */
2900 if (Has_Discriminants (gnat_parent)
2901 && Has_Unknown_Discriminants (gnat_entity))
2903 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
2905 /* If we are defining the type, the underlying record
2906 view must already have been elaborated at this point.
2907 Otherwise do it now as its parent subtype cannot be
2908 technically elaborated on its own. */
2910 gcc_assert (present_gnu_tree (gnat_uview));
2912 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
2914 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
2916 /* Substitute the "get to the parent" of the type for that
2917 of its underlying record view in the cloned type. */
2918 for (gnat_field = First_Stored_Discriminant (gnat_uview);
2919 Present (gnat_field);
2920 gnat_field = Next_Stored_Discriminant (gnat_field))
2921 if (Present (Corresponding_Discriminant (gnat_field)))
2923 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
2925 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2926 gnu_get_parent, gnu_field, NULL_TREE);
2928 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
2932 gnu_parent = gnat_to_gnu_type (gnat_parent);
2934 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2935 initially built. The discriminants must reference the fields
2936 of the parent subtype and not those of its base type for the
2937 placeholder machinery to properly work. */
2940 /* The actual parent subtype is the full view. */
2941 if (IN (Ekind (gnat_parent), Private_Kind))
2943 if (Present (Full_View (gnat_parent)))
2944 gnat_parent = Full_View (gnat_parent);
2946 gnat_parent = Underlying_Full_View (gnat_parent);
2949 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2950 Present (gnat_field);
2951 gnat_field = Next_Stored_Discriminant (gnat_field))
2952 if (Present (Corresponding_Discriminant (gnat_field)))
2954 Entity_Id field = Empty;
2955 for (field = First_Stored_Discriminant (gnat_parent);
2957 field = Next_Stored_Discriminant (field))
2958 if (same_discriminant_p (gnat_field, field))
2960 gcc_assert (Present (field));
2961 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2962 = gnat_to_gnu_field_decl (field);
2966 /* The "get to the parent" COMPONENT_REF must be given its
2968 TREE_TYPE (gnu_get_parent) = gnu_parent;
2970 /* ...and reference the _Parent field of this record. */
2972 = create_field_decl (parent_name_id,
2973 gnu_parent, gnu_type,
2975 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
2977 ? bitsize_zero_node : NULL_TREE,
2979 DECL_INTERNAL_P (gnu_field) = 1;
2980 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
2981 TYPE_FIELDS (gnu_type) = gnu_field;
2984 /* Make the fields for the discriminants and put them into the record
2985 unless it's an Unchecked_Union. */
2987 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2988 Present (gnat_field);
2989 gnat_field = Next_Stored_Discriminant (gnat_field))
2991 /* If this is a record extension and this discriminant is the
2992 renaming of another discriminant, we've handled it above. */
2993 if (Present (Parent_Subtype (gnat_entity))
2994 && Present (Corresponding_Discriminant (gnat_field)))
2998 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
3001 /* Make an expression using a PLACEHOLDER_EXPR from the
3002 FIELD_DECL node just created and link that with the
3003 corresponding GNAT defining identifier. */
3004 save_gnu_tree (gnat_field,
3005 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3006 build0 (PLACEHOLDER_EXPR, gnu_type),
3007 gnu_field, NULL_TREE),
3010 if (!is_unchecked_union)
3012 DECL_CHAIN (gnu_field) = gnu_field_list;
3013 gnu_field_list = gnu_field;
3017 /* Add the fields into the record type and finish it up. */
3018 components_to_record (gnu_type, Component_List (record_definition),
3019 gnu_field_list, packed, definition, false,
3020 all_rep, is_unchecked_union, debug_info_p,
3021 false, OK_To_Reorder_Components (gnat_entity),
3024 /* If it is passed by reference, force BLKmode to ensure that objects
3025 of this type will always be put in memory. */
3026 if (Is_By_Reference_Type (gnat_entity))
3027 SET_TYPE_MODE (gnu_type, BLKmode);
3029 /* We used to remove the associations of the discriminants and _Parent
3030 for validity checking but we may need them if there's a Freeze_Node
3031 for a subtype used in this record. */
3032 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3034 /* Fill in locations of fields. */
3035 annotate_rep (gnat_entity, gnu_type);
3037 /* If there are any entities in the chain corresponding to components
3038 that we did not elaborate, ensure we elaborate their types if they
3040 for (gnat_temp = First_Entity (gnat_entity);
3041 Present (gnat_temp);
3042 gnat_temp = Next_Entity (gnat_temp))
3043 if ((Ekind (gnat_temp) == E_Component
3044 || Ekind (gnat_temp) == E_Discriminant)
3045 && Is_Itype (Etype (gnat_temp))
3046 && !present_gnu_tree (gnat_temp))
3047 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3049 /* If this is a record type associated with an exception definition,
3050 equate its fields to those of the standard exception type. This
3051 will make it possible to convert between them. */
3052 if (gnu_entity_name == exception_data_name_id)
3055 for (gnu_field = TYPE_FIELDS (gnu_type),
3056 gnu_std_field = TYPE_FIELDS (except_type_node);
3058 gnu_field = DECL_CHAIN (gnu_field),
3059 gnu_std_field = DECL_CHAIN (gnu_std_field))
3060 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
3061 gcc_assert (!gnu_std_field);
3066 case E_Class_Wide_Subtype:
3067 /* If an equivalent type is present, that is what we should use.
3068 Otherwise, fall through to handle this like a record subtype
3069 since it may have constraints. */
3070 if (gnat_equiv_type != gnat_entity)
3072 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
3073 maybe_present = true;
3077 /* ... fall through ... */
3079 case E_Record_Subtype:
3080 /* If Cloned_Subtype is Present it means this record subtype has
3081 identical layout to that type or subtype and we should use
3082 that GCC type for this one. The front end guarantees that
3083 the component list is shared. */
3084 if (Present (Cloned_Subtype (gnat_entity)))
3086 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
3088 maybe_present = true;
3092 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3093 changing the type, make a new type with each field having the type of
3094 the field in the new subtype but the position computed by transforming
3095 every discriminant reference according to the constraints. We don't
3096 see any difference between private and non-private type here since
3097 derivations from types should have been deferred until the completion
3098 of the private type. */
3101 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
3106 defer_incomplete_level++;
3107 this_deferred = true;
3110 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
3112 if (present_gnu_tree (gnat_entity))
3114 maybe_present = true;
3118 /* If this is a record subtype associated with a dispatch table,
3119 strip the suffix. This is necessary to make sure 2 different
3120 subtypes associated with the imported and exported views of a
3121 dispatch table are properly merged in LTO mode. */
3122 if (Is_Dispatch_Table_Entity (gnat_entity))
3125 Get_Encoded_Name (gnat_entity);
3126 p = strchr (Name_Buffer, '_');
3128 strcpy (p+2, "dtS");
3129 gnu_entity_name = get_identifier (Name_Buffer);
3132 /* When the subtype has discriminants and these discriminants affect
3133 the initial shape it has inherited, factor them in. But for an
3134 Unchecked_Union (it must be an Itype), just return the type.
3135 We can't just test Is_Constrained because private subtypes without
3136 discriminants of types with discriminants with default expressions
3137 are Is_Constrained but aren't constrained! */
3138 if (IN (Ekind (gnat_base_type), Record_Kind)
3139 && !Is_Unchecked_Union (gnat_base_type)
3140 && !Is_For_Access_Subtype (gnat_entity)
3141 && Is_Constrained (gnat_entity)
3142 && Has_Discriminants (gnat_entity)
3143 && Present (Discriminant_Constraint (gnat_entity))
3144 && Stored_Constraint (gnat_entity) != No_Elist)
3146 VEC(subst_pair,heap) *gnu_subst_list
3147 = build_subst_list (gnat_entity, gnat_base_type, definition);
3148 tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
3149 tree gnu_pos_list, gnu_field_list = NULL_TREE;
3150 bool selected_variant = false;
3151 Entity_Id gnat_field;
3152 VEC(variant_desc,heap) *gnu_variant_list;
3154 gnu_type = make_node (RECORD_TYPE);
3155 TYPE_NAME (gnu_type) = gnu_entity_name;
3157 /* Set the size, alignment and alias set of the new type to
3158 match that of the old one, doing required substitutions. */
3159 copy_and_substitute_in_size (gnu_type, gnu_base_type,
3162 if (TYPE_IS_PADDING_P (gnu_base_type))
3163 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3165 gnu_unpad_base_type = gnu_base_type;
3167 /* Look for a REP part in the base type. */
3168 gnu_rep_part = get_rep_part (gnu_unpad_base_type);
3170 /* Look for a variant part in the base type. */
3171 gnu_variant_part = get_variant_part (gnu_unpad_base_type);
3173 /* If there is a variant part, we must compute whether the
3174 constraints statically select a particular variant. If
3175 so, we simply drop the qualified union and flatten the
3176 list of fields. Otherwise we'll build a new qualified
3177 union for the variants that are still relevant. */
3178 if (gnu_variant_part)
3184 = build_variant_list (TREE_TYPE (gnu_variant_part),
3185 gnu_subst_list, NULL);
3187 /* If all the qualifiers are unconditionally true, the
3188 innermost variant is statically selected. */
3189 selected_variant = true;
3190 FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
3192 if (!integer_onep (v->qual))
3194 selected_variant = false;
3198 /* Otherwise, create the new variants. */
3199 if (!selected_variant)
3200 FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
3203 tree old_variant = v->type;
3204 tree new_variant = make_node (RECORD_TYPE);
3205 TYPE_NAME (new_variant)
3206 = DECL_NAME (TYPE_NAME (old_variant));
3207 copy_and_substitute_in_size (new_variant, old_variant,
3209 v->record = new_variant;
3214 gnu_variant_list = NULL;
3215 selected_variant = false;
3219 = build_position_list (gnu_unpad_base_type,
3220 gnu_variant_list && !selected_variant,
3221 size_zero_node, bitsize_zero_node,
3222 BIGGEST_ALIGNMENT, NULL_TREE);
3224 for (gnat_field = First_Entity (gnat_entity);
3225 Present (gnat_field);
3226 gnat_field = Next_Entity (gnat_field))
3227 if ((Ekind (gnat_field) == E_Component
3228 || Ekind (gnat_field) == E_Discriminant)
3229 && !(Present (Corresponding_Discriminant (gnat_field))
3230 && Is_Tagged_Type (gnat_base_type))
3231 && Underlying_Type (Scope (Original_Record_Component
3235 Name_Id gnat_name = Chars (gnat_field);
3236 Entity_Id gnat_old_field
3237 = Original_Record_Component (gnat_field);
3239 = gnat_to_gnu_field_decl (gnat_old_field);
3240 tree gnu_context = DECL_CONTEXT (gnu_old_field);
3241 tree gnu_field, gnu_field_type, gnu_size;
3242 tree gnu_cont_type, gnu_last = NULL_TREE;
3244 /* If the type is the same, retrieve the GCC type from the
3245 old field to take into account possible adjustments. */
3246 if (Etype (gnat_field) == Etype (gnat_old_field))
3247 gnu_field_type = TREE_TYPE (gnu_old_field);
3249 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3251 /* If there was a component clause, the field types must be
3252 the same for the type and subtype, so copy the data from
3253 the old field to avoid recomputation here. Also if the
3254 field is justified modular and the optimization in
3255 gnat_to_gnu_field was applied. */
3256 if (Present (Component_Clause (gnat_old_field))
3257 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3258 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3259 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3260 == TREE_TYPE (gnu_old_field)))
3262 gnu_size = DECL_SIZE (gnu_old_field);
3263 gnu_field_type = TREE_TYPE (gnu_old_field);
3266 /* If the old field was packed and of constant size, we
3267 have to get the old size here, as it might differ from
3268 what the Etype conveys and the latter might overlap
3269 onto the following field. Try to arrange the type for
3270 possible better packing along the way. */
3271 else if (DECL_PACKED (gnu_old_field)
3272 && TREE_CODE (DECL_SIZE (gnu_old_field))
3275 gnu_size = DECL_SIZE (gnu_old_field);
3276 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
3277 && !TYPE_FAT_POINTER_P (gnu_field_type)
3278 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3280 = make_packable_type (gnu_field_type, true);
3284 gnu_size = TYPE_SIZE (gnu_field_type);
3286 /* If the context of the old field is the base type or its
3287 REP part (if any), put the field directly in the new
3288 type; otherwise look up the context in the variant list
3289 and put the field either in the new type if there is a
3290 selected variant or in one of the new variants. */
3291 if (gnu_context == gnu_unpad_base_type
3293 && gnu_context == TREE_TYPE (gnu_rep_part)))
3294 gnu_cont_type = gnu_type;
3301 FOR_EACH_VEC_ELT_REVERSE (variant_desc,
3302 gnu_variant_list, ix, v)
3303 if (v->type == gnu_context)
3310 if (selected_variant)
3311 gnu_cont_type = gnu_type;
3313 gnu_cont_type = v->record;
3316 /* The front-end may pass us "ghost" components if
3317 it fails to recognize that a constrained subtype
3318 is statically constrained. Discard them. */
3322 /* Now create the new field modeled on the old one. */
3324 = create_field_decl_from (gnu_old_field, gnu_field_type,
3325 gnu_cont_type, gnu_size,
3326 gnu_pos_list, gnu_subst_list);
3328 /* Put it in one of the new variants directly. */
3329 if (gnu_cont_type != gnu_type)
3331 DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3332 TYPE_FIELDS (gnu_cont_type) = gnu_field;
3335 /* To match the layout crafted in components_to_record,
3336 if this is the _Tag or _Parent field, put it before
3337 any other fields. */
3338 else if (gnat_name == Name_uTag
3339 || gnat_name == Name_uParent)
3340 gnu_field_list = chainon (gnu_field_list, gnu_field);
3342 /* Similarly, if this is the _Controller field, put
3343 it before the other fields except for the _Tag or
3345 else if (gnat_name == Name_uController && gnu_last)
3347 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
3348 DECL_CHAIN (gnu_last) = gnu_field;
3351 /* Otherwise, if this is a regular field, put it after
3352 the other fields. */
3355 DECL_CHAIN (gnu_field) = gnu_field_list;
3356 gnu_field_list = gnu_field;
3358 gnu_last = gnu_field;
3361 save_gnu_tree (gnat_field, gnu_field, false);
3364 /* If there is a variant list and no selected variant, we need
3365 to create the nest of variant parts from the old nest. */
3366 if (gnu_variant_list && !selected_variant)
3368 tree new_variant_part
3369 = create_variant_part_from (gnu_variant_part,
3370 gnu_variant_list, gnu_type,
3371 gnu_pos_list, gnu_subst_list);
3372 DECL_CHAIN (new_variant_part) = gnu_field_list;
3373 gnu_field_list = new_variant_part;
3376 /* Now go through the entities again looking for Itypes that
3377 we have not elaborated but should (e.g., Etypes of fields
3378 that have Original_Components). */
3379 for (gnat_field = First_Entity (gnat_entity);
3380 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3381 if ((Ekind (gnat_field) == E_Discriminant
3382 || Ekind (gnat_field) == E_Component)
3383 && !present_gnu_tree (Etype (gnat_field)))
3384 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3386 /* Do not emit debug info for the type yet since we're going to
3388 gnu_field_list = nreverse (gnu_field_list);
3389 finish_record_type (gnu_type, gnu_field_list, 2, false);
3391 /* See the E_Record_Type case for the rationale. */
3392 if (Is_By_Reference_Type (gnat_entity))
3393 SET_TYPE_MODE (gnu_type, BLKmode);
3395 compute_record_mode (gnu_type);
3397 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3399 /* Fill in locations of fields. */
3400 annotate_rep (gnat_entity, gnu_type);
3402 /* If debugging information is being written for the type, write
3403 a record that shows what we are a subtype of and also make a
3404 variable that indicates our size, if still variable. */
3407 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3408 tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type);
3409 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3411 if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL)
3412 gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name);
3414 TYPE_NAME (gnu_subtype_marker)
3415 = create_concat_name (gnat_entity, "XVS");
3416 finish_record_type (gnu_subtype_marker,
3417 create_field_decl (gnu_unpad_base_name,
3418 build_reference_type
3419 (gnu_unpad_base_type),
3421 NULL_TREE, NULL_TREE,
3425 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3426 gnu_subtype_marker);
3429 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3430 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3431 TYPE_SIZE_UNIT (gnu_subtype_marker)
3432 = create_var_decl (create_concat_name (gnat_entity,
3434 NULL_TREE, sizetype, gnu_size_unit,
3435 false, false, false, false, NULL,
3439 VEC_free (variant_desc, heap, gnu_variant_list);
3440 VEC_free (subst_pair, heap, gnu_subst_list);
3442 /* Now we can finalize it. */
3443 rest_of_record_type_compilation (gnu_type);
3446 /* Otherwise, go down all the components in the new type and make
3447 them equivalent to those in the base type. */
3450 gnu_type = gnu_base_type;
3452 for (gnat_temp = First_Entity (gnat_entity);
3453 Present (gnat_temp);
3454 gnat_temp = Next_Entity (gnat_temp))
3455 if ((Ekind (gnat_temp) == E_Discriminant
3456 && !Is_Unchecked_Union (gnat_base_type))
3457 || Ekind (gnat_temp) == E_Component)
3458 save_gnu_tree (gnat_temp,
3459 gnat_to_gnu_field_decl
3460 (Original_Record_Component (gnat_temp)),
3466 case E_Access_Subprogram_Type:
3467 /* Use the special descriptor type for dispatch tables if needed,
3468 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3469 Note that we are only required to do so for static tables in
3470 order to be compatible with the C++ ABI, but Ada 2005 allows
3471 to extend library level tagged types at the local level so
3472 we do it in the non-static case as well. */
3473 if (TARGET_VTABLE_USES_DESCRIPTORS
3474 && Is_Dispatch_Table_Entity (gnat_entity))
3476 gnu_type = fdesc_type_node;
3477 gnu_size = TYPE_SIZE (gnu_type);
3481 /* ... fall through ... */
3483 case E_Anonymous_Access_Subprogram_Type:
3484 /* If we are not defining this entity, and we have incomplete
3485 entities being processed above us, make a dummy type and
3486 fill it in later. */
3487 if (!definition && defer_incomplete_level != 0)
3489 struct incomplete *p
3490 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3493 = build_pointer_type
3494 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3495 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3496 !Comes_From_Source (gnat_entity),
3497 debug_info_p, gnat_entity);
3498 this_made_decl = true;
3499 gnu_type = TREE_TYPE (gnu_decl);
3500 save_gnu_tree (gnat_entity, gnu_decl, false);
3503 p->old_type = TREE_TYPE (gnu_type);
3504 p->full_type = Directly_Designated_Type (gnat_entity);
3505 p->next = defer_incomplete_list;
3506 defer_incomplete_list = p;
3510 /* ... fall through ... */
3512 case E_Allocator_Type:
3514 case E_Access_Attribute_Type:
3515 case E_Anonymous_Access_Type:
3516 case E_General_Access_Type:
3518 /* The designated type and its equivalent type for gigi. */
3519 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3520 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3521 /* Whether it comes from a limited with. */
3522 bool is_from_limited_with
3523 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3524 && From_With_Type (gnat_desig_equiv));
3525 /* The "full view" of the designated type. If this is an incomplete
3526 entity from a limited with, treat its non-limited view as the full
3527 view. Otherwise, if this is an incomplete or private type, use the
3528 full view. In the former case, we might point to a private type,
3529 in which case, we need its full view. Also, we want to look at the
3530 actual type used for the representation, so this takes a total of
3532 Entity_Id gnat_desig_full_direct_first
3533 = (is_from_limited_with
3534 ? Non_Limited_View (gnat_desig_equiv)
3535 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3536 ? Full_View (gnat_desig_equiv) : Empty));
3537 Entity_Id gnat_desig_full_direct
3538 = ((is_from_limited_with
3539 && Present (gnat_desig_full_direct_first)
3540 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3541 ? Full_View (gnat_desig_full_direct_first)
3542 : gnat_desig_full_direct_first);
3543 Entity_Id gnat_desig_full
3544 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3545 /* The type actually used to represent the designated type, either
3546 gnat_desig_full or gnat_desig_equiv. */
3547 Entity_Id gnat_desig_rep;
3548 /* True if this is a pointer to an unconstrained array. */
3549 bool is_unconstrained_array;
3550 /* We want to know if we'll be seeing the freeze node for any
3551 incomplete type we may be pointing to. */
3553 = (Present (gnat_desig_full)
3554 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3555 : In_Extended_Main_Code_Unit (gnat_desig_type));
3556 /* True if we make a dummy type here. */
3557 bool made_dummy = false;
3558 /* The mode to be used for the pointer type. */
3559 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3560 /* The GCC type used for the designated type. */
3561 tree gnu_desig_type = NULL_TREE;
3563 if (!targetm.valid_pointer_mode (p_mode))
3566 /* If either the designated type or its full view is an unconstrained
3567 array subtype, replace it with the type it's a subtype of. This
3568 avoids problems with multiple copies of unconstrained array types.
3569 Likewise, if the designated type is a subtype of an incomplete
3570 record type, use the parent type to avoid order of elaboration
3571 issues. This can lose some code efficiency, but there is no
3573 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3574 && !Is_Constrained (gnat_desig_equiv))
3575 gnat_desig_equiv = Etype (gnat_desig_equiv);
3576 if (Present (gnat_desig_full)
3577 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3578 && !Is_Constrained (gnat_desig_full))
3579 || (Ekind (gnat_desig_full) == E_Record_Subtype
3580 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3581 gnat_desig_full = Etype (gnat_desig_full);
3583 /* Set the type that's actually the representation of the designated
3584 type and also flag whether we have a unconstrained array. */
3586 = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
3587 is_unconstrained_array
3588 = Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep);
3590 /* If we are pointing to an incomplete type whose completion is an
3591 unconstrained array, make dummy fat and thin pointer types to it.
3592 Likewise if the type itself is dummy or an unconstrained array. */
3593 if (is_unconstrained_array
3594 && (Present (gnat_desig_full)
3595 || (present_gnu_tree (gnat_desig_equiv)
3597 (TREE_TYPE (get_gnu_tree (gnat_desig_equiv))))
3599 && defer_incomplete_level != 0
3600 && !present_gnu_tree (gnat_desig_equiv))
3602 && is_from_limited_with
3603 && Present (Freeze_Node (gnat_desig_equiv)))))
3605 if (present_gnu_tree (gnat_desig_rep))
3606 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
3609 gnu_desig_type = make_dummy_type (gnat_desig_rep);
3613 /* If the call above got something that has a pointer, the pointer
3614 is our type. This could have happened either because the type
3615 was elaborated or because somebody else executed the code. */
3616 if (!TYPE_POINTER_TO (gnu_desig_type))
3617 build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
3618 gnu_type = TYPE_POINTER_TO (gnu_desig_type);
3621 /* If we already know what the full type is, use it. */
3622 else if (Present (gnat_desig_full)
3623 && present_gnu_tree (gnat_desig_full))
3624 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3626 /* Get the type of the thing we are to point to and build a pointer to
3627 it. If it is a reference to an incomplete or private type with a
3628 full view that is a record, make a dummy type node and get the
3629 actual type later when we have verified it is safe. */
3630 else if ((!in_main_unit
3631 && !present_gnu_tree (gnat_desig_equiv)
3632 && Present (gnat_desig_full)
3633 && !present_gnu_tree (gnat_desig_full)
3634 && Is_Record_Type (gnat_desig_full))
3635 /* Likewise if we are pointing to a record or array and we are
3636 to defer elaborating incomplete types. We do this as this
3637 access type may be the full view of a private type. Note
3638 that the unconstrained array case is handled above. */
3639 || ((!in_main_unit || imported_p)
3640 && defer_incomplete_level != 0
3641 && !present_gnu_tree (gnat_desig_equiv)
3642 && (Is_Record_Type (gnat_desig_rep)
3643 || Is_Array_Type (gnat_desig_rep)))
3644 /* If this is a reference from a limited_with type back to our
3645 main unit and there's a freeze node for it, either we have
3646 already processed the declaration and made the dummy type,
3647 in which case we just reuse the latter, or we have not yet,
3648 in which case we make the dummy type and it will be reused
3649 when the declaration is finally processed. In both cases,
3650 the pointer eventually created below will be automatically
3651 adjusted when the freeze node is processed. Note that the
3652 unconstrained array case is handled above. */
3654 && is_from_limited_with
3655 && Present (Freeze_Node (gnat_desig_rep))))
3657 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3661 /* Otherwise handle the case of a pointer to itself. */
3662 else if (gnat_desig_equiv == gnat_entity)
3665 = build_pointer_type_for_mode (void_type_node, p_mode,
3666 No_Strict_Aliasing (gnat_entity));
3667 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3670 /* If expansion is disabled, the equivalent type of a concurrent type
3671 is absent, so build a dummy pointer type. */
3672 else if (type_annotate_only && No (gnat_desig_equiv))
3673 gnu_type = ptr_void_type_node;
3675 /* Finally, handle the default case where we can just elaborate our
3678 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3680 /* It is possible that a call to gnat_to_gnu_type above resolved our
3681 type. If so, just return it. */
3682 if (present_gnu_tree (gnat_entity))
3684 maybe_present = true;
3688 /* If we have not done it yet, build the pointer type the usual way. */
3691 /* Modify the designated type if we are pointing only to constant
3692 objects, but don't do it for unconstrained arrays. */
3693 if (Is_Access_Constant (gnat_entity)
3694 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3697 = build_qualified_type
3699 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3701 /* Some extra processing is required if we are building a
3702 pointer to an incomplete type (in the GCC sense). We might
3703 have such a type if we just made a dummy, or directly out
3704 of the call to gnat_to_gnu_type above if we are processing
3705 an access type for a record component designating the
3706 record type itself. */
3707 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3709 /* We must ensure that the pointer to variant we make will
3710 be processed by update_pointer_to when the initial type
3711 is completed. Pretend we made a dummy and let further
3712 processing act as usual. */
3715 /* We must ensure that update_pointer_to will not retrieve
3716 the dummy variant when building a properly qualified
3717 version of the complete type. We take advantage of the
3718 fact that get_qualified_type is requiring TYPE_NAMEs to
3719 match to influence build_qualified_type and then also
3720 update_pointer_to here. */
3721 TYPE_NAME (gnu_desig_type)
3722 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3727 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3728 No_Strict_Aliasing (gnat_entity));
3731 /* If we are not defining this object and we have made a dummy pointer,
3732 save our current definition, evaluate the actual type, and replace
3733 the tentative type we made with the actual one. If we are to defer
3734 actually looking up the actual type, make an entry in the deferred
3735 list. If this is from a limited with, we may have to defer to the
3736 end of the current unit. */
3737 if ((!in_main_unit || is_from_limited_with) && made_dummy)
3739 tree gnu_old_desig_type;
3741 if (TYPE_IS_FAT_POINTER_P (gnu_type))
3743 gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
3744 if (esize == POINTER_SIZE)
3745 gnu_type = build_pointer_type
3746 (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
3749 gnu_old_desig_type = TREE_TYPE (gnu_type);
3751 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3752 !Comes_From_Source (gnat_entity),
3753 debug_info_p, gnat_entity);
3754 this_made_decl = true;
3755 gnu_type = TREE_TYPE (gnu_decl);
3756 save_gnu_tree (gnat_entity, gnu_decl, false);
3759 /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
3760 update gnu_old_desig_type directly, in which case it will not be
3761 a dummy type any more when we get into update_pointer_to.
3763 This can happen e.g. when the designated type is a record type,
3764 because their elaboration starts with an initial node from
3765 make_dummy_type, which may be the same node as the one we got.
3767 Besides, variants of this non-dummy type might have been created
3768 along the way. update_pointer_to is expected to properly take
3769 care of those situations. */
3770 if (defer_incomplete_level == 0 && !is_from_limited_with)
3772 defer_finalize_level++;
3773 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
3774 gnat_to_gnu_type (gnat_desig_equiv));
3775 defer_finalize_level--;
3779 struct incomplete *p = XNEW (struct incomplete);
3780 struct incomplete **head
3781 = (is_from_limited_with
3782 ? &defer_limited_with : &defer_incomplete_list);
3783 p->old_type = gnu_old_desig_type;
3784 p->full_type = gnat_desig_equiv;
3792 case E_Access_Protected_Subprogram_Type:
3793 case E_Anonymous_Access_Protected_Subprogram_Type:
3794 if (type_annotate_only && No (gnat_equiv_type))
3795 gnu_type = ptr_void_type_node;
3798 /* The run-time representation is the equivalent type. */
3799 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3800 maybe_present = true;
3803 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3804 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3805 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3806 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3807 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3812 case E_Access_Subtype:
3814 /* We treat this as identical to its base type; any constraint is
3815 meaningful only to the front end.
3817 The designated type must be elaborated as well, if it does
3818 not have its own freeze node. Designated (sub)types created
3819 for constrained components of records with discriminants are
3820 not frozen by the front end and thus not elaborated by gigi,
3821 because their use may appear before the base type is frozen,
3822 and because it is not clear that they are needed anywhere in
3823 Gigi. With the current model, there is no correct place where
3824 they could be elaborated. */
3826 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3827 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3828 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3829 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3830 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3832 /* If we are not defining this entity, and we have incomplete
3833 entities being processed above us, make a dummy type and
3834 elaborate it later. */
3835 if (!definition && defer_incomplete_level != 0)
3837 struct incomplete *p
3838 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3840 = build_pointer_type
3841 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3843 p->old_type = TREE_TYPE (gnu_ptr_type);
3844 p->full_type = Directly_Designated_Type (gnat_entity);
3845 p->next = defer_incomplete_list;
3846 defer_incomplete_list = p;
3848 else if (!IN (Ekind (Base_Type
3849 (Directly_Designated_Type (gnat_entity))),
3850 Incomplete_Or_Private_Kind))
3851 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3855 maybe_present = true;
3858 /* Subprogram Entities
3860 The following access functions are defined for subprograms:
3862 Etype Return type or Standard_Void_Type.
3863 First_Formal The first formal parameter.
3864 Is_Imported Indicates that the subprogram has appeared in
3865 an INTERFACE or IMPORT pragma. For now we
3866 assume that the external language is C.
3867 Is_Exported Likewise but for an EXPORT pragma.
3868 Is_Inlined True if the subprogram is to be inlined.
3870 Each parameter is first checked by calling must_pass_by_ref on its
3871 type to determine if it is passed by reference. For parameters which
3872 are copied in, if they are Ada In Out or Out parameters, their return
3873 value becomes part of a record which becomes the return type of the
3874 function (C function - note that this applies only to Ada procedures
3875 so there is no Ada return type). Additional code to store back the
3876 parameters will be generated on the caller side. This transformation
3877 is done here, not in the front-end.
3879 The intended result of the transformation can be seen from the
3880 equivalent source rewritings that follow:
3882 struct temp {int a,b};
3883 procedure P (A,B: In Out ...) is temp P (int A,B)
3886 end P; return {A,B};
3893 For subprogram types we need to perform mainly the same conversions to
3894 GCC form that are needed for procedures and function declarations. The
3895 only difference is that at the end, we make a type declaration instead
3896 of a function declaration. */
3898 case E_Subprogram_Type:
3902 /* The type returned by a function or else Standard_Void_Type for a
3904 Entity_Id gnat_return_type = Etype (gnat_entity);
3905 tree gnu_return_type;
3906 /* The first GCC parameter declaration (a PARM_DECL node). The
3907 PARM_DECL nodes are chained through the DECL_CHAIN field, so this
3908 actually is the head of this parameter list. */
3909 tree gnu_param_list = NULL_TREE;
3910 /* Likewise for the stub associated with an exported procedure. */
3911 tree gnu_stub_param_list = NULL_TREE;
3912 /* Non-null for subprograms containing parameters passed by copy-in
3913 copy-out (Ada In Out or Out parameters not passed by reference),
3914 in which case it is the list of nodes used to specify the values
3915 of the In Out/Out parameters that are returned as a record upon
3916 procedure return. The TREE_PURPOSE of an element of this list is
3917 a field of the record and the TREE_VALUE is the PARM_DECL
3918 corresponding to that field. This list will be saved in the
3919 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3920 tree gnu_cico_list = NULL_TREE;
3921 /* List of fields in return type of procedure with copy-in copy-out
3923 tree gnu_field_list = NULL_TREE;
3924 /* If an import pragma asks to map this subprogram to a GCC builtin,
3925 this is the builtin DECL node. */
3926 tree gnu_builtin_decl = NULL_TREE;
3927 /* For the stub associated with an exported procedure. */
3928 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3929 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3930 Entity_Id gnat_param;
3931 bool inline_flag = Is_Inlined (gnat_entity);
3932 bool public_flag = Is_Public (gnat_entity) || imported_p;
3934 = (Is_Public (gnat_entity) && !definition) || imported_p;
3935 bool artificial_flag = !Comes_From_Source (gnat_entity);
3936 /* The semantics of "pure" in Ada essentially matches that of "const"
3937 in the back-end. In particular, both properties are orthogonal to
3938 the "nothrow" property if the EH circuitry is explicit in the
3939 internal representation of the back-end. If we are to completely
3940 hide the EH circuitry from it, we need to declare that calls to pure
3941 Ada subprograms that can throw have side effects since they can
3942 trigger an "abnormal" transfer of control flow; thus they can be
3943 neither "const" nor "pure" in the back-end sense. */
3945 = (Exception_Mechanism == Back_End_Exceptions
3946 && Is_Pure (gnat_entity));
3947 bool volatile_flag = No_Return (gnat_entity);
3948 bool return_by_direct_ref_p = false;
3949 bool return_by_invisi_ref_p = false;
3950 bool return_unconstrained_p = false;
3951 bool has_stub = false;
3954 /* A parameter may refer to this type, so defer completion of any
3955 incomplete types. */
3956 if (kind == E_Subprogram_Type && !definition)
3958 defer_incomplete_level++;
3959 this_deferred = true;
3962 /* If the subprogram has an alias, it is probably inherited, so
3963 we can use the original one. If the original "subprogram"
3964 is actually an enumeration literal, it may be the first use
3965 of its type, so we must elaborate that type now. */
3966 if (Present (Alias (gnat_entity)))
3968 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3969 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3971 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0);
3973 /* Elaborate any Itypes in the parameters of this entity. */
3974 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3975 Present (gnat_temp);
3976 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3977 if (Is_Itype (Etype (gnat_temp)))
3978 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3983 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3984 corresponding DECL node. Proper generation of calls later on need
3985 proper parameter associations so we don't "break;" here. */
3986 if (Convention (gnat_entity) == Convention_Intrinsic
3987 && Present (Interface_Name (gnat_entity)))
3989 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3991 /* Inability to find the builtin decl most often indicates a
3992 genuine mistake, but imports of unregistered intrinsics are
3993 sometimes issued on purpose to allow hooking in alternate
3994 bodies. We post a warning conditioned on Wshadow in this case,
3995 to let developers be notified on demand without risking false
3996 positives with common default sets of options. */
3998 if (gnu_builtin_decl == NULL_TREE && warn_shadow)
3999 post_error ("?gcc intrinsic not found for&!", gnat_entity);
4002 /* ??? What if we don't find the builtin node above ? warn ? err ?
4003 In the current state we neither warn nor err, and calls will just
4004 be handled as for regular subprograms. */
4006 /* Look into the return type and get its associated GCC tree. If it
4007 is not void, compute various flags for the subprogram type. */
4008 if (Ekind (gnat_return_type) == E_Void)
4009 gnu_return_type = void_type_node;
4012 gnu_return_type = gnat_to_gnu_type (gnat_return_type);
4014 /* If this function returns by reference, make the actual return
4015 type the pointer type and make a note of that. */
4016 if (Returns_By_Ref (gnat_entity))
4018 gnu_return_type = build_pointer_type (gnu_return_type);
4019 return_by_direct_ref_p = true;
4022 /* If we are supposed to return an unconstrained array type, make
4023 the actual return type the fat pointer type. */
4024 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
4026 gnu_return_type = TREE_TYPE (gnu_return_type);
4027 return_unconstrained_p = true;
4030 /* Likewise, if the return type requires a transient scope, the
4031 return value will be allocated on the secondary stack so the
4032 actual return type is the pointer type. */
4033 else if (Requires_Transient_Scope (gnat_return_type))
4035 gnu_return_type = build_pointer_type (gnu_return_type);
4036 return_unconstrained_p = true;
4039 /* If the Mechanism is By_Reference, ensure this function uses the
4040 target's by-invisible-reference mechanism, which may not be the
4041 same as above (e.g. it might be passing an extra parameter). */
4042 else if (kind == E_Function
4043 && Mechanism (gnat_entity) == By_Reference)
4044 return_by_invisi_ref_p = true;
4046 /* Likewise, if the return type is itself By_Reference. */
4047 else if (TREE_ADDRESSABLE (gnu_return_type))
4048 return_by_invisi_ref_p = true;
4050 /* If the type is a padded type and the underlying type would not
4051 be passed by reference or the function has a foreign convention,
4052 return the underlying type. */
4053 else if (TYPE_IS_PADDING_P (gnu_return_type)
4054 && (!default_pass_by_ref
4055 (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
4056 || Has_Foreign_Convention (gnat_entity)))
4057 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
4059 /* If the return type is unconstrained, that means it must have a
4060 maximum size. Use the padded type as the effective return type.
4061 And ensure the function uses the target's by-invisible-reference
4062 mechanism to avoid copying too much data when it returns. */
4063 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
4066 = maybe_pad_type (gnu_return_type,
4067 max_size (TYPE_SIZE (gnu_return_type),
4069 0, gnat_entity, false, false, false, true);
4071 /* Declare it now since it will never be declared otherwise.
4072 This is necessary to ensure that its subtrees are properly
4074 create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
4075 NULL, true, debug_info_p, gnat_entity);
4077 return_by_invisi_ref_p = true;
4080 /* If the return type has a size that overflows, we cannot have
4081 a function that returns that type. This usage doesn't make
4082 sense anyway, so give an error here. */
4083 if (TYPE_SIZE_UNIT (gnu_return_type)
4084 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
4085 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
4087 post_error ("cannot return type whose size overflows",
4089 gnu_return_type = copy_node (gnu_return_type);
4090 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
4091 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
4092 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
4093 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
4097 /* Loop over the parameters and get their associated GCC tree. While
4098 doing this, build a copy-in copy-out structure if we need one. */
4099 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
4100 Present (gnat_param);
4101 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
4103 tree gnu_param_name = get_entity_name (gnat_param);
4104 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
4105 tree gnu_param, gnu_field;
4106 bool copy_in_copy_out = false;
4107 Mechanism_Type mech = Mechanism (gnat_param);
4109 /* Builtins are expanded inline and there is no real call sequence
4110 involved. So the type expected by the underlying expander is
4111 always the type of each argument "as is". */
4112 if (gnu_builtin_decl)
4114 /* Handle the first parameter of a valued procedure specially. */
4115 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
4116 mech = By_Copy_Return;
4117 /* Otherwise, see if a Mechanism was supplied that forced this
4118 parameter to be passed one way or another. */
4119 else if (mech == Default
4120 || mech == By_Copy || mech == By_Reference)
4122 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
4123 mech = By_Descriptor;
4125 else if (By_Short_Descriptor_Last <= mech &&
4126 mech <= By_Short_Descriptor)
4127 mech = By_Short_Descriptor;
4131 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
4132 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
4133 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
4135 mech = By_Reference;
4141 post_error ("unsupported mechanism for&", gnat_param);
4146 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4147 Has_Foreign_Convention (gnat_entity),
4150 /* We are returned either a PARM_DECL or a type if no parameter
4151 needs to be passed; in either case, adjust the type. */
4152 if (DECL_P (gnu_param))
4153 gnu_param_type = TREE_TYPE (gnu_param);
4156 gnu_param_type = gnu_param;
4157 gnu_param = NULL_TREE;
4160 /* The failure of this assertion will very likely come from an
4161 order of elaboration issue for the type of the parameter. */
4162 gcc_assert (kind == E_Subprogram_Type
4163 || !TYPE_IS_DUMMY_P (gnu_param_type));
4167 /* If it's an exported subprogram, we build a parameter list
4168 in parallel, in case we need to emit a stub for it. */
4169 if (Is_Exported (gnat_entity))
4172 = chainon (gnu_param, gnu_stub_param_list);
4173 /* Change By_Descriptor parameter to By_Reference for
4174 the internal version of an exported subprogram. */
4175 if (mech == By_Descriptor || mech == By_Short_Descriptor)
4178 = gnat_to_gnu_param (gnat_param, By_Reference,
4184 gnu_param = copy_node (gnu_param);
4187 gnu_param_list = chainon (gnu_param, gnu_param_list);
4188 Sloc_to_locus (Sloc (gnat_param),
4189 &DECL_SOURCE_LOCATION (gnu_param));
4190 save_gnu_tree (gnat_param, gnu_param, false);
4192 /* If a parameter is a pointer, this function may modify
4193 memory through it and thus shouldn't be considered
4194 a const function. Also, the memory may be modified
4195 between two calls, so they can't be CSE'ed. The latter
4196 case also handles by-ref parameters. */
4197 if (POINTER_TYPE_P (gnu_param_type)
4198 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4202 if (copy_in_copy_out)
4206 tree gnu_new_ret_type = make_node (RECORD_TYPE);
4208 /* If this is a function, we also need a field for the
4209 return value to be placed. */
4210 if (TREE_CODE (gnu_return_type) != VOID_TYPE)
4213 = create_field_decl (get_identifier ("RETVAL"),
4215 gnu_new_ret_type, NULL_TREE,
4217 Sloc_to_locus (Sloc (gnat_entity),
4218 &DECL_SOURCE_LOCATION (gnu_field));
4219 gnu_field_list = gnu_field;
4221 = tree_cons (gnu_field, void_type_node, NULL_TREE);
4224 gnu_return_type = gnu_new_ret_type;
4225 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4226 /* Set a default alignment to speed up accesses. */
4227 TYPE_ALIGN (gnu_return_type)
4228 = get_mode_alignment (ptr_mode);
4232 = create_field_decl (gnu_param_name, gnu_param_type,
4233 gnu_return_type, NULL_TREE, NULL_TREE,
4235 /* Set a minimum alignment to speed up accesses. */
4236 if (DECL_ALIGN (gnu_field) < TYPE_ALIGN (gnu_return_type))
4237 DECL_ALIGN (gnu_field) = TYPE_ALIGN (gnu_return_type);
4238 Sloc_to_locus (Sloc (gnat_param),
4239 &DECL_SOURCE_LOCATION (gnu_field));
4240 DECL_CHAIN (gnu_field) = gnu_field_list;
4241 gnu_field_list = gnu_field;
4243 = tree_cons (gnu_field, gnu_param, gnu_cico_list);
4249 /* If we have a CICO list but it has only one entry, we convert
4250 this function into a function that returns this object. */
4251 if (list_length (gnu_cico_list) == 1)
4252 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
4254 /* Do not finalize the return type if the subprogram is stubbed
4255 since structures are incomplete for the back-end. */
4256 else if (Convention (gnat_entity) != Convention_Stubbed)
4258 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4261 /* Try to promote the mode of the return type if it is passed
4262 in registers, again to speed up accesses. */
4263 if (TYPE_MODE (gnu_return_type) == BLKmode
4264 && !targetm.calls.return_in_memory (gnu_return_type,
4268 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
4269 unsigned int i = BITS_PER_UNIT;
4270 enum machine_mode mode;
4274 mode = mode_for_size (i, MODE_INT, 0);
4275 if (mode != BLKmode)
4277 SET_TYPE_MODE (gnu_return_type, mode);
4278 TYPE_ALIGN (gnu_return_type)
4279 = GET_MODE_ALIGNMENT (mode);
4280 TYPE_SIZE (gnu_return_type)
4281 = bitsize_int (GET_MODE_BITSIZE (mode));
4282 TYPE_SIZE_UNIT (gnu_return_type)
4283 = size_int (GET_MODE_SIZE (mode));
4288 rest_of_record_type_compilation (gnu_return_type);
4292 if (Has_Stdcall_Convention (gnat_entity))
4293 prepend_one_attribute_to
4294 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4295 get_identifier ("stdcall"), NULL_TREE,
4298 /* If we should request stack realignment for a foreign convention
4299 subprogram, do so. Note that this applies to task entry points in
4301 if (FOREIGN_FORCE_REALIGN_STACK
4302 && Has_Foreign_Convention (gnat_entity))
4303 prepend_one_attribute_to
4304 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4305 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4308 /* The lists have been built in reverse. */
4309 gnu_param_list = nreverse (gnu_param_list);
4311 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4312 gnu_cico_list = nreverse (gnu_cico_list);
4314 if (kind == E_Function)
4315 Set_Mechanism (gnat_entity, return_unconstrained_p
4316 || return_by_direct_ref_p
4317 || return_by_invisi_ref_p
4318 ? By_Reference : By_Copy);
4320 = create_subprog_type (gnu_return_type, gnu_param_list,
4321 gnu_cico_list, return_unconstrained_p,
4322 return_by_direct_ref_p,
4323 return_by_invisi_ref_p);
4327 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4328 gnu_cico_list, return_unconstrained_p,
4329 return_by_direct_ref_p,
4330 return_by_invisi_ref_p);
4332 /* A subprogram (something that doesn't return anything) shouldn't
4333 be considered const since there would be no reason for such a
4334 subprogram. Note that procedures with Out (or In Out) parameters
4335 have already been converted into a function with a return type. */
4336 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4340 = build_qualified_type (gnu_type,
4341 TYPE_QUALS (gnu_type)
4342 | (TYPE_QUAL_CONST * const_flag)
4343 | (TYPE_QUAL_VOLATILE * volatile_flag));
4347 = build_qualified_type (gnu_stub_type,
4348 TYPE_QUALS (gnu_stub_type)
4349 | (TYPE_QUAL_CONST * const_flag)
4350 | (TYPE_QUAL_VOLATILE * volatile_flag));
4352 /* If we have a builtin decl for that function, use it. Check if the
4353 profiles are compatible and warn if they are not. The checker is
4354 expected to post extra diagnostics in this case. */
4355 if (gnu_builtin_decl)
4357 intrin_binding_t inb;
4359 inb.gnat_entity = gnat_entity;
4360 inb.ada_fntype = gnu_type;
4361 inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
4363 if (!intrin_profiles_compatible_p (&inb))
4365 ("?profile of& doesn''t match the builtin it binds!",
4368 gnu_decl = gnu_builtin_decl;
4369 gnu_type = TREE_TYPE (gnu_builtin_decl);
4373 /* If there was no specified Interface_Name and the external and
4374 internal names of the subprogram are the same, only use the
4375 internal name to allow disambiguation of nested subprograms. */
4376 if (No (Interface_Name (gnat_entity))
4377 && gnu_ext_name == gnu_entity_name)
4378 gnu_ext_name = NULL_TREE;
4380 /* If we are defining the subprogram and it has an Address clause
4381 we must get the address expression from the saved GCC tree for the
4382 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4383 the address expression here since the front-end has guaranteed
4384 in that case that the elaboration has no effects. If there is
4385 an Address clause and we are not defining the object, just
4386 make it a constant. */
4387 if (Present (Address_Clause (gnat_entity)))
4389 tree gnu_address = NULL_TREE;
4393 = (present_gnu_tree (gnat_entity)
4394 ? get_gnu_tree (gnat_entity)
4395 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4397 save_gnu_tree (gnat_entity, NULL_TREE, false);
4399 /* Convert the type of the object to a reference type that can
4400 alias everything as per 13.3(19). */
4402 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4404 gnu_address = convert (gnu_type, gnu_address);
4407 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4408 gnu_address, false, Is_Public (gnat_entity),
4409 extern_flag, false, NULL, gnat_entity);
4410 DECL_BY_REF_P (gnu_decl) = 1;
4413 else if (kind == E_Subprogram_Type)
4415 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4416 artificial_flag, debug_info_p, gnat_entity);
4421 gnu_stub_name = gnu_ext_name;
4422 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4423 public_flag = false;
4424 artificial_flag = true;
4428 = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4429 gnu_param_list, inline_flag, public_flag,
4430 extern_flag, artificial_flag, attr_list,
4435 = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4436 gnu_stub_type, gnu_stub_param_list,
4437 inline_flag, true, extern_flag,
4438 false, attr_list, gnat_entity);
4439 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4442 /* This is unrelated to the stub built right above. */
4443 DECL_STUBBED_P (gnu_decl)
4444 = Convention (gnat_entity) == Convention_Stubbed;
4449 case E_Incomplete_Type:
4450 case E_Incomplete_Subtype:
4451 case E_Private_Type:
4452 case E_Private_Subtype:
4453 case E_Limited_Private_Type:
4454 case E_Limited_Private_Subtype:
4455 case E_Record_Type_With_Private:
4456 case E_Record_Subtype_With_Private:
4458 /* Get the "full view" of this entity. If this is an incomplete
4459 entity from a limited with, treat its non-limited view as the
4460 full view. Otherwise, use either the full view or the underlying
4461 full view, whichever is present. This is used in all the tests
4464 = (IN (kind, Incomplete_Kind) && From_With_Type (gnat_entity))
4465 ? Non_Limited_View (gnat_entity)
4466 : Present (Full_View (gnat_entity))
4467 ? Full_View (gnat_entity)
4468 : Underlying_Full_View (gnat_entity);
4470 /* If this is an incomplete type with no full view, it must be a Taft
4471 Amendment type, in which case we return a dummy type. Otherwise,
4472 just get the type from its Etype. */
4475 if (kind == E_Incomplete_Type)
4477 gnu_type = make_dummy_type (gnat_entity);
4478 gnu_decl = TYPE_STUB_DECL (gnu_type);
4482 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4484 maybe_present = true;
4489 /* If we already made a type for the full view, reuse it. */
4490 else if (present_gnu_tree (full_view))
4492 gnu_decl = get_gnu_tree (full_view);
4496 /* Otherwise, if we are not defining the type now, get the type
4497 from the full view. But always get the type from the full view
4498 for define on use types, since otherwise we won't see them! */
4499 else if (!definition
4500 || (Is_Itype (full_view)
4501 && No (Freeze_Node (gnat_entity)))
4502 || (Is_Itype (gnat_entity)
4503 && No (Freeze_Node (full_view))))
4505 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4506 maybe_present = true;
4510 /* For incomplete types, make a dummy type entry which will be
4511 replaced later. Save it as the full declaration's type so
4512 we can do any needed updates when we see it. */
4513 gnu_type = make_dummy_type (gnat_entity);
4514 gnu_decl = TYPE_STUB_DECL (gnu_type);
4515 if (Has_Completion_In_Body (gnat_entity))
4516 DECL_TAFT_TYPE_P (gnu_decl) = 1;
4517 save_gnu_tree (full_view, gnu_decl, 0);
4521 case E_Class_Wide_Type:
4522 /* Class-wide types are always transformed into their root type. */
4523 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4524 maybe_present = true;
4528 case E_Task_Subtype:
4529 case E_Protected_Type:
4530 case E_Protected_Subtype:
4531 /* Concurrent types are always transformed into their record type. */
4532 if (type_annotate_only && No (gnat_equiv_type))
4533 gnu_type = void_type_node;
4535 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4536 maybe_present = true;
4540 gnu_decl = create_label_decl (gnu_entity_name);
4545 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4546 we've already saved it, so we don't try to. */
4547 gnu_decl = error_mark_node;
4555 /* If we had a case where we evaluated another type and it might have
4556 defined this one, handle it here. */
4557 if (maybe_present && present_gnu_tree (gnat_entity))
4559 gnu_decl = get_gnu_tree (gnat_entity);
4563 /* If we are processing a type and there is either no decl for it or
4564 we just made one, do some common processing for the type, such as
4565 handling alignment and possible padding. */
4566 if (is_type && (!gnu_decl || this_made_decl))
4568 /* Tell the middle-end that objects of tagged types are guaranteed to
4569 be properly aligned. This is necessary because conversions to the
4570 class-wide type are translated into conversions to the root type,
4571 which can be less aligned than some of its derived types. */
4572 if (Is_Tagged_Type (gnat_entity)
4573 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4574 TYPE_ALIGN_OK (gnu_type) = 1;
4576 /* If the type is passed by reference, objects of this type must be
4577 fully addressable and cannot be copied. */
4578 if (Is_By_Reference_Type (gnat_entity))
4579 TREE_ADDRESSABLE (gnu_type) = 1;
4581 /* ??? Don't set the size for a String_Literal since it is either
4582 confirming or we don't handle it properly (if the low bound is
4584 if (!gnu_size && kind != E_String_Literal_Subtype)
4586 Uint gnat_size = Known_Esize (gnat_entity)
4587 ? Esize (gnat_entity) : RM_Size (gnat_entity);
4589 = validate_size (gnat_size, gnu_type, gnat_entity, TYPE_DECL,
4590 false, Has_Size_Clause (gnat_entity));
4593 /* If a size was specified, see if we can make a new type of that size
4594 by rearranging the type, for example from a fat to a thin pointer. */
4598 = make_type_from_size (gnu_type, gnu_size,
4599 Has_Biased_Representation (gnat_entity));
4601 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4602 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4606 /* If the alignment hasn't already been processed and this is
4607 not an unconstrained array, see if an alignment is specified.
4608 If not, we pick a default alignment for atomic objects. */
4609 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4611 else if (Known_Alignment (gnat_entity))
4613 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4614 TYPE_ALIGN (gnu_type));
4616 /* Warn on suspiciously large alignments. This should catch
4617 errors about the (alignment,byte)/(size,bit) discrepancy. */
4618 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4622 /* If a size was specified, take it into account. Otherwise
4623 use the RM size for records as the type size has already
4624 been adjusted to the alignment. */
4627 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4628 || TREE_CODE (gnu_type) == UNION_TYPE
4629 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4630 && !TYPE_FAT_POINTER_P (gnu_type))
4631 size = rm_size (gnu_type);
4633 size = TYPE_SIZE (gnu_type);
4635 /* Consider an alignment as suspicious if the alignment/size
4636 ratio is greater or equal to the byte/bit ratio. */
4637 if (host_integerp (size, 1)
4638 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4639 post_error_ne ("?suspiciously large alignment specified for&",
4640 Expression (Alignment_Clause (gnat_entity)),
4644 else if (Is_Atomic (gnat_entity) && !gnu_size
4645 && host_integerp (TYPE_SIZE (gnu_type), 1)
4646 && integer_pow2p (TYPE_SIZE (gnu_type)))
4647 align = MIN (BIGGEST_ALIGNMENT,
4648 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4649 else if (Is_Atomic (gnat_entity) && gnu_size
4650 && host_integerp (gnu_size, 1)
4651 && integer_pow2p (gnu_size))
4652 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4654 /* See if we need to pad the type. If we did, and made a record,
4655 the name of the new type may be changed. So get it back for
4656 us when we make the new TYPE_DECL below. */
4657 if (gnu_size || align > 0)
4658 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4659 false, !gnu_decl, definition, false);
4661 if (TYPE_IS_PADDING_P (gnu_type))
4663 gnu_entity_name = TYPE_NAME (gnu_type);
4664 if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
4665 gnu_entity_name = DECL_NAME (gnu_entity_name);
4668 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4670 /* If we are at global level, GCC will have applied variable_size to
4671 the type, but that won't have done anything. So, if it's not
4672 a constant or self-referential, call elaborate_expression_1 to
4673 make a variable for the size rather than calculating it each time.
4674 Handle both the RM size and the actual size. */
4675 if (global_bindings_p ()
4676 && TYPE_SIZE (gnu_type)
4677 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4678 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4680 tree size = TYPE_SIZE (gnu_type);
4682 TYPE_SIZE (gnu_type)
4683 = elaborate_expression_1 (size, gnat_entity,
4684 get_identifier ("SIZE"),
4687 /* ??? For now, store the size as a multiple of the alignment in
4688 bytes so that we can see the alignment from the tree. */
4689 TYPE_SIZE_UNIT (gnu_type)
4690 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity,
4691 get_identifier ("SIZE_A_UNIT"),
4693 TYPE_ALIGN (gnu_type));
4695 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4696 may not be marked by the call to create_type_decl below. */
4697 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
4699 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4701 tree variant_part = get_variant_part (gnu_type);
4702 tree ada_size = TYPE_ADA_SIZE (gnu_type);
4706 tree union_type = TREE_TYPE (variant_part);
4707 tree offset = DECL_FIELD_OFFSET (variant_part);
4709 /* If the position of the variant part is constant, subtract
4710 it from the size of the type of the parent to get the new
4711 size. This manual CSE reduces the data size. */
4712 if (TREE_CODE (offset) == INTEGER_CST)
4714 tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part);
4715 TYPE_SIZE (union_type)
4716 = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type),
4717 bit_from_pos (offset, bitpos));
4718 TYPE_SIZE_UNIT (union_type)
4719 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type),
4720 byte_from_pos (offset, bitpos));
4724 TYPE_SIZE (union_type)
4725 = elaborate_expression_1 (TYPE_SIZE (union_type),
4727 get_identifier ("VSIZE"),
4730 /* ??? For now, store the size as a multiple of the
4731 alignment in bytes so that we can see the alignment
4733 TYPE_SIZE_UNIT (union_type)
4734 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type),
4739 TYPE_ALIGN (union_type));
4741 /* ??? For now, store the offset as a multiple of the
4742 alignment in bytes so that we can see the alignment
4744 DECL_FIELD_OFFSET (variant_part)
4745 = elaborate_expression_2 (offset,
4747 get_identifier ("VOFFSET"),
4753 DECL_SIZE (variant_part) = TYPE_SIZE (union_type);
4754 DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
4757 if (operand_equal_p (ada_size, size, 0))
4758 ada_size = TYPE_SIZE (gnu_type);
4761 = elaborate_expression_1 (ada_size, gnat_entity,
4762 get_identifier ("RM_SIZE"),
4764 SET_TYPE_ADA_SIZE (gnu_type, ada_size);
4768 /* If this is a record type or subtype, call elaborate_expression_1 on
4769 any field position. Do this for both global and local types.
4770 Skip any fields that we haven't made trees for to avoid problems with
4771 class wide types. */
4772 if (IN (kind, Record_Kind))
4773 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4774 gnat_temp = Next_Entity (gnat_temp))
4775 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4777 tree gnu_field = get_gnu_tree (gnat_temp);
4779 /* ??? For now, store the offset as a multiple of the alignment
4780 in bytes so that we can see the alignment from the tree. */
4781 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4783 DECL_FIELD_OFFSET (gnu_field)
4784 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
4786 get_identifier ("OFFSET"),
4788 DECL_OFFSET_ALIGN (gnu_field));
4790 /* ??? The context of gnu_field is not necessarily gnu_type
4791 so the MULT_EXPR node built above may not be marked by
4792 the call to create_type_decl below. */
4793 if (global_bindings_p ())
4794 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4798 if (Treat_As_Volatile (gnat_entity))
4800 = build_qualified_type (gnu_type,
4801 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
4803 if (Is_Atomic (gnat_entity))
4804 check_ok_for_atomic (gnu_type, gnat_entity, false);
4806 if (Present (Alignment_Clause (gnat_entity)))
4807 TYPE_USER_ALIGN (gnu_type) = 1;
4809 if (Universal_Aliasing (gnat_entity))
4810 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4813 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4814 !Comes_From_Source (gnat_entity),
4815 debug_info_p, gnat_entity);
4818 TREE_TYPE (gnu_decl) = gnu_type;
4819 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4823 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4825 gnu_type = TREE_TYPE (gnu_decl);
4827 /* If this is a derived type, relate its alias set to that of its parent
4828 to avoid troubles when a call to an inherited primitive is inlined in
4829 a context where a derived object is accessed. The inlined code works
4830 on the parent view so the resulting code may access the same object
4831 using both the parent and the derived alias sets, which thus have to
4832 conflict. As the same issue arises with component references, the
4833 parent alias set also has to conflict with composite types enclosing
4834 derived components. For instance, if we have:
4841 we want T to conflict with both D and R, in addition to R being a
4842 superset of D by record/component construction.
4844 One way to achieve this is to perform an alias set copy from the
4845 parent to the derived type. This is not quite appropriate, though,
4846 as we don't want separate derived types to conflict with each other:
4848 type I1 is new Integer;
4849 type I2 is new Integer;
4851 We want I1 and I2 to both conflict with Integer but we do not want
4852 I1 to conflict with I2, and an alias set copy on derivation would
4855 The option chosen is to make the alias set of the derived type a
4856 superset of that of its parent type. It trivially fulfills the
4857 simple requirement for the Integer derivation example above, and
4858 the component case as well by superset transitivity:
4861 R ----------> D ----------> T
4863 However, for composite types, conversions between derived types are
4864 translated into VIEW_CONVERT_EXPRs so a sequence like:
4866 type Comp1 is new Comp;
4867 type Comp2 is new Comp;
4868 procedure Proc (C : Comp1);
4876 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4878 and gimplified into:
4885 i.e. generates code involving type punning. Therefore, Comp1 needs
4886 to conflict with Comp2 and an alias set copy is required.
4888 The language rules ensure the parent type is already frozen here. */
4889 if (Is_Derived_Type (gnat_entity))
4891 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
4892 relate_alias_sets (gnu_type, gnu_parent_type,
4893 Is_Composite_Type (gnat_entity)
4894 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
4897 /* Back-annotate the Alignment of the type if not already in the
4898 tree. Likewise for sizes. */
4899 if (Unknown_Alignment (gnat_entity))
4901 unsigned int double_align, align;
4902 bool is_capped_double, align_clause;
4904 /* If the default alignment of "double" or larger scalar types is
4905 specifically capped and this is not an array with an alignment
4906 clause on the component type, return the cap. */
4907 if ((double_align = double_float_alignment) > 0)
4909 = is_double_float_or_array (gnat_entity, &align_clause);
4910 else if ((double_align = double_scalar_alignment) > 0)
4912 = is_double_scalar_or_array (gnat_entity, &align_clause);
4914 is_capped_double = align_clause = false;
4916 if (is_capped_double && !align_clause)
4917 align = double_align;
4919 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4921 Set_Alignment (gnat_entity, UI_From_Int (align));
4924 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4926 tree gnu_size = TYPE_SIZE (gnu_type);
4928 /* If the size is self-referential, annotate the maximum value. */
4929 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4930 gnu_size = max_size (gnu_size, true);
4932 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4934 /* In this mode, the tag and the parent components are not
4935 generated by the front-end so the sizes must be adjusted. */
4936 tree pointer_size = bitsize_int (POINTER_SIZE), offset;
4939 if (Is_Derived_Type (gnat_entity))
4941 offset = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
4943 Set_Alignment (gnat_entity,
4944 Alignment (Etype (Base_Type (gnat_entity))));
4947 offset = pointer_size;
4949 gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
4950 gnu_size = size_binop (MULT_EXPR, pointer_size,
4951 size_binop (CEIL_DIV_EXPR,
4954 uint_size = annotate_value (gnu_size);
4955 Set_Esize (gnat_entity, uint_size);
4956 Set_RM_Size (gnat_entity, uint_size);
4959 Set_Esize (gnat_entity, annotate_value (gnu_size));
4962 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4963 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4966 /* If we really have a ..._DECL node, set a couple of flags on it. But we
4967 cannot do so if we are reusing the ..._DECL node made for an alias or a
4968 renamed object as the predicates don't apply to it but to GNAT_ENTITY. */
4969 if (DECL_P (gnu_decl)
4970 && !Present (Alias (gnat_entity))
4971 && !(Present (Renamed_Object (gnat_entity)) && saved))
4973 if (!Comes_From_Source (gnat_entity))
4974 DECL_ARTIFICIAL (gnu_decl) = 1;
4977 DECL_IGNORED_P (gnu_decl) = 1;
4980 /* If we haven't already, associate the ..._DECL node that we just made with
4981 the input GNAT entity node. */
4983 save_gnu_tree (gnat_entity, gnu_decl, false);
4985 /* If this is an enumeration or floating-point type, we were not able to set
4986 the bounds since they refer to the type. These are always static. */
4987 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4988 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4990 tree gnu_scalar_type = gnu_type;
4991 tree gnu_low_bound, gnu_high_bound;
4993 /* If this is a padded type, we need to use the underlying type. */
4994 if (TYPE_IS_PADDING_P (gnu_scalar_type))
4995 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4997 /* If this is a floating point type and we haven't set a floating
4998 point type yet, use this in the evaluation of the bounds. */
4999 if (!longest_float_type_node && kind == E_Floating_Point_Type)
5000 longest_float_type_node = gnu_scalar_type;
5002 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
5003 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
5005 if (kind == E_Enumeration_Type)
5007 /* Enumeration types have specific RM bounds. */
5008 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
5009 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
5011 /* Write full debugging information. */
5012 rest_of_type_decl_compilation (gnu_decl);
5017 /* Floating-point types don't have specific RM bounds. */
5018 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
5019 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
5023 /* If we deferred processing of incomplete types, re-enable it. If there
5024 were no other disables and we have deferred types to process, do so. */
5026 && --defer_incomplete_level == 0
5027 && defer_incomplete_list)
5029 struct incomplete *p, *next;
5031 /* We are back to level 0 for the deferring of incomplete types.
5032 But processing these incomplete types below may itself require
5033 deferring, so preserve what we have and restart from scratch. */
5034 p = defer_incomplete_list;
5035 defer_incomplete_list = NULL;
5037 /* For finalization, however, all types must be complete so we
5038 cannot do the same because deferred incomplete types may end up
5039 referencing each other. Process them all recursively first. */
5040 defer_finalize_level++;
5047 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5048 gnat_to_gnu_type (p->full_type));
5052 defer_finalize_level--;
5055 /* If all the deferred incomplete types have been processed, we can proceed
5056 with the finalization of the deferred types. */
5057 if (defer_incomplete_level == 0
5058 && defer_finalize_level == 0
5059 && defer_finalize_list)
5064 FOR_EACH_VEC_ELT (tree, defer_finalize_list, i, t)
5065 rest_of_type_decl_compilation_no_defer (t);
5067 VEC_free (tree, heap, defer_finalize_list);
5070 /* If we are not defining this type, see if it's on one of the lists of
5071 incomplete types. If so, handle the list entry now. */
5072 if (is_type && !definition)
5074 struct incomplete *p;
5076 for (p = defer_incomplete_list; p; p = p->next)
5077 if (p->old_type && p->full_type == gnat_entity)
5079 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5080 TREE_TYPE (gnu_decl));
5081 p->old_type = NULL_TREE;
5084 for (p = defer_limited_with; p; p = p->next)
5085 if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
5087 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5088 TREE_TYPE (gnu_decl));
5089 p->old_type = NULL_TREE;
5096 /* If this is a packed array type whose original array type is itself
5097 an Itype without freeze node, make sure the latter is processed. */
5098 if (Is_Packed_Array_Type (gnat_entity)
5099 && Is_Itype (Original_Array_Type (gnat_entity))
5100 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
5101 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
5102 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
5107 /* Similar, but if the returned value is a COMPONENT_REF, return the
5111 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
5113 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5115 if (TREE_CODE (gnu_field) == COMPONENT_REF)
5116 gnu_field = TREE_OPERAND (gnu_field, 1);
5121 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5122 the GCC type corresponding to that entity. */
5125 gnat_to_gnu_type (Entity_Id gnat_entity)
5129 /* The back end never attempts to annotate generic types. */
5130 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
5131 return void_type_node;
5133 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5134 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
5136 return TREE_TYPE (gnu_decl);
5139 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5140 the unpadded version of the GCC type corresponding to that entity. */
5143 get_unpadded_type (Entity_Id gnat_entity)
5145 tree type = gnat_to_gnu_type (gnat_entity);
5147 if (TYPE_IS_PADDING_P (type))
5148 type = TREE_TYPE (TYPE_FIELDS (type));
5153 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
5154 Every TYPE_DECL generated for a type definition must be passed
5155 to this function once everything else has been done for it. */
5158 rest_of_type_decl_compilation (tree decl)
5160 /* We need to defer finalizing the type if incomplete types
5161 are being deferred or if they are being processed. */
5162 if (defer_incomplete_level != 0 || defer_finalize_level != 0)
5163 VEC_safe_push (tree, heap, defer_finalize_list, decl);
5165 rest_of_type_decl_compilation_no_defer (decl);
5168 /* Same as above but without deferring the compilation. This
5169 function should not be invoked directly on a TYPE_DECL. */
5172 rest_of_type_decl_compilation_no_defer (tree decl)
5174 const int toplev = global_bindings_p ();
5175 tree t = TREE_TYPE (decl);
5177 rest_of_decl_compilation (decl, toplev, 0);
5179 /* Now process all the variants. This is needed for STABS. */
5180 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
5182 if (t == TREE_TYPE (decl))
5185 if (!TYPE_STUB_DECL (t))
5186 TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
5188 rest_of_type_compilation (t, toplev);
5192 /* Finalize the processing of From_With_Type incomplete types. */
5195 finalize_from_with_types (void)
5197 struct incomplete *p, *next;
5199 p = defer_limited_with;
5200 defer_limited_with = NULL;
5207 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5208 gnat_to_gnu_type (p->full_type));
5213 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
5214 kind of type (such E_Task_Type) that has a different type which Gigi
5215 uses for its representation. If the type does not have a special type
5216 for its representation, return GNAT_ENTITY. If a type is supposed to
5217 exist, but does not, abort unless annotating types, in which case
5218 return Empty. If GNAT_ENTITY is Empty, return Empty. */
5221 Gigi_Equivalent_Type (Entity_Id gnat_entity)
5223 Entity_Id gnat_equiv = gnat_entity;
5225 if (No (gnat_entity))
5228 switch (Ekind (gnat_entity))
5230 case E_Class_Wide_Subtype:
5231 if (Present (Equivalent_Type (gnat_entity)))
5232 gnat_equiv = Equivalent_Type (gnat_entity);
5235 case E_Access_Protected_Subprogram_Type:
5236 case E_Anonymous_Access_Protected_Subprogram_Type:
5237 gnat_equiv = Equivalent_Type (gnat_entity);
5240 case E_Class_Wide_Type:
5241 gnat_equiv = Root_Type (gnat_entity);
5245 case E_Task_Subtype:
5246 case E_Protected_Type:
5247 case E_Protected_Subtype:
5248 gnat_equiv = Corresponding_Record_Type (gnat_entity);
5255 gcc_assert (Present (gnat_equiv) || type_annotate_only);
5259 /* Return a GCC tree for a type corresponding to the component type of the
5260 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5261 is for an array being defined. DEBUG_INFO_P is true if we need to write
5262 debug information for other types that we may create in the process. */
5265 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5268 const Entity_Id gnat_type = Component_Type (gnat_array);
5269 tree gnu_type = gnat_to_gnu_type (gnat_type);
5272 /* Try to get a smaller form of the component if needed. */
5273 if ((Is_Packed (gnat_array)
5274 || Has_Component_Size_Clause (gnat_array))
5275 && !Is_Bit_Packed_Array (gnat_array)
5276 && !Has_Aliased_Components (gnat_array)
5277 && !Strict_Alignment (gnat_type)
5278 && TREE_CODE (gnu_type) == RECORD_TYPE
5279 && !TYPE_FAT_POINTER_P (gnu_type)
5280 && host_integerp (TYPE_SIZE (gnu_type), 1))
5281 gnu_type = make_packable_type (gnu_type, false);
5283 if (Has_Atomic_Components (gnat_array))
5284 check_ok_for_atomic (gnu_type, gnat_array, true);
5286 /* Get and validate any specified Component_Size. */
5288 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5289 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5290 true, Has_Component_Size_Clause (gnat_array));
5292 /* If the array has aliased components and the component size can be zero,
5293 force at least unit size to ensure that the components have distinct
5296 && Has_Aliased_Components (gnat_array)
5297 && (integer_zerop (TYPE_SIZE (gnu_type))
5298 || (TREE_CODE (gnu_type) == ARRAY_TYPE
5299 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5301 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5303 /* If the component type is a RECORD_TYPE that has a self-referential size,
5304 then use the maximum size for the component size. */
5306 && TREE_CODE (gnu_type) == RECORD_TYPE
5307 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5308 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5310 /* Honor the component size. This is not needed for bit-packed arrays. */
5311 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5313 tree orig_type = gnu_type;
5314 unsigned int max_align;
5316 /* If an alignment is specified, use it as a cap on the component type
5317 so that it can be honored for the whole type. But ignore it for the
5318 original type of packed array types. */
5319 if (No (Packed_Array_Type (gnat_array)) && Known_Alignment (gnat_array))
5320 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5324 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5325 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5326 gnu_type = orig_type;
5328 orig_type = gnu_type;
5330 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5331 true, false, definition, true);
5333 /* If a padding record was made, declare it now since it will never be
5334 declared otherwise. This is necessary to ensure that its subtrees
5335 are properly marked. */
5336 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5337 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
5338 debug_info_p, gnat_array);
5341 if (Has_Volatile_Components (gnat_array))
5343 = build_qualified_type (gnu_type,
5344 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
5349 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5350 using MECH as its passing mechanism, to be placed in the parameter
5351 list built for GNAT_SUBPROG. Assume a foreign convention for the
5352 latter if FOREIGN is true. Also set CICO to true if the parameter
5353 must use the copy-in copy-out implementation mechanism.
5355 The returned tree is a PARM_DECL, except for those cases where no
5356 parameter needs to be actually passed to the subprogram; the type
5357 of this "shadow" parameter is then returned instead. */
5360 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5361 Entity_Id gnat_subprog, bool foreign, bool *cico)
5363 tree gnu_param_name = get_entity_name (gnat_param);
5364 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5365 tree gnu_param_type_alt = NULL_TREE;
5366 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5367 /* The parameter can be indirectly modified if its address is taken. */
5368 bool ro_param = in_param && !Address_Taken (gnat_param);
5369 bool by_return = false, by_component_ptr = false;
5370 bool by_ref = false, by_double_ref = false;
5373 /* Copy-return is used only for the first parameter of a valued procedure.
5374 It's a copy mechanism for which a parameter is never allocated. */
5375 if (mech == By_Copy_Return)
5377 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5382 /* If this is either a foreign function or if the underlying type won't
5383 be passed by reference, strip off possible padding type. */
5384 if (TYPE_IS_PADDING_P (gnu_param_type))
5386 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5388 if (mech == By_Reference
5390 || (!must_pass_by_ref (unpadded_type)
5391 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
5392 gnu_param_type = unpadded_type;
5395 /* If this is a read-only parameter, make a variant of the type that is
5396 read-only. ??? However, if this is an unconstrained array, that type
5397 can be very complex, so skip it for now. Likewise for any other
5398 self-referential type. */
5400 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5401 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5402 gnu_param_type = build_qualified_type (gnu_param_type,
5403 (TYPE_QUALS (gnu_param_type)
5404 | TYPE_QUAL_CONST));
5406 /* For foreign conventions, pass arrays as pointers to the element type.
5407 First check for unconstrained array and get the underlying array. */
5408 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5410 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5412 /* For GCC builtins, pass Address integer types as (void *) */
5413 if (Convention (gnat_subprog) == Convention_Intrinsic
5414 && Present (Interface_Name (gnat_subprog))
5415 && Is_Descendent_Of_Address (Etype (gnat_param)))
5416 gnu_param_type = ptr_void_type_node;
5418 /* VMS descriptors are themselves passed by reference. */
5419 if (mech == By_Short_Descriptor ||
5420 (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
5422 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5423 Mechanism (gnat_param),
5425 else if (mech == By_Descriptor)
5427 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5428 chosen in fill_vms_descriptor. */
5430 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5431 Mechanism (gnat_param),
5434 = build_pointer_type (build_vms_descriptor (gnu_param_type,
5435 Mechanism (gnat_param),
5439 /* Arrays are passed as pointers to element type for foreign conventions. */
5442 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5444 /* Strip off any multi-dimensional entries, then strip
5445 off the last array to get the component type. */
5446 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5447 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5448 gnu_param_type = TREE_TYPE (gnu_param_type);
5450 by_component_ptr = true;
5451 gnu_param_type = TREE_TYPE (gnu_param_type);
5454 gnu_param_type = build_qualified_type (gnu_param_type,
5455 (TYPE_QUALS (gnu_param_type)
5456 | TYPE_QUAL_CONST));
5458 gnu_param_type = build_pointer_type (gnu_param_type);
5461 /* Fat pointers are passed as thin pointers for foreign conventions. */
5462 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5464 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5466 /* If we must pass or were requested to pass by reference, do so.
5467 If we were requested to pass by copy, do so.
5468 Otherwise, for foreign conventions, pass In Out or Out parameters
5469 or aggregates by reference. For COBOL and Fortran, pass all
5470 integer and FP types that way too. For Convention Ada, use
5471 the standard Ada default. */
5472 else if (must_pass_by_ref (gnu_param_type)
5473 || mech == By_Reference
5476 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5478 && (Convention (gnat_subprog) == Convention_Fortran
5479 || Convention (gnat_subprog) == Convention_COBOL)
5480 && (INTEGRAL_TYPE_P (gnu_param_type)
5481 || FLOAT_TYPE_P (gnu_param_type)))
5483 && default_pass_by_ref (gnu_param_type)))))
5485 gnu_param_type = build_reference_type (gnu_param_type);
5488 /* In some ABIs, e.g. SPARC 32-bit, fat pointer types are themselves
5489 passed by reference. Pass them by explicit reference, this will
5490 generate more debuggable code at -O0. */
5491 if (TYPE_IS_FAT_POINTER_P (gnu_param_type)
5492 && targetm.calls.pass_by_reference (pack_cumulative_args (NULL),
5493 TYPE_MODE (gnu_param_type),
5497 gnu_param_type = build_reference_type (gnu_param_type);
5498 by_double_ref = true;
5502 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5506 if (mech == By_Copy && (by_ref || by_component_ptr))
5507 post_error ("?cannot pass & by copy", gnat_param);
5509 /* If this is an Out parameter that isn't passed by reference and isn't
5510 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5511 it will be a VAR_DECL created when we process the procedure, so just
5512 return its type. For the special parameter of a valued procedure,
5515 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5516 Out parameters with discriminants or implicit initial values to be
5517 handled like In Out parameters. These type are normally built as
5518 aggregates, hence passed by reference, except for some packed arrays
5519 which end up encoded in special integer types.
5521 The exception we need to make is then for packed arrays of records
5522 with discriminants or implicit initial values. We have no light/easy
5523 way to check for the latter case, so we merely check for packed arrays
5524 of records. This may lead to useless copy-in operations, but in very
5525 rare cases only, as these would be exceptions in a set of already
5526 exceptional situations. */
5527 if (Ekind (gnat_param) == E_Out_Parameter
5530 || (mech != By_Descriptor
5531 && mech != By_Short_Descriptor
5532 && !POINTER_TYPE_P (gnu_param_type)
5533 && !AGGREGATE_TYPE_P (gnu_param_type)))
5534 && !(Is_Array_Type (Etype (gnat_param))
5535 && Is_Packed (Etype (gnat_param))
5536 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5537 return gnu_param_type;
5539 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5540 ro_param || by_ref || by_component_ptr);
5541 DECL_BY_REF_P (gnu_param) = by_ref;
5542 DECL_BY_DOUBLE_REF_P (gnu_param) = by_double_ref;
5543 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5544 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
5545 mech == By_Short_Descriptor);
5546 DECL_POINTS_TO_READONLY_P (gnu_param)
5547 = (ro_param && (by_ref || by_component_ptr));
5549 /* Save the alternate descriptor type, if any. */
5550 if (gnu_param_type_alt)
5551 SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5553 /* If no Mechanism was specified, indicate what we're using, then
5554 back-annotate it. */
5555 if (mech == Default)
5556 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5558 Set_Mechanism (gnat_param, mech);
5562 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5565 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5567 while (Present (Corresponding_Discriminant (discr1)))
5568 discr1 = Corresponding_Discriminant (discr1);
5570 while (Present (Corresponding_Discriminant (discr2)))
5571 discr2 = Corresponding_Discriminant (discr2);
5574 Original_Record_Component (discr1) == Original_Record_Component (discr2);
5577 /* Return true if the array type GNU_TYPE, which represents a dimension of
5578 GNAT_TYPE, has a non-aliased component in the back-end sense. */
5581 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
5583 /* If the array type is not the innermost dimension of the GNAT type,
5584 then it has a non-aliased component. */
5585 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5586 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5589 /* If the array type has an aliased component in the front-end sense,
5590 then it also has an aliased component in the back-end sense. */
5591 if (Has_Aliased_Components (gnat_type))
5594 /* If this is a derived type, then it has a non-aliased component if
5595 and only if its parent type also has one. */
5596 if (Is_Derived_Type (gnat_type))
5598 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
5600 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
5602 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
5603 for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
5604 gnu_parent_type = TREE_TYPE (gnu_parent_type);
5605 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
5608 /* Otherwise, rely exclusively on properties of the element type. */
5609 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5612 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5615 compile_time_known_address_p (Node_Id gnat_address)
5617 /* Catch System'To_Address. */
5618 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5619 gnat_address = Expression (gnat_address);
5621 return Compile_Time_Known_Value (gnat_address);
5624 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
5625 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
5628 cannot_be_superflat_p (Node_Id gnat_range)
5630 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
5631 Node_Id scalar_range;
5632 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
5634 /* If the low bound is not constant, try to find an upper bound. */
5635 while (Nkind (gnat_lb) != N_Integer_Literal
5636 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
5637 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
5638 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
5639 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5640 || Nkind (scalar_range) == N_Range))
5641 gnat_lb = High_Bound (scalar_range);
5643 /* If the high bound is not constant, try to find a lower bound. */
5644 while (Nkind (gnat_hb) != N_Integer_Literal
5645 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
5646 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
5647 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
5648 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5649 || Nkind (scalar_range) == N_Range))
5650 gnat_hb = Low_Bound (scalar_range);
5652 /* If we have failed to find constant bounds, punt. */
5653 if (Nkind (gnat_lb) != N_Integer_Literal
5654 || Nkind (gnat_hb) != N_Integer_Literal)
5657 /* We need at least a signed 64-bit type to catch most cases. */
5658 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
5659 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
5660 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
5663 /* If the low bound is the smallest integer, nothing can be smaller. */
5664 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
5665 if (TREE_OVERFLOW (gnu_lb_minus_one))
5668 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
5671 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
5674 constructor_address_p (tree gnu_expr)
5676 while (TREE_CODE (gnu_expr) == NOP_EXPR
5677 || TREE_CODE (gnu_expr) == CONVERT_EXPR
5678 || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
5679 gnu_expr = TREE_OPERAND (gnu_expr, 0);
5681 return (TREE_CODE (gnu_expr) == ADDR_EXPR
5682 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
5685 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5686 be elaborated at the point of its definition, but do nothing else. */
5689 elaborate_entity (Entity_Id gnat_entity)
5691 switch (Ekind (gnat_entity))
5693 case E_Signed_Integer_Subtype:
5694 case E_Modular_Integer_Subtype:
5695 case E_Enumeration_Subtype:
5696 case E_Ordinary_Fixed_Point_Subtype:
5697 case E_Decimal_Fixed_Point_Subtype:
5698 case E_Floating_Point_Subtype:
5700 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5701 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5703 /* ??? Tests to avoid Constraint_Error in static expressions
5704 are needed until after the front stops generating bogus
5705 conversions on bounds of real types. */
5706 if (!Raises_Constraint_Error (gnat_lb))
5707 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5708 true, false, Needs_Debug_Info (gnat_entity));
5709 if (!Raises_Constraint_Error (gnat_hb))
5710 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5711 true, false, Needs_Debug_Info (gnat_entity));
5717 Node_Id full_definition = Declaration_Node (gnat_entity);
5718 Node_Id record_definition = Type_Definition (full_definition);
5720 /* If this is a record extension, go a level further to find the
5721 record definition. */
5722 if (Nkind (record_definition) == N_Derived_Type_Definition)
5723 record_definition = Record_Extension_Part (record_definition);
5727 case E_Record_Subtype:
5728 case E_Private_Subtype:
5729 case E_Limited_Private_Subtype:
5730 case E_Record_Subtype_With_Private:
5731 if (Is_Constrained (gnat_entity)
5732 && Has_Discriminants (gnat_entity)
5733 && Present (Discriminant_Constraint (gnat_entity)))
5735 Node_Id gnat_discriminant_expr;
5736 Entity_Id gnat_field;
5739 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
5740 gnat_discriminant_expr
5741 = First_Elmt (Discriminant_Constraint (gnat_entity));
5742 Present (gnat_field);
5743 gnat_field = Next_Discriminant (gnat_field),
5744 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5745 /* ??? For now, ignore access discriminants. */
5746 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5747 elaborate_expression (Node (gnat_discriminant_expr),
5748 gnat_entity, get_entity_name (gnat_field),
5749 true, false, false);
5756 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5757 any entities on its entity chain similarly. */
5760 mark_out_of_scope (Entity_Id gnat_entity)
5762 Entity_Id gnat_sub_entity;
5763 unsigned int kind = Ekind (gnat_entity);
5765 /* If this has an entity list, process all in the list. */
5766 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5767 || IN (kind, Private_Kind)
5768 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5769 || kind == E_Function || kind == E_Generic_Function
5770 || kind == E_Generic_Package || kind == E_Generic_Procedure
5771 || kind == E_Loop || kind == E_Operator || kind == E_Package
5772 || kind == E_Package_Body || kind == E_Procedure
5773 || kind == E_Record_Type || kind == E_Record_Subtype
5774 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5775 for (gnat_sub_entity = First_Entity (gnat_entity);
5776 Present (gnat_sub_entity);
5777 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5778 if (Scope (gnat_sub_entity) == gnat_entity
5779 && gnat_sub_entity != gnat_entity)
5780 mark_out_of_scope (gnat_sub_entity);
5782 /* Now clear this if it has been defined, but only do so if it isn't
5783 a subprogram or parameter. We could refine this, but it isn't
5784 worth it. If this is statically allocated, it is supposed to
5785 hang around out of cope. */
5786 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5787 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5789 save_gnu_tree (gnat_entity, NULL_TREE, true);
5790 save_gnu_tree (gnat_entity, error_mark_node, true);
5794 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5795 If this is a multi-dimensional array type, do this recursively.
5798 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5799 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5800 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5803 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
5805 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5806 of a one-dimensional array, since the padding has the same alias set
5807 as the field type, but if it's a multi-dimensional array, we need to
5808 see the inner types. */
5809 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5810 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5811 || TYPE_PADDING_P (gnu_old_type)))
5812 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5814 /* Unconstrained array types are deemed incomplete and would thus be given
5815 alias set 0. Retrieve the underlying array type. */
5816 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5818 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5819 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
5821 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
5823 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5824 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5825 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5826 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
5830 case ALIAS_SET_COPY:
5831 /* The alias set shouldn't be copied between array types with different
5832 aliasing settings because this can break the aliasing relationship
5833 between the array type and its element type. */
5834 #ifndef ENABLE_CHECKING
5835 if (flag_strict_aliasing)
5837 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
5838 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
5839 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
5840 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
5842 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5845 case ALIAS_SET_SUBSET:
5846 case ALIAS_SET_SUPERSET:
5848 alias_set_type old_set = get_alias_set (gnu_old_type);
5849 alias_set_type new_set = get_alias_set (gnu_new_type);
5851 /* Do nothing if the alias sets conflict. This ensures that we
5852 never call record_alias_subset several times for the same pair
5853 or at all for alias set 0. */
5854 if (!alias_sets_conflict_p (old_set, new_set))
5856 if (op == ALIAS_SET_SUBSET)
5857 record_alias_subset (old_set, new_set);
5859 record_alias_subset (new_set, old_set);
5868 record_component_aliases (gnu_new_type);
5871 /* Return true if the size represented by GNU_SIZE can be handled by an
5872 allocation. If STATIC_P is true, consider only what can be done with a
5873 static allocation. */
5876 allocatable_size_p (tree gnu_size, bool static_p)
5878 HOST_WIDE_INT our_size;
5880 /* If this is not a static allocation, the only case we want to forbid
5881 is an overflowing size. That will be converted into a raise a
5884 return !(TREE_CODE (gnu_size) == INTEGER_CST
5885 && TREE_OVERFLOW (gnu_size));
5887 /* Otherwise, we need to deal with both variable sizes and constant
5888 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5889 since assemblers may not like very large sizes. */
5890 if (!host_integerp (gnu_size, 1))
5893 our_size = tree_low_cst (gnu_size, 1);
5894 return (int) our_size == our_size;
5897 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5898 NAME, ARGS and ERROR_POINT. */
5901 prepend_one_attribute_to (struct attrib ** attr_list,
5902 enum attr_type attr_type,
5905 Node_Id attr_error_point)
5907 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5909 attr->type = attr_type;
5910 attr->name = attr_name;
5911 attr->args = attr_args;
5912 attr->error_point = attr_error_point;
5914 attr->next = *attr_list;
5918 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5921 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5925 /* Attributes are stored as Representation Item pragmas. */
5927 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5928 gnat_temp = Next_Rep_Item (gnat_temp))
5929 if (Nkind (gnat_temp) == N_Pragma)
5931 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5932 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5933 enum attr_type etype;
5935 /* Map the kind of pragma at hand. Skip if this is not one
5936 we know how to handle. */
5938 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5940 case Pragma_Machine_Attribute:
5941 etype = ATTR_MACHINE_ATTRIBUTE;
5944 case Pragma_Linker_Alias:
5945 etype = ATTR_LINK_ALIAS;
5948 case Pragma_Linker_Section:
5949 etype = ATTR_LINK_SECTION;
5952 case Pragma_Linker_Constructor:
5953 etype = ATTR_LINK_CONSTRUCTOR;
5956 case Pragma_Linker_Destructor:
5957 etype = ATTR_LINK_DESTRUCTOR;
5960 case Pragma_Weak_External:
5961 etype = ATTR_WEAK_EXTERNAL;
5964 case Pragma_Thread_Local_Storage:
5965 etype = ATTR_THREAD_LOCAL_STORAGE;
5972 /* See what arguments we have and turn them into GCC trees for
5973 attribute handlers. These expect identifier for strings. We
5974 handle at most two arguments, static expressions only. */
5976 if (Present (gnat_assoc) && Present (First (gnat_assoc)))
5978 Node_Id gnat_arg0 = Next (First (gnat_assoc));
5979 Node_Id gnat_arg1 = Empty;
5981 if (Present (gnat_arg0)
5982 && Is_Static_Expression (Expression (gnat_arg0)))
5984 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
5986 if (TREE_CODE (gnu_arg0) == STRING_CST)
5987 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
5989 gnat_arg1 = Next (gnat_arg0);
5992 if (Present (gnat_arg1)
5993 && Is_Static_Expression (Expression (gnat_arg1)))
5995 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
5997 if (TREE_CODE (gnu_arg1) == STRING_CST)
5998 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
6002 /* Prepend to the list now. Make a list of the argument we might
6003 have, as GCC expects it. */
6004 prepend_one_attribute_to
6007 (gnu_arg1 != NULL_TREE)
6008 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
6009 Present (Next (First (gnat_assoc)))
6010 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
6014 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6015 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6016 return the GCC tree to use for that expression. GNU_NAME is the suffix
6017 to use if a variable needs to be created and DEFINITION is true if this
6018 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6019 otherwise, we are just elaborating the expression for side-effects. If
6020 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6021 isn't needed for code generation. */
6024 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
6025 bool definition, bool need_value, bool need_debug)
6029 /* If we already elaborated this expression (e.g. it was involved
6030 in the definition of a private type), use the old value. */
6031 if (present_gnu_tree (gnat_expr))
6032 return get_gnu_tree (gnat_expr);
6034 /* If we don't need a value and this is static or a discriminant,
6035 we don't need to do anything. */
6037 && (Is_OK_Static_Expression (gnat_expr)
6038 || (Nkind (gnat_expr) == N_Identifier
6039 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
6042 /* If it's a static expression, we don't need a variable for debugging. */
6043 if (need_debug && Is_OK_Static_Expression (gnat_expr))
6046 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6047 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
6048 gnu_name, definition, need_debug);
6050 /* Save the expression in case we try to elaborate this entity again. Since
6051 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6052 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
6053 save_gnu_tree (gnat_expr, gnu_expr, true);
6055 return need_value ? gnu_expr : error_mark_node;
6058 /* Similar, but take a GNU expression and always return a result. */
6061 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6062 bool definition, bool need_debug)
6064 const bool expr_global_p = Is_Public (gnat_entity) || global_bindings_p ();
6065 bool expr_variable_p, use_variable;
6067 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
6068 reference will have been replaced with a COMPONENT_REF when the type
6069 is being elaborated. However, there are some cases involving child
6070 types where we will. So convert it to a COMPONENT_REF. We hope it
6071 will be at the highest level of the expression in these cases. */
6072 if (TREE_CODE (gnu_expr) == FIELD_DECL)
6073 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
6074 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
6075 gnu_expr, NULL_TREE);
6077 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6078 that an expression cannot contain both a discriminant and a variable. */
6079 if (CONTAINS_PLACEHOLDER_P (gnu_expr))
6082 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6083 a variable that is initialized to contain the expression when the package
6084 containing the definition is elaborated. If this entity is defined at top
6085 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6086 if this is necessary. */
6087 if (CONSTANT_CLASS_P (gnu_expr))
6088 expr_variable_p = false;
6091 /* Skip any conversions and simple arithmetics to see if the expression
6092 is based on a read-only variable.
6093 ??? This really should remain read-only, but we have to think about
6094 the typing of the tree here. */
6096 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
6098 if (handled_component_p (inner))
6100 HOST_WIDE_INT bitsize, bitpos;
6102 enum machine_mode mode;
6103 int unsignedp, volatilep;
6105 inner = get_inner_reference (inner, &bitsize, &bitpos, &offset,
6106 &mode, &unsignedp, &volatilep, false);
6107 /* If the offset is variable, err on the side of caution. */
6114 && TREE_CODE (inner) == VAR_DECL
6115 && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
6118 /* We only need to use the variable if we are in a global context since GCC
6119 can do the right thing in the local case. However, when not optimizing,
6120 use it for bounds of loop iteration scheme to avoid code duplication. */
6121 use_variable = expr_variable_p
6124 && Is_Itype (gnat_entity)
6125 && Nkind (Associated_Node_For_Itype (gnat_entity))
6126 == N_Loop_Parameter_Specification));
6128 /* Now create it, possibly only for debugging purposes. */
6129 if (use_variable || need_debug)
6132 = create_var_decl (create_concat_name (gnat_entity,
6133 IDENTIFIER_POINTER (gnu_name)),
6134 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
6135 !need_debug, Is_Public (gnat_entity),
6136 !definition, expr_global_p, NULL, gnat_entity);
6142 return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
6145 /* Similar, but take an alignment factor and make it explicit in the tree. */
6148 elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6149 bool definition, bool need_debug, unsigned int align)
6151 tree unit_align = size_int (align / BITS_PER_UNIT);
6153 size_binop (MULT_EXPR,
6154 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR,
6157 gnat_entity, gnu_name, definition,
6162 /* Create a record type that contains a SIZE bytes long field of TYPE with a
6163 starting bit position so that it is aligned to ALIGN bits, and leaving at
6164 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
6165 record is guaranteed to get. */
6168 make_aligning_type (tree type, unsigned int align, tree size,
6169 unsigned int base_align, int room)
6171 /* We will be crafting a record type with one field at a position set to be
6172 the next multiple of ALIGN past record'address + room bytes. We use a
6173 record placeholder to express record'address. */
6174 tree record_type = make_node (RECORD_TYPE);
6175 tree record = build0 (PLACEHOLDER_EXPR, record_type);
6178 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
6180 /* The diagram below summarizes the shape of what we manipulate:
6182 <--------- pos ---------->
6183 { +------------+-------------+-----------------+
6184 record =>{ |############| ... | field (type) |
6185 { +------------+-------------+-----------------+
6186 |<-- room -->|<- voffset ->|<---- size ----->|
6189 record_addr vblock_addr
6191 Every length is in sizetype bytes there, except "pos" which has to be
6192 set as a bit position in the GCC tree for the record. */
6193 tree room_st = size_int (room);
6194 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
6195 tree voffset_st, pos, field;
6197 tree name = TYPE_NAME (type);
6199 if (TREE_CODE (name) == TYPE_DECL)
6200 name = DECL_NAME (name);
6201 name = concat_name (name, "ALIGN");
6202 TYPE_NAME (record_type) = name;
6204 /* Compute VOFFSET and then POS. The next byte position multiple of some
6205 alignment after some address is obtained by "and"ing the alignment minus
6206 1 with the two's complement of the address. */
6207 voffset_st = size_binop (BIT_AND_EXPR,
6208 fold_build1 (NEGATE_EXPR, sizetype, vblock_addr_st),
6209 size_int ((align / BITS_PER_UNIT) - 1));
6211 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
6212 pos = size_binop (MULT_EXPR,
6213 convert (bitsizetype,
6214 size_binop (PLUS_EXPR, room_st, voffset_st)),
6217 /* Craft the GCC record representation. We exceptionally do everything
6218 manually here because 1) our generic circuitry is not quite ready to
6219 handle the complex position/size expressions we are setting up, 2) we
6220 have a strong simplifying factor at hand: we know the maximum possible
6221 value of voffset, and 3) we have to set/reset at least the sizes in
6222 accordance with this maximum value anyway, as we need them to convey
6223 what should be "alloc"ated for this type.
6225 Use -1 as the 'addressable' indication for the field to prevent the
6226 creation of a bitfield. We don't need one, it would have damaging
6227 consequences on the alignment computation, and create_field_decl would
6228 make one without this special argument, for instance because of the
6229 complex position expression. */
6230 field = create_field_decl (get_identifier ("F"), type, record_type, size,
6232 TYPE_FIELDS (record_type) = field;
6234 TYPE_ALIGN (record_type) = base_align;
6235 TYPE_USER_ALIGN (record_type) = 1;
6237 TYPE_SIZE (record_type)
6238 = size_binop (PLUS_EXPR,
6239 size_binop (MULT_EXPR, convert (bitsizetype, size),
6241 bitsize_int (align + room * BITS_PER_UNIT));
6242 TYPE_SIZE_UNIT (record_type)
6243 = size_binop (PLUS_EXPR, size,
6244 size_int (room + align / BITS_PER_UNIT));
6246 SET_TYPE_MODE (record_type, BLKmode);
6247 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
6249 /* Declare it now since it will never be declared otherwise. This is
6250 necessary to ensure that its subtrees are properly marked. */
6251 create_type_decl (name, record_type, NULL, true, false, Empty);
6256 /* Return the result of rounding T up to ALIGN. */
6258 static inline unsigned HOST_WIDE_INT
6259 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
6267 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
6268 as the field type of a packed record if IN_RECORD is true, or as the
6269 component type of a packed array if IN_RECORD is false. See if we can
6270 rewrite it either as a type that has a non-BLKmode, which we can pack
6271 tighter in the packed record case, or as a smaller type. If so, return
6272 the new type. If not, return the original type. */
6275 make_packable_type (tree type, bool in_record)
6277 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
6278 unsigned HOST_WIDE_INT new_size;
6279 tree new_type, old_field, field_list = NULL_TREE;
6281 /* No point in doing anything if the size is zero. */
6285 new_type = make_node (TREE_CODE (type));
6287 /* Copy the name and flags from the old type to that of the new.
6288 Note that we rely on the pointer equality created here for
6289 TYPE_NAME to look through conversions in various places. */
6290 TYPE_NAME (new_type) = TYPE_NAME (type);
6291 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
6292 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
6293 if (TREE_CODE (type) == RECORD_TYPE)
6294 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
6296 /* If we are in a record and have a small size, set the alignment to
6297 try for an integral mode. Otherwise set it to try for a smaller
6298 type with BLKmode. */
6299 if (in_record && size <= MAX_FIXED_MODE_SIZE)
6301 TYPE_ALIGN (new_type) = ceil_alignment (size);
6302 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
6306 unsigned HOST_WIDE_INT align;
6308 /* Do not try to shrink the size if the RM size is not constant. */
6309 if (TYPE_CONTAINS_TEMPLATE_P (type)
6310 || !host_integerp (TYPE_ADA_SIZE (type), 1))
6313 /* Round the RM size up to a unit boundary to get the minimal size
6314 for a BLKmode record. Give up if it's already the size. */
6315 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
6316 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
6317 if (new_size == size)
6320 align = new_size & -new_size;
6321 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
6324 TYPE_USER_ALIGN (new_type) = 1;
6326 /* Now copy the fields, keeping the position and size as we don't want
6327 to change the layout by propagating the packedness downwards. */
6328 for (old_field = TYPE_FIELDS (type); old_field;
6329 old_field = DECL_CHAIN (old_field))
6331 tree new_field_type = TREE_TYPE (old_field);
6332 tree new_field, new_size;
6334 if ((TREE_CODE (new_field_type) == RECORD_TYPE
6335 || TREE_CODE (new_field_type) == UNION_TYPE
6336 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
6337 && !TYPE_FAT_POINTER_P (new_field_type)
6338 && host_integerp (TYPE_SIZE (new_field_type), 1))
6339 new_field_type = make_packable_type (new_field_type, true);
6341 /* However, for the last field in a not already packed record type
6342 that is of an aggregate type, we need to use the RM size in the
6343 packable version of the record type, see finish_record_type. */
6344 if (!DECL_CHAIN (old_field)
6345 && !TYPE_PACKED (type)
6346 && (TREE_CODE (new_field_type) == RECORD_TYPE
6347 || TREE_CODE (new_field_type) == UNION_TYPE
6348 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
6349 && !TYPE_FAT_POINTER_P (new_field_type)
6350 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
6351 && TYPE_ADA_SIZE (new_field_type))
6352 new_size = TYPE_ADA_SIZE (new_field_type);
6354 new_size = DECL_SIZE (old_field);
6357 = create_field_decl (DECL_NAME (old_field), new_field_type, new_type,
6358 new_size, bit_position (old_field),
6360 !DECL_NONADDRESSABLE_P (old_field));
6362 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
6363 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
6364 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
6365 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
6367 DECL_CHAIN (new_field) = field_list;
6368 field_list = new_field;
6371 finish_record_type (new_type, nreverse (field_list), 2, false);
6372 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
6373 SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
6374 DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)));
6376 /* If this is a padding record, we never want to make the size smaller
6377 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
6378 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
6380 TYPE_SIZE (new_type) = TYPE_SIZE (type);
6381 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
6386 TYPE_SIZE (new_type) = bitsize_int (new_size);
6387 TYPE_SIZE_UNIT (new_type)
6388 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
6391 if (!TYPE_CONTAINS_TEMPLATE_P (type))
6392 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
6394 compute_record_mode (new_type);
6396 /* Try harder to get a packable type if necessary, for example
6397 in case the record itself contains a BLKmode field. */
6398 if (in_record && TYPE_MODE (new_type) == BLKmode)
6399 SET_TYPE_MODE (new_type,
6400 mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
6402 /* If neither the mode nor the size has shrunk, return the old type. */
6403 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
6409 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
6410 if needed. We have already verified that SIZE and TYPE are large enough.
6411 GNAT_ENTITY is used to name the resulting record and to issue a warning.
6412 IS_COMPONENT_TYPE is true if this is being done for the component type
6413 of an array. IS_USER_TYPE is true if we must complete the original type.
6414 DEFINITION is true if this type is being defined. SAME_RM_SIZE is true
6415 if the RM size of the resulting type is to be set to SIZE too; otherwise,
6416 it's set to the RM size of the original type. */
6419 maybe_pad_type (tree type, tree size, unsigned int align,
6420 Entity_Id gnat_entity, bool is_component_type,
6421 bool is_user_type, bool definition, bool same_rm_size)
6423 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
6424 tree orig_size = TYPE_SIZE (type);
6427 /* If TYPE is a padded type, see if it agrees with any size and alignment
6428 we were given. If so, return the original type. Otherwise, strip
6429 off the padding, since we will either be returning the inner type
6430 or repadding it. If no size or alignment is specified, use that of
6431 the original padded type. */
6432 if (TYPE_IS_PADDING_P (type))
6435 || operand_equal_p (round_up (size,
6436 MAX (align, TYPE_ALIGN (type))),
6437 round_up (TYPE_SIZE (type),
6438 MAX (align, TYPE_ALIGN (type))),
6440 && (align == 0 || align == TYPE_ALIGN (type)))
6444 size = TYPE_SIZE (type);
6446 align = TYPE_ALIGN (type);
6448 type = TREE_TYPE (TYPE_FIELDS (type));
6449 orig_size = TYPE_SIZE (type);
6452 /* If the size is either not being changed or is being made smaller (which
6453 is not done here and is only valid for bitfields anyway), show the size
6454 isn't changing. Likewise, clear the alignment if it isn't being
6455 changed. Then return if we aren't doing anything. */
6457 && (operand_equal_p (size, orig_size, 0)
6458 || (TREE_CODE (orig_size) == INTEGER_CST
6459 && tree_int_cst_lt (size, orig_size))))
6462 if (align == TYPE_ALIGN (type))
6465 if (align == 0 && !size)
6468 /* If requested, complete the original type and give it a name. */
6470 create_type_decl (get_entity_name (gnat_entity), type,
6471 NULL, !Comes_From_Source (gnat_entity),
6473 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6474 && DECL_IGNORED_P (TYPE_NAME (type))),
6477 /* We used to modify the record in place in some cases, but that could
6478 generate incorrect debugging information. So make a new record
6480 record = make_node (RECORD_TYPE);
6481 TYPE_PADDING_P (record) = 1;
6483 if (Present (gnat_entity))
6484 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
6486 TYPE_VOLATILE (record)
6487 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
6489 TYPE_ALIGN (record) = align;
6490 TYPE_SIZE (record) = size ? size : orig_size;
6491 TYPE_SIZE_UNIT (record)
6492 = convert (sizetype,
6493 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
6494 bitsize_unit_node));
6496 /* If we are changing the alignment and the input type is a record with
6497 BLKmode and a small constant size, try to make a form that has an
6498 integral mode. This might allow the padding record to also have an
6499 integral mode, which will be much more efficient. There is no point
6500 in doing so if a size is specified unless it is also a small constant
6501 size and it is incorrect to do so if we cannot guarantee that the mode
6502 will be naturally aligned since the field must always be addressable.
6504 ??? This might not always be a win when done for a stand-alone object:
6505 since the nominal and the effective type of the object will now have
6506 different modes, a VIEW_CONVERT_EXPR will be required for converting
6507 between them and it might be hard to overcome afterwards, including
6508 at the RTL level when the stand-alone object is accessed as a whole. */
6510 && TREE_CODE (type) == RECORD_TYPE
6511 && TYPE_MODE (type) == BLKmode
6512 && TREE_CODE (orig_size) == INTEGER_CST
6513 && !TREE_OVERFLOW (orig_size)
6514 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
6516 || (TREE_CODE (size) == INTEGER_CST
6517 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
6519 tree packable_type = make_packable_type (type, true);
6520 if (TYPE_MODE (packable_type) != BLKmode
6521 && align >= TYPE_ALIGN (packable_type))
6522 type = packable_type;
6525 /* Now create the field with the original size. */
6526 field = create_field_decl (get_identifier ("F"), type, record, orig_size,
6527 bitsize_zero_node, 0, 1);
6528 DECL_INTERNAL_P (field) = 1;
6530 /* Do not emit debug info until after the auxiliary record is built. */
6531 finish_record_type (record, field, 1, false);
6533 /* Set the same size for its RM size if requested; otherwise reuse
6534 the RM size of the original type. */
6535 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
6537 /* Unless debugging information isn't being written for the input type,
6538 write a record that shows what we are a subtype of and also make a
6539 variable that indicates our size, if still variable. */
6540 if (TREE_CODE (orig_size) != INTEGER_CST
6541 && TYPE_NAME (record)
6543 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6544 && DECL_IGNORED_P (TYPE_NAME (type))))
6546 tree marker = make_node (RECORD_TYPE);
6547 tree name = TYPE_NAME (record);
6548 tree orig_name = TYPE_NAME (type);
6550 if (TREE_CODE (name) == TYPE_DECL)
6551 name = DECL_NAME (name);
6553 if (TREE_CODE (orig_name) == TYPE_DECL)
6554 orig_name = DECL_NAME (orig_name);
6556 TYPE_NAME (marker) = concat_name (name, "XVS");
6557 finish_record_type (marker,
6558 create_field_decl (orig_name,
6559 build_reference_type (type),
6560 marker, NULL_TREE, NULL_TREE,
6564 add_parallel_type (TYPE_STUB_DECL (record), marker);
6566 if (definition && size && TREE_CODE (size) != INTEGER_CST)
6567 TYPE_SIZE_UNIT (marker)
6568 = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
6569 TYPE_SIZE_UNIT (record), false, false, false,
6570 false, NULL, gnat_entity);
6573 rest_of_record_type_compilation (record);
6575 /* If the size was widened explicitly, maybe give a warning. Take the
6576 original size as the maximum size of the input if there was an
6577 unconstrained record involved and round it up to the specified alignment,
6578 if one was specified. */
6579 if (CONTAINS_PLACEHOLDER_P (orig_size))
6580 orig_size = max_size (orig_size, true);
6583 orig_size = round_up (orig_size, align);
6585 if (Present (gnat_entity)
6587 && TREE_CODE (size) != MAX_EXPR
6588 && TREE_CODE (size) != COND_EXPR
6589 && !operand_equal_p (size, orig_size, 0)
6590 && !(TREE_CODE (size) == INTEGER_CST
6591 && TREE_CODE (orig_size) == INTEGER_CST
6592 && (TREE_OVERFLOW (size)
6593 || TREE_OVERFLOW (orig_size)
6594 || tree_int_cst_lt (size, orig_size))))
6596 Node_Id gnat_error_node = Empty;
6598 if (Is_Packed_Array_Type (gnat_entity))
6599 gnat_entity = Original_Array_Type (gnat_entity);
6601 if ((Ekind (gnat_entity) == E_Component
6602 || Ekind (gnat_entity) == E_Discriminant)
6603 && Present (Component_Clause (gnat_entity)))
6604 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
6605 else if (Present (Size_Clause (gnat_entity)))
6606 gnat_error_node = Expression (Size_Clause (gnat_entity));
6608 /* Generate message only for entities that come from source, since
6609 if we have an entity created by expansion, the message will be
6610 generated for some other corresponding source entity. */
6611 if (Comes_From_Source (gnat_entity))
6613 if (Present (gnat_error_node))
6614 post_error_ne_tree ("{^ }bits of & unused?",
6615 gnat_error_node, gnat_entity,
6616 size_diffop (size, orig_size));
6617 else if (is_component_type)
6618 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6619 gnat_entity, gnat_entity,
6620 size_diffop (size, orig_size));
6627 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6628 the value passed against the list of choices. */
6631 choices_to_gnu (tree operand, Node_Id choices)
6635 tree result = boolean_false_node;
6636 tree this_test, low = 0, high = 0, single = 0;
6638 for (choice = First (choices); Present (choice); choice = Next (choice))
6640 switch (Nkind (choice))
6643 low = gnat_to_gnu (Low_Bound (choice));
6644 high = gnat_to_gnu (High_Bound (choice));
6647 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6648 build_binary_op (GE_EXPR, boolean_type_node,
6650 build_binary_op (LE_EXPR, boolean_type_node,
6655 case N_Subtype_Indication:
6656 gnat_temp = Range_Expression (Constraint (choice));
6657 low = gnat_to_gnu (Low_Bound (gnat_temp));
6658 high = gnat_to_gnu (High_Bound (gnat_temp));
6661 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6662 build_binary_op (GE_EXPR, boolean_type_node,
6664 build_binary_op (LE_EXPR, boolean_type_node,
6669 case N_Expanded_Name:
6670 /* This represents either a subtype range, an enumeration
6671 literal, or a constant Ekind says which. If an enumeration
6672 literal or constant, fall through to the next case. */
6673 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6674 && Ekind (Entity (choice)) != E_Constant)
6676 tree type = gnat_to_gnu_type (Entity (choice));
6678 low = TYPE_MIN_VALUE (type);
6679 high = TYPE_MAX_VALUE (type);
6682 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6683 build_binary_op (GE_EXPR, boolean_type_node,
6685 build_binary_op (LE_EXPR, boolean_type_node,
6690 /* ... fall through ... */
6692 case N_Character_Literal:
6693 case N_Integer_Literal:
6694 single = gnat_to_gnu (choice);
6695 this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
6699 case N_Others_Choice:
6700 this_test = boolean_true_node;
6707 result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
6714 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6715 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6718 adjust_packed (tree field_type, tree record_type, int packed)
6720 /* If the field contains an item of variable size, we cannot pack it
6721 because we cannot create temporaries of non-fixed size in case
6722 we need to take the address of the field. See addressable_p and
6723 the notes on the addressability issues for further details. */
6724 if (is_variable_size (field_type))
6727 /* If the alignment of the record is specified and the field type
6728 is over-aligned, request Storage_Unit alignment for the field. */
6731 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6740 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6741 placed in GNU_RECORD_TYPE.
6743 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6744 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6745 record has a specified alignment.
6747 DEFINITION is true if this field is for a record being defined.
6749 DEBUG_INFO_P is true if we need to write debug information for types
6750 that we may create in the process. */
6753 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6754 bool definition, bool debug_info_p)
6756 const Entity_Id gnat_field_type = Etype (gnat_field);
6757 tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
6758 tree gnu_field_id = get_entity_name (gnat_field);
6759 tree gnu_field, gnu_size, gnu_pos;
6761 = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
6762 bool needs_strict_alignment
6764 || Is_Aliased (gnat_field)
6765 || Strict_Alignment (gnat_field_type));
6767 /* If this field requires strict alignment, we cannot pack it because
6768 it would very likely be under-aligned in the record. */
6769 if (needs_strict_alignment)
6772 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6774 /* If a size is specified, use it. Otherwise, if the record type is packed,
6775 use the official RM size. See "Handling of Type'Size Values" in Einfo
6776 for further details. */
6777 if (Known_Esize (gnat_field))
6778 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6779 gnat_field, FIELD_DECL, false, true);
6780 else if (packed == 1)
6781 gnu_size = validate_size (RM_Size (gnat_field_type), gnu_field_type,
6782 gnat_field, FIELD_DECL, false, true);
6784 gnu_size = NULL_TREE;
6786 /* If we have a specified size that is smaller than that of the field's type,
6787 or a position is specified, and the field's type is a record that doesn't
6788 require strict alignment, see if we can get either an integral mode form
6789 of the type or a smaller form. If we can, show a size was specified for
6790 the field if there wasn't one already, so we know to make this a bitfield
6791 and avoid making things wider.
6793 Changing to an integral mode form is useful when the record is packed as
6794 we can then place the field at a non-byte-aligned position and so achieve
6795 tighter packing. This is in addition required if the field shares a byte
6796 with another field and the front-end lets the back-end handle the access
6797 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6799 Changing to a smaller form is required if the specified size is smaller
6800 than that of the field's type and the type contains sub-fields that are
6801 padded, in order to avoid generating accesses to these sub-fields that
6802 are wider than the field.
6804 We avoid the transformation if it is not required or potentially useful,
6805 as it might entail an increase of the field's alignment and have ripple
6806 effects on the outer record type. A typical case is a field known to be
6807 byte-aligned and not to share a byte with another field. */
6808 if (!needs_strict_alignment
6809 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6810 && !TYPE_FAT_POINTER_P (gnu_field_type)
6811 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6814 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6815 || (Present (Component_Clause (gnat_field))
6816 && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6817 % BITS_PER_UNIT == 0
6818 && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6820 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6821 if (gnu_packable_type != gnu_field_type)
6823 gnu_field_type = gnu_packable_type;
6825 gnu_size = rm_size (gnu_field_type);
6829 /* If we are packing the record and the field is BLKmode, round the
6830 size up to a byte boundary. */
6831 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6832 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6834 if (Present (Component_Clause (gnat_field)))
6836 Entity_Id gnat_parent
6837 = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6839 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6840 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6841 gnat_field, FIELD_DECL, false, true);
6843 /* Ensure the position does not overlap with the parent subtype, if there
6844 is one. This test is omitted if the parent of the tagged type has a
6845 full rep clause since, in this case, component clauses are allowed to
6846 overlay the space allocated for the parent type and the front-end has
6847 checked that there are no overlapping components. */
6848 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6850 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6852 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6853 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6856 ("offset of& must be beyond parent{, minimum allowed is ^}",
6857 First_Bit (Component_Clause (gnat_field)), gnat_field,
6858 TYPE_SIZE_UNIT (gnu_parent));
6862 /* If this field needs strict alignment, ensure the record is
6863 sufficiently aligned and that that position and size are
6864 consistent with the alignment. */
6865 if (needs_strict_alignment)
6867 TYPE_ALIGN (gnu_record_type)
6868 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6871 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6873 if (Is_Atomic (gnat_field) || Is_Atomic (gnat_field_type))
6875 ("atomic field& must be natural size of type{ (^)}",
6876 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6877 TYPE_SIZE (gnu_field_type));
6879 else if (Is_Aliased (gnat_field))
6881 ("size of aliased field& must be ^ bits",
6882 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6883 TYPE_SIZE (gnu_field_type));
6885 else if (Strict_Alignment (gnat_field_type))
6887 ("size of & with aliased or tagged components not ^ bits",
6888 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6889 TYPE_SIZE (gnu_field_type));
6891 gnu_size = NULL_TREE;
6894 if (!integer_zerop (size_binop
6895 (TRUNC_MOD_EXPR, gnu_pos,
6896 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6900 ("position of volatile field& must be multiple of ^ bits",
6901 First_Bit (Component_Clause (gnat_field)), gnat_field,
6902 TYPE_ALIGN (gnu_field_type));
6904 else if (Is_Aliased (gnat_field))
6906 ("position of aliased field& must be multiple of ^ bits",
6907 First_Bit (Component_Clause (gnat_field)), gnat_field,
6908 TYPE_ALIGN (gnu_field_type));
6910 else if (Strict_Alignment (gnat_field_type))
6912 ("position of & with aliased or tagged components not multiple of ^ bits",
6913 First_Bit (Component_Clause (gnat_field)), gnat_field,
6914 TYPE_ALIGN (gnu_field_type));
6919 gnu_pos = NULL_TREE;
6923 if (Is_Atomic (gnat_field))
6924 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6927 /* If the record has rep clauses and this is the tag field, make a rep
6928 clause for it as well. */
6929 else if (Has_Specified_Layout (Scope (gnat_field))
6930 && Chars (gnat_field) == Name_uTag)
6932 gnu_pos = bitsize_zero_node;
6933 gnu_size = TYPE_SIZE (gnu_field_type);
6937 gnu_pos = NULL_TREE;
6939 /* We need to make the size the maximum for the type if it is
6940 self-referential and an unconstrained type. In that case, we can't
6941 pack the field since we can't make a copy to align it. */
6942 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6944 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6945 && !Is_Constrained (Underlying_Type (gnat_field_type)))
6947 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6951 /* If a size is specified, adjust the field's type to it. */
6954 tree orig_field_type;
6956 /* If the field's type is justified modular, we would need to remove
6957 the wrapper to (better) meet the layout requirements. However we
6958 can do so only if the field is not aliased to preserve the unique
6959 layout and if the prescribed size is not greater than that of the
6960 packed array to preserve the justification. */
6961 if (!needs_strict_alignment
6962 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6963 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6964 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6966 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6969 = make_type_from_size (gnu_field_type, gnu_size,
6970 Has_Biased_Representation (gnat_field));
6972 orig_field_type = gnu_field_type;
6973 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6974 false, false, definition, true);
6976 /* If a padding record was made, declare it now since it will never be
6977 declared otherwise. This is necessary to ensure that its subtrees
6978 are properly marked. */
6979 if (gnu_field_type != orig_field_type
6980 && !DECL_P (TYPE_NAME (gnu_field_type)))
6981 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL,
6982 true, debug_info_p, gnat_field);
6985 /* Otherwise (or if there was an error), don't specify a position. */
6987 gnu_pos = NULL_TREE;
6989 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6990 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6992 /* Now create the decl for the field. */
6994 = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6995 gnu_size, gnu_pos, packed, Is_Aliased (gnat_field));
6996 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6997 TREE_THIS_VOLATILE (gnu_field) = TREE_SIDE_EFFECTS (gnu_field) = is_volatile;
6999 if (Ekind (gnat_field) == E_Discriminant)
7000 DECL_DISCRIMINANT_NUMBER (gnu_field)
7001 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
7006 /* Return true if TYPE is a type with variable size, a padding type with a
7007 field of variable size or is a record that has a field such a field. */
7010 is_variable_size (tree type)
7014 if (!TREE_CONSTANT (TYPE_SIZE (type)))
7017 if (TYPE_IS_PADDING_P (type)
7018 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
7021 if (TREE_CODE (type) != RECORD_TYPE
7022 && TREE_CODE (type) != UNION_TYPE
7023 && TREE_CODE (type) != QUAL_UNION_TYPE)
7026 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
7027 if (is_variable_size (TREE_TYPE (field)))
7033 /* qsort comparer for the bit positions of two record components. */
7036 compare_field_bitpos (const PTR rt1, const PTR rt2)
7038 const_tree const field1 = * (const_tree const *) rt1;
7039 const_tree const field2 = * (const_tree const *) rt2;
7041 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
7043 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
7046 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
7047 the result as the field list of GNU_RECORD_TYPE and finish it up. When
7048 called from gnat_to_gnu_entity during the processing of a record type
7049 definition, the GCC node for the parent, if any, will be the single field
7050 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
7051 GNU_FIELD_LIST. The other calls to this function are recursive calls for
7052 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
7054 PACKED is 1 if this is for a packed record, -1 if this is for a record
7055 with Component_Alignment of Storage_Unit, -2 if this is for a record
7056 with a specified alignment.
7058 DEFINITION is true if we are defining this record type.
7060 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
7061 out the record. This means the alignment only serves to force fields to
7062 be bitfields, but not to require the record to be that aligned. This is
7065 ALL_REP is true if a rep clause is present for all the fields.
7067 UNCHECKED_UNION is true if we are building this type for a record with a
7068 Pragma Unchecked_Union.
7070 DEBUG_INFO is true if we need to write debug information about the type.
7072 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
7073 mean that its contents may be unused as well, only the container itself.
7075 REORDER is true if we are permitted to reorder components of this type.
7077 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
7078 with a rep clause is to be added; in this case, that is all that should
7079 be done with such fields. */
7082 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
7083 tree gnu_field_list, int packed, bool definition,
7084 bool cancel_alignment, bool all_rep,
7085 bool unchecked_union, bool debug_info,
7086 bool maybe_unused, bool reorder,
7087 tree *p_gnu_rep_list)
7089 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
7090 bool layout_with_rep = false;
7091 Node_Id component_decl, variant_part;
7092 tree gnu_field, gnu_next, gnu_last;
7093 tree gnu_variant_part = NULL_TREE;
7094 tree gnu_rep_list = NULL_TREE;
7095 tree gnu_var_list = NULL_TREE;
7096 tree gnu_self_list = NULL_TREE;
7098 /* For each component referenced in a component declaration create a GCC
7099 field and add it to the list, skipping pragmas in the GNAT list. */
7100 gnu_last = tree_last (gnu_field_list);
7101 if (Present (Component_Items (gnat_component_list)))
7103 = First_Non_Pragma (Component_Items (gnat_component_list));
7104 Present (component_decl);
7105 component_decl = Next_Non_Pragma (component_decl))
7107 Entity_Id gnat_field = Defining_Entity (component_decl);
7108 Name_Id gnat_name = Chars (gnat_field);
7110 /* If present, the _Parent field must have been created as the single
7111 field of the record type. Put it before any other fields. */
7112 if (gnat_name == Name_uParent)
7114 gnu_field = TYPE_FIELDS (gnu_record_type);
7115 gnu_field_list = chainon (gnu_field_list, gnu_field);
7119 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
7120 definition, debug_info);
7122 /* If this is the _Tag field, put it before any other fields. */
7123 if (gnat_name == Name_uTag)
7124 gnu_field_list = chainon (gnu_field_list, gnu_field);
7126 /* If this is the _Controller field, put it before the other
7127 fields except for the _Tag or _Parent field. */
7128 else if (gnat_name == Name_uController && gnu_last)
7130 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
7131 DECL_CHAIN (gnu_last) = gnu_field;
7134 /* If this is a regular field, put it after the other fields. */
7137 DECL_CHAIN (gnu_field) = gnu_field_list;
7138 gnu_field_list = gnu_field;
7140 gnu_last = gnu_field;
7144 save_gnu_tree (gnat_field, gnu_field, false);
7147 /* At the end of the component list there may be a variant part. */
7148 variant_part = Variant_Part (gnat_component_list);
7150 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7151 mutually exclusive and should go in the same memory. To do this we need
7152 to treat each variant as a record whose elements are created from the
7153 component list for the variant. So here we create the records from the
7154 lists for the variants and put them all into the QUAL_UNION_TYPE.
7155 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7156 use GNU_RECORD_TYPE if there are no fields so far. */
7157 if (Present (variant_part))
7159 Node_Id gnat_discr = Name (variant_part), variant;
7160 tree gnu_discr = gnat_to_gnu (gnat_discr);
7161 tree gnu_name = TYPE_NAME (gnu_record_type);
7163 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
7165 tree gnu_union_type, gnu_union_name;
7166 tree gnu_variant_list = NULL_TREE;
7168 if (TREE_CODE (gnu_name) == TYPE_DECL)
7169 gnu_name = DECL_NAME (gnu_name);
7172 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
7174 /* Reuse an enclosing union if all fields are in the variant part
7175 and there is no representation clause on the record, to match
7176 the layout of C unions. There is an associated check below. */
7178 && TREE_CODE (gnu_record_type) == UNION_TYPE
7179 && !TYPE_PACKED (gnu_record_type))
7180 gnu_union_type = gnu_record_type;
7184 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
7186 TYPE_NAME (gnu_union_type) = gnu_union_name;
7187 TYPE_ALIGN (gnu_union_type) = 0;
7188 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
7191 for (variant = First_Non_Pragma (Variants (variant_part));
7193 variant = Next_Non_Pragma (variant))
7195 tree gnu_variant_type = make_node (RECORD_TYPE);
7196 tree gnu_inner_name;
7199 Get_Variant_Encoding (variant);
7200 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
7201 TYPE_NAME (gnu_variant_type)
7202 = concat_name (gnu_union_name,
7203 IDENTIFIER_POINTER (gnu_inner_name));
7205 /* Set the alignment of the inner type in case we need to make
7206 inner objects into bitfields, but then clear it out so the
7207 record actually gets only the alignment required. */
7208 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
7209 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
7211 /* Similarly, if the outer record has a size specified and all
7212 fields have record rep clauses, we can propagate the size
7213 into the variant part. */
7214 if (all_rep_and_size)
7216 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
7217 TYPE_SIZE_UNIT (gnu_variant_type)
7218 = TYPE_SIZE_UNIT (gnu_record_type);
7221 /* Add the fields into the record type for the variant. Note that
7222 we aren't sure to really use it at this point, see below. */
7223 components_to_record (gnu_variant_type, Component_List (variant),
7224 NULL_TREE, packed, definition,
7225 !all_rep_and_size, all_rep,
7226 unchecked_union, debug_info,
7227 true, reorder, &gnu_rep_list);
7229 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
7231 Set_Present_Expr (variant, annotate_value (gnu_qual));
7233 /* If this is an Unchecked_Union and we have exactly one field,
7234 use this field directly to match the layout of C unions. */
7236 && TYPE_FIELDS (gnu_variant_type)
7237 && !DECL_CHAIN (TYPE_FIELDS (gnu_variant_type)))
7238 gnu_field = TYPE_FIELDS (gnu_variant_type);
7241 /* Deal with packedness like in gnat_to_gnu_field. */
7243 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
7245 /* Finalize the record type now. We used to throw away
7246 empty records but we no longer do that because we need
7247 them to generate complete debug info for the variant;
7248 otherwise, the union type definition will be lacking
7249 the fields associated with these empty variants. */
7250 rest_of_record_type_compilation (gnu_variant_type);
7251 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
7252 NULL, true, debug_info, gnat_component_list);
7255 = create_field_decl (gnu_inner_name, gnu_variant_type,
7258 ? TYPE_SIZE (gnu_variant_type) : 0,
7260 ? bitsize_zero_node : 0,
7263 DECL_INTERNAL_P (gnu_field) = 1;
7265 if (!unchecked_union)
7266 DECL_QUALIFIER (gnu_field) = gnu_qual;
7269 DECL_CHAIN (gnu_field) = gnu_variant_list;
7270 gnu_variant_list = gnu_field;
7273 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7274 if (gnu_variant_list)
7276 int union_field_packed;
7278 if (all_rep_and_size)
7280 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
7281 TYPE_SIZE_UNIT (gnu_union_type)
7282 = TYPE_SIZE_UNIT (gnu_record_type);
7285 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
7286 all_rep_and_size ? 1 : 0, debug_info);
7288 /* If GNU_UNION_TYPE is our record type, it means we must have an
7289 Unchecked_Union with no fields. Verify that and, if so, just
7291 if (gnu_union_type == gnu_record_type)
7293 gcc_assert (unchecked_union
7299 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
7300 NULL, true, debug_info, gnat_component_list);
7302 /* Deal with packedness like in gnat_to_gnu_field. */
7304 = adjust_packed (gnu_union_type, gnu_record_type, packed);
7307 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
7308 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
7309 all_rep ? bitsize_zero_node : 0,
7310 union_field_packed, 0);
7312 DECL_INTERNAL_P (gnu_variant_part) = 1;
7313 DECL_CHAIN (gnu_variant_part) = gnu_field_list;
7314 gnu_field_list = gnu_variant_part;
7318 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
7319 permitted to reorder components, self-referential sizes or variable sizes.
7320 If they do, pull them out and put them onto the appropriate list. We have
7321 to do this in a separate pass since we want to handle the discriminants
7322 but can't play with them until we've used them in debugging data above.
7324 ??? If we reorder them, debugging information will be wrong but there is
7325 nothing that can be done about this at the moment. */
7326 gnu_last = NULL_TREE;
7328 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7331 DECL_CHAIN (gnu_last) = gnu_next; \
7333 gnu_field_list = gnu_next; \
7335 DECL_CHAIN (gnu_field) = (LIST); \
7336 (LIST) = gnu_field; \
7339 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
7341 gnu_next = DECL_CHAIN (gnu_field);
7343 if (DECL_FIELD_OFFSET (gnu_field))
7345 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
7351 /* Pull out the variant part and put it onto GNU_SELF_LIST. */
7352 if (gnu_field == gnu_variant_part)
7354 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7358 /* Skip internal fields and fields with fixed size. */
7359 if (!DECL_INTERNAL_P (gnu_field)
7360 && !(DECL_SIZE (gnu_field)
7361 && TREE_CODE (DECL_SIZE (gnu_field)) == INTEGER_CST))
7363 tree type_size = TYPE_SIZE (TREE_TYPE (gnu_field));
7365 if (CONTAINS_PLACEHOLDER_P (type_size))
7367 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7371 if (TREE_CODE (type_size) != INTEGER_CST)
7373 MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
7379 gnu_last = gnu_field;
7382 #undef MOVE_FROM_FIELD_LIST_TO
7384 /* If permitted, we reorder the components as follows:
7386 1) all fixed length fields,
7387 2) all fields whose length doesn't depend on discriminants,
7388 3) all fields whose length depends on discriminants,
7389 4) the variant part,
7391 within the record and within each variant recursively. */
7394 = chainon (nreverse (gnu_self_list),
7395 chainon (nreverse (gnu_var_list), gnu_field_list));
7397 /* If we have any fields in our rep'ed field list and it is not the case that
7398 all the fields in the record have rep clauses and P_REP_LIST is nonzero,
7399 set it and ignore these fields. */
7400 if (gnu_rep_list && p_gnu_rep_list && !all_rep)
7401 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
7403 /* Otherwise, sort the fields by bit position and put them into their own
7404 record, before the others, if we also have fields without rep clauses. */
7405 else if (gnu_rep_list)
7408 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
7409 int i, len = list_length (gnu_rep_list);
7410 tree *gnu_arr = XALLOCAVEC (tree, len);
7412 for (gnu_field = gnu_rep_list, i = 0;
7414 gnu_field = DECL_CHAIN (gnu_field), i++)
7415 gnu_arr[i] = gnu_field;
7417 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7419 /* Put the fields in the list in order of increasing position, which
7420 means we start from the end. */
7421 gnu_rep_list = NULL_TREE;
7422 for (i = len - 1; i >= 0; i--)
7424 DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
7425 gnu_rep_list = gnu_arr[i];
7426 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7431 finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info);
7433 = create_field_decl (get_identifier ("REP"), gnu_rep_type,
7434 gnu_record_type, NULL_TREE, NULL_TREE, 0, 1);
7435 DECL_INTERNAL_P (gnu_field) = 1;
7436 gnu_field_list = chainon (gnu_field_list, gnu_field);
7440 layout_with_rep = true;
7441 gnu_field_list = nreverse (gnu_rep_list);
7445 if (cancel_alignment)
7446 TYPE_ALIGN (gnu_record_type) = 0;
7448 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
7449 layout_with_rep ? 1 : 0, debug_info && !maybe_unused);
7452 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7453 placed into an Esize, Component_Bit_Offset, or Component_Size value
7454 in the GNAT tree. */
7457 annotate_value (tree gnu_size)
7460 Node_Ref_Or_Val ops[3], ret;
7461 struct tree_int_map **h = NULL;
7464 /* See if we've already saved the value for this node. */
7465 if (EXPR_P (gnu_size))
7467 struct tree_int_map in;
7468 if (!annotate_value_cache)
7469 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
7470 tree_int_map_eq, 0);
7471 in.base.from = gnu_size;
7472 h = (struct tree_int_map **)
7473 htab_find_slot (annotate_value_cache, &in, INSERT);
7476 return (Node_Ref_Or_Val) (*h)->to;
7479 /* If we do not return inside this switch, TCODE will be set to the
7480 code to use for a Create_Node operand and LEN (set above) will be
7481 the number of recursive calls for us to make. */
7483 switch (TREE_CODE (gnu_size))
7486 if (TREE_OVERFLOW (gnu_size))
7489 /* This may come from a conversion from some smaller type, so ensure
7490 this is in bitsizetype. */
7491 gnu_size = convert (bitsizetype, gnu_size);
7493 /* For a negative value, build NEGATE_EXPR of the opposite. Such values
7494 appear in expressions containing aligning patterns. Note that, since
7495 sizetype is sign-extended but nonetheless unsigned, we don't directly
7496 use tree_int_cst_sgn. */
7497 if (TREE_INT_CST_HIGH (gnu_size) < 0)
7499 tree op_size = fold_build1 (NEGATE_EXPR, bitsizetype, gnu_size);
7500 return annotate_value (build1 (NEGATE_EXPR, bitsizetype, op_size));
7503 return UI_From_gnu (gnu_size);
7506 /* The only case we handle here is a simple discriminant reference. */
7507 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
7508 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
7509 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7510 return Create_Node (Discrim_Val,
7511 annotate_value (DECL_DISCRIMINANT_NUMBER
7512 (TREE_OPERAND (gnu_size, 1))),
7517 CASE_CONVERT: case NON_LVALUE_EXPR:
7518 return annotate_value (TREE_OPERAND (gnu_size, 0));
7520 /* Now just list the operations we handle. */
7521 case COND_EXPR: tcode = Cond_Expr; break;
7522 case PLUS_EXPR: tcode = Plus_Expr; break;
7523 case MINUS_EXPR: tcode = Minus_Expr; break;
7524 case MULT_EXPR: tcode = Mult_Expr; break;
7525 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
7526 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
7527 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
7528 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
7529 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
7530 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
7531 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
7532 case NEGATE_EXPR: tcode = Negate_Expr; break;
7533 case MIN_EXPR: tcode = Min_Expr; break;
7534 case MAX_EXPR: tcode = Max_Expr; break;
7535 case ABS_EXPR: tcode = Abs_Expr; break;
7536 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
7537 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
7538 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
7539 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
7540 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
7541 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
7542 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
7543 case LT_EXPR: tcode = Lt_Expr; break;
7544 case LE_EXPR: tcode = Le_Expr; break;
7545 case GT_EXPR: tcode = Gt_Expr; break;
7546 case GE_EXPR: tcode = Ge_Expr; break;
7547 case EQ_EXPR: tcode = Eq_Expr; break;
7548 case NE_EXPR: tcode = Ne_Expr; break;
7552 tree t = maybe_inline_call_in_expr (gnu_size);
7554 return annotate_value (t);
7557 /* Fall through... */
7563 /* Now get each of the operands that's relevant for this code. If any
7564 cannot be expressed as a repinfo node, say we can't. */
7565 for (i = 0; i < 3; i++)
7568 for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
7570 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7571 if (ops[i] == No_Uint)
7575 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7577 /* Save the result in the cache. */
7580 *h = ggc_alloc_tree_int_map ();
7581 (*h)->base.from = gnu_size;
7588 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7589 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7590 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7591 BY_REF is true if the object is used by reference and BY_DOUBLE_REF is
7592 true if the object is used by double reference. */
7595 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref,
7601 gnu_type = TREE_TYPE (gnu_type);
7603 if (TYPE_IS_FAT_POINTER_P (gnu_type))
7604 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7606 gnu_type = TREE_TYPE (gnu_type);
7609 if (Unknown_Esize (gnat_entity))
7611 if (TREE_CODE (gnu_type) == RECORD_TYPE
7612 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7613 size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
7615 size = TYPE_SIZE (gnu_type);
7618 Set_Esize (gnat_entity, annotate_value (size));
7621 if (Unknown_Alignment (gnat_entity))
7622 Set_Alignment (gnat_entity,
7623 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7626 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7627 Return NULL_TREE if there is no such element in the list. */
7630 purpose_member_field (const_tree elem, tree list)
7634 tree field = TREE_PURPOSE (list);
7635 if (SAME_FIELD_P (field, elem))
7637 list = TREE_CHAIN (list);
7642 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7643 set Component_Bit_Offset and Esize of the components to the position and
7644 size used by Gigi. */
7647 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7649 Entity_Id gnat_field;
7652 /* We operate by first making a list of all fields and their position (we
7653 can get the size easily) and then update all the sizes in the tree. */
7655 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7656 BIGGEST_ALIGNMENT, NULL_TREE);
7658 for (gnat_field = First_Entity (gnat_entity);
7659 Present (gnat_field);
7660 gnat_field = Next_Entity (gnat_field))
7661 if (Ekind (gnat_field) == E_Component
7662 || (Ekind (gnat_field) == E_Discriminant
7663 && !Is_Unchecked_Union (Scope (gnat_field))))
7665 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
7671 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
7673 /* In this mode the tag and parent components are not
7674 generated, so we add the appropriate offset to each
7675 component. For a component appearing in the current
7676 extension, the offset is the size of the parent. */
7677 if (Is_Derived_Type (gnat_entity)
7678 && Original_Record_Component (gnat_field) == gnat_field)
7680 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7683 parent_offset = bitsize_int (POINTER_SIZE);
7686 parent_offset = bitsize_zero_node;
7688 Set_Component_Bit_Offset
7691 (size_binop (PLUS_EXPR,
7692 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7693 TREE_VEC_ELT (TREE_VALUE (t), 2)),
7696 Set_Esize (gnat_field,
7697 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7699 else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7701 /* If there is no entry, this is an inherited component whose
7702 position is the same as in the parent type. */
7703 Set_Component_Bit_Offset
7705 Component_Bit_Offset (Original_Record_Component (gnat_field)));
7707 Set_Esize (gnat_field,
7708 Esize (Original_Record_Component (gnat_field)));
7713 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7714 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7715 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7716 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7717 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7718 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7719 pre-existing list to be chained to the newly created entries. */
7722 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
7723 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
7727 for (gnu_field = TYPE_FIELDS (gnu_type);
7729 gnu_field = DECL_CHAIN (gnu_field))
7731 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
7732 DECL_FIELD_BIT_OFFSET (gnu_field));
7733 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
7734 DECL_FIELD_OFFSET (gnu_field));
7735 unsigned int our_offset_align
7736 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
7737 tree v = make_tree_vec (3);
7739 TREE_VEC_ELT (v, 0) = gnu_our_offset;
7740 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
7741 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
7742 gnu_list = tree_cons (gnu_field, v, gnu_list);
7744 /* Recurse on internal fields, flattening the nested fields except for
7745 those in the variant part, if requested. */
7746 if (DECL_INTERNAL_P (gnu_field))
7748 tree gnu_field_type = TREE_TYPE (gnu_field);
7749 if (do_not_flatten_variant
7750 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
7752 = build_position_list (gnu_field_type, do_not_flatten_variant,
7753 size_zero_node, bitsize_zero_node,
7754 BIGGEST_ALIGNMENT, gnu_list);
7757 = build_position_list (gnu_field_type, do_not_flatten_variant,
7758 gnu_our_offset, gnu_our_bitpos,
7759 our_offset_align, gnu_list);
7766 /* Return a VEC describing the substitutions needed to reflect the
7767 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7768 be in any order. The values in an element of the VEC are in the form
7769 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
7770 a definition of GNAT_SUBTYPE. */
7772 static VEC(subst_pair,heap) *
7773 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
7775 VEC(subst_pair,heap) *gnu_vec = NULL;
7776 Entity_Id gnat_discrim;
7779 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
7780 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
7781 Present (gnat_discrim);
7782 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
7783 gnat_value = Next_Elmt (gnat_value))
7784 /* Ignore access discriminants. */
7785 if (!Is_Access_Type (Etype (Node (gnat_value))))
7787 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
7788 tree replacement = convert (TREE_TYPE (gnu_field),
7789 elaborate_expression
7790 (Node (gnat_value), gnat_subtype,
7791 get_entity_name (gnat_discrim),
7792 definition, true, false));
7793 subst_pair *s = VEC_safe_push (subst_pair, heap, gnu_vec, NULL);
7794 s->discriminant = gnu_field;
7795 s->replacement = replacement;
7801 /* Scan all fields in QUAL_UNION_TYPE and return a VEC describing the
7802 variants of QUAL_UNION_TYPE that are still relevant after applying
7803 the substitutions described in SUBST_LIST. VARIANT_LIST is a
7804 pre-existing VEC onto which newly created entries should be
7807 static VEC(variant_desc,heap) *
7808 build_variant_list (tree qual_union_type, VEC(subst_pair,heap) *subst_list,
7809 VEC(variant_desc,heap) *variant_list)
7813 for (gnu_field = TYPE_FIELDS (qual_union_type);
7815 gnu_field = DECL_CHAIN (gnu_field))
7817 tree qual = DECL_QUALIFIER (gnu_field);
7821 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
7822 qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
7824 /* If the new qualifier is not unconditionally false, its variant may
7825 still be accessed. */
7826 if (!integer_zerop (qual))
7829 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
7831 v = VEC_safe_push (variant_desc, heap, variant_list, NULL);
7832 v->type = variant_type;
7833 v->field = gnu_field;
7835 v->record = NULL_TREE;
7837 /* Recurse on the variant subpart of the variant, if any. */
7838 variant_subpart = get_variant_part (variant_type);
7839 if (variant_subpart)
7840 variant_list = build_variant_list (TREE_TYPE (variant_subpart),
7841 subst_list, variant_list);
7843 /* If the new qualifier is unconditionally true, the subsequent
7844 variants cannot be accessed. */
7845 if (integer_onep (qual))
7850 return variant_list;
7853 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7854 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
7855 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
7856 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
7857 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
7858 true if we are being called to process the Component_Size of GNAT_OBJECT;
7859 this is used only for error messages. ZERO_OK is true if a size of zero
7860 is permitted; if ZERO_OK is false, it means that a size of zero should be
7861 treated as an unspecified size. */
7864 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
7865 enum tree_code kind, bool component_p, bool zero_ok)
7867 Node_Id gnat_error_node;
7868 tree type_size, size;
7870 /* Return 0 if no size was specified. */
7871 if (uint_size == No_Uint)
7874 /* Ignore a negative size since that corresponds to our back-annotation. */
7875 if (UI_Lt (uint_size, Uint_0))
7878 /* Find the node to use for error messages. */
7879 if ((Ekind (gnat_object) == E_Component
7880 || Ekind (gnat_object) == E_Discriminant)
7881 && Present (Component_Clause (gnat_object)))
7882 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
7883 else if (Present (Size_Clause (gnat_object)))
7884 gnat_error_node = Expression (Size_Clause (gnat_object));
7886 gnat_error_node = gnat_object;
7888 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7889 but cannot be represented in bitsizetype. */
7890 size = UI_To_gnu (uint_size, bitsizetype);
7891 if (TREE_OVERFLOW (size))
7894 post_error_ne ("component size for& is too large", gnat_error_node,
7897 post_error_ne ("size for& is too large", gnat_error_node,
7902 /* Ignore a zero size if it is not permitted. */
7903 if (!zero_ok && integer_zerop (size))
7906 /* The size of objects is always a multiple of a byte. */
7907 if (kind == VAR_DECL
7908 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
7911 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7912 gnat_error_node, gnat_object);
7914 post_error_ne ("size for& is not a multiple of Storage_Unit",
7915 gnat_error_node, gnat_object);
7919 /* If this is an integral type or a packed array type, the front-end has
7920 already verified the size, so we need not do it here (which would mean
7921 checking against the bounds). However, if this is an aliased object,
7922 it may not be smaller than the type of the object. */
7923 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7924 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7927 /* If the object is a record that contains a template, add the size of the
7928 template to the specified size. */
7929 if (TREE_CODE (gnu_type) == RECORD_TYPE
7930 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7931 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7933 if (kind == VAR_DECL
7934 /* If a type needs strict alignment, a component of this type in
7935 a packed record cannot be packed and thus uses the type size. */
7936 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
7937 type_size = TYPE_SIZE (gnu_type);
7939 type_size = rm_size (gnu_type);
7941 /* Modify the size of a discriminated type to be the maximum size. */
7942 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7943 type_size = max_size (type_size, true);
7945 /* If this is an access type or a fat pointer, the minimum size is that given
7946 by the smallest integral mode that's valid for pointers. */
7947 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
7949 enum machine_mode p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7950 while (!targetm.valid_pointer_mode (p_mode))
7951 p_mode = GET_MODE_WIDER_MODE (p_mode);
7952 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7955 /* Issue an error either if the default size of the object isn't a constant
7956 or if the new size is smaller than it. */
7957 if (TREE_CODE (type_size) != INTEGER_CST
7958 || TREE_OVERFLOW (type_size)
7959 || tree_int_cst_lt (size, type_size))
7963 ("component size for& too small{, minimum allowed is ^}",
7964 gnat_error_node, gnat_object, type_size);
7967 ("size for& too small{, minimum allowed is ^}",
7968 gnat_error_node, gnat_object, type_size);
7975 /* Similarly, but both validate and process a value of RM size. This routine
7976 is only called for types. */
7979 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7981 Node_Id gnat_attr_node;
7982 tree old_size, size;
7984 /* Do nothing if no size was specified. */
7985 if (uint_size == No_Uint)
7988 /* Ignore a negative size since that corresponds to our back-annotation. */
7989 if (UI_Lt (uint_size, Uint_0))
7992 /* Only issue an error if a Value_Size clause was explicitly given.
7993 Otherwise, we'd be duplicating an error on the Size clause. */
7995 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7997 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7998 but cannot be represented in bitsizetype. */
7999 size = UI_To_gnu (uint_size, bitsizetype);
8000 if (TREE_OVERFLOW (size))
8002 if (Present (gnat_attr_node))
8003 post_error_ne ("Value_Size for& is too large", gnat_attr_node,
8008 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8009 exists, or this is an integer type, in which case the front-end will
8010 have always set it. */
8011 if (No (gnat_attr_node)
8012 && integer_zerop (size)
8013 && !Has_Size_Clause (gnat_entity)
8014 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8017 old_size = rm_size (gnu_type);
8019 /* If the old size is self-referential, get the maximum size. */
8020 if (CONTAINS_PLACEHOLDER_P (old_size))
8021 old_size = max_size (old_size, true);
8023 /* Issue an error either if the old size of the object isn't a constant or
8024 if the new size is smaller than it. The front-end has already verified
8025 this for scalar and packed array types. */
8026 if (TREE_CODE (old_size) != INTEGER_CST
8027 || TREE_OVERFLOW (old_size)
8028 || (AGGREGATE_TYPE_P (gnu_type)
8029 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
8030 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
8031 && !(TYPE_IS_PADDING_P (gnu_type)
8032 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
8033 && TYPE_PACKED_ARRAY_TYPE_P
8034 (TREE_TYPE (TYPE_FIELDS (gnu_type))))
8035 && tree_int_cst_lt (size, old_size)))
8037 if (Present (gnat_attr_node))
8039 ("Value_Size for& too small{, minimum allowed is ^}",
8040 gnat_attr_node, gnat_entity, old_size);
8044 /* Otherwise, set the RM size proper for integral types... */
8045 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
8046 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8047 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
8048 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
8049 SET_TYPE_RM_SIZE (gnu_type, size);
8051 /* ...or the Ada size for record and union types. */
8052 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
8053 || TREE_CODE (gnu_type) == UNION_TYPE
8054 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8055 && !TYPE_FAT_POINTER_P (gnu_type))
8056 SET_TYPE_ADA_SIZE (gnu_type, size);
8059 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
8060 If TYPE is the best type, return it. Otherwise, make a new type. We
8061 only support new integral and pointer types. FOR_BIASED is true if
8062 we are making a biased type. */
8065 make_type_from_size (tree type, tree size_tree, bool for_biased)
8067 unsigned HOST_WIDE_INT size;
8071 /* If size indicates an error, just return TYPE to avoid propagating
8072 the error. Likewise if it's too large to represent. */
8073 if (!size_tree || !host_integerp (size_tree, 1))
8076 size = tree_low_cst (size_tree, 1);
8078 switch (TREE_CODE (type))
8083 biased_p = (TREE_CODE (type) == INTEGER_TYPE
8084 && TYPE_BIASED_REPRESENTATION_P (type));
8086 /* Integer types with precision 0 are forbidden. */
8090 /* Only do something if the type is not a packed array type and
8091 doesn't already have the proper size. */
8092 if (TYPE_PACKED_ARRAY_TYPE_P (type)
8093 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
8096 biased_p |= for_biased;
8097 if (size > LONG_LONG_TYPE_SIZE)
8098 size = LONG_LONG_TYPE_SIZE;
8100 if (TYPE_UNSIGNED (type) || biased_p)
8101 new_type = make_unsigned_type (size);
8103 new_type = make_signed_type (size);
8104 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
8105 SET_TYPE_RM_MIN_VALUE (new_type,
8106 convert (TREE_TYPE (new_type),
8107 TYPE_MIN_VALUE (type)));
8108 SET_TYPE_RM_MAX_VALUE (new_type,
8109 convert (TREE_TYPE (new_type),
8110 TYPE_MAX_VALUE (type)));
8111 /* Copy the name to show that it's essentially the same type and
8112 not a subrange type. */
8113 TYPE_NAME (new_type) = TYPE_NAME (type);
8114 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
8115 SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
8119 /* Do something if this is a fat pointer, in which case we
8120 may need to return the thin pointer. */
8121 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
8123 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
8124 if (!targetm.valid_pointer_mode (p_mode))
8127 build_pointer_type_for_mode
8128 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
8134 /* Only do something if this is a thin pointer, in which case we
8135 may need to return the fat pointer. */
8136 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
8138 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
8148 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8149 a type or object whose present alignment is ALIGN. If this alignment is
8150 valid, return it. Otherwise, give an error and return ALIGN. */
8153 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
8155 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
8156 unsigned int new_align;
8157 Node_Id gnat_error_node;
8159 /* Don't worry about checking alignment if alignment was not specified
8160 by the source program and we already posted an error for this entity. */
8161 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
8164 /* Post the error on the alignment clause if any. Note, for the implicit
8165 base type of an array type, the alignment clause is on the first
8167 if (Present (Alignment_Clause (gnat_entity)))
8168 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
8170 else if (Is_Itype (gnat_entity)
8171 && Is_Array_Type (gnat_entity)
8172 && Etype (gnat_entity) == gnat_entity
8173 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
8175 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
8178 gnat_error_node = gnat_entity;
8180 /* Within GCC, an alignment is an integer, so we must make sure a value is
8181 specified that fits in that range. Also, there is an upper bound to
8182 alignments we can support/allow. */
8183 if (!UI_Is_In_Int_Range (alignment)
8184 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
8185 post_error_ne_num ("largest supported alignment for& is ^",
8186 gnat_error_node, gnat_entity, max_allowed_alignment);
8187 else if (!(Present (Alignment_Clause (gnat_entity))
8188 && From_At_Mod (Alignment_Clause (gnat_entity)))
8189 && new_align * BITS_PER_UNIT < align)
8191 unsigned int double_align;
8192 bool is_capped_double, align_clause;
8194 /* If the default alignment of "double" or larger scalar types is
8195 specifically capped and the new alignment is above the cap, do
8196 not post an error and change the alignment only if there is an
8197 alignment clause; this makes it possible to have the associated
8198 GCC type overaligned by default for performance reasons. */
8199 if ((double_align = double_float_alignment) > 0)
8202 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8204 = is_double_float_or_array (gnat_type, &align_clause);
8206 else if ((double_align = double_scalar_alignment) > 0)
8209 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8211 = is_double_scalar_or_array (gnat_type, &align_clause);
8214 is_capped_double = align_clause = false;
8216 if (is_capped_double && new_align >= double_align)
8219 align = new_align * BITS_PER_UNIT;
8223 if (is_capped_double)
8224 align = double_align * BITS_PER_UNIT;
8226 post_error_ne_num ("alignment for& must be at least ^",
8227 gnat_error_node, gnat_entity,
8228 align / BITS_PER_UNIT);
8233 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
8234 if (new_align > align)
8241 /* Return the smallest alignment not less than SIZE. */
8244 ceil_alignment (unsigned HOST_WIDE_INT size)
8246 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
8249 /* Verify that OBJECT, a type or decl, is something we can implement
8250 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
8251 if we require atomic components. */
8254 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
8256 Node_Id gnat_error_point = gnat_entity;
8258 enum machine_mode mode;
8262 /* There are three case of what OBJECT can be. It can be a type, in which
8263 case we take the size, alignment and mode from the type. It can be a
8264 declaration that was indirect, in which case the relevant values are
8265 that of the type being pointed to, or it can be a normal declaration,
8266 in which case the values are of the decl. The code below assumes that
8267 OBJECT is either a type or a decl. */
8268 if (TYPE_P (object))
8270 /* If this is an anonymous base type, nothing to check. Error will be
8271 reported on the source type. */
8272 if (!Comes_From_Source (gnat_entity))
8275 mode = TYPE_MODE (object);
8276 align = TYPE_ALIGN (object);
8277 size = TYPE_SIZE (object);
8279 else if (DECL_BY_REF_P (object))
8281 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
8282 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
8283 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
8287 mode = DECL_MODE (object);
8288 align = DECL_ALIGN (object);
8289 size = DECL_SIZE (object);
8292 /* Consider all floating-point types atomic and any types that that are
8293 represented by integers no wider than a machine word. */
8294 if (GET_MODE_CLASS (mode) == MODE_FLOAT
8295 || ((GET_MODE_CLASS (mode) == MODE_INT
8296 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
8297 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
8300 /* For the moment, also allow anything that has an alignment equal
8301 to its size and which is smaller than a word. */
8302 if (size && TREE_CODE (size) == INTEGER_CST
8303 && compare_tree_int (size, align) == 0
8304 && align <= BITS_PER_WORD)
8307 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
8308 gnat_node = Next_Rep_Item (gnat_node))
8310 if (!comp_p && Nkind (gnat_node) == N_Pragma
8311 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8313 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8314 else if (comp_p && Nkind (gnat_node) == N_Pragma
8315 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8316 == Pragma_Atomic_Components))
8317 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8321 post_error_ne ("atomic access to component of & cannot be guaranteed",
8322 gnat_error_point, gnat_entity);
8324 post_error_ne ("atomic access to & cannot be guaranteed",
8325 gnat_error_point, gnat_entity);
8329 /* Helper for the intrin compatibility checks family. Evaluate whether
8330 two types are definitely incompatible. */
8333 intrin_types_incompatible_p (tree t1, tree t2)
8335 enum tree_code code;
8337 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
8340 if (TYPE_MODE (t1) != TYPE_MODE (t2))
8343 if (TREE_CODE (t1) != TREE_CODE (t2))
8346 code = TREE_CODE (t1);
8352 return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
8355 case REFERENCE_TYPE:
8356 /* Assume designated types are ok. We'd need to account for char * and
8357 void * variants to do better, which could rapidly get messy and isn't
8358 clearly worth the effort. */
8368 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8369 on the Ada/builtin argument lists for the INB binding. */
8372 intrin_arglists_compatible_p (intrin_binding_t * inb)
8374 function_args_iterator ada_iter, btin_iter;
8376 function_args_iter_init (&ada_iter, inb->ada_fntype);
8377 function_args_iter_init (&btin_iter, inb->btin_fntype);
8379 /* Sequence position of the last argument we checked. */
8384 tree ada_type = function_args_iter_cond (&ada_iter);
8385 tree btin_type = function_args_iter_cond (&btin_iter);
8387 /* If we've exhausted both lists simultaneously, we're done. */
8388 if (ada_type == NULL_TREE && btin_type == NULL_TREE)
8391 /* If one list is shorter than the other, they fail to match. */
8392 if (ada_type == NULL_TREE || btin_type == NULL_TREE)
8395 /* If we're done with the Ada args and not with the internal builtin
8396 args, or the other way around, complain. */
8397 if (ada_type == void_type_node
8398 && btin_type != void_type_node)
8400 post_error ("?Ada arguments list too short!", inb->gnat_entity);
8404 if (btin_type == void_type_node
8405 && ada_type != void_type_node)
8407 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8408 inb->gnat_entity, inb->gnat_entity, argpos);
8412 /* Otherwise, check that types match for the current argument. */
8414 if (intrin_types_incompatible_p (ada_type, btin_type))
8416 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8417 inb->gnat_entity, inb->gnat_entity, argpos);
8422 function_args_iter_next (&ada_iter);
8423 function_args_iter_next (&btin_iter);
8429 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8430 on the Ada/builtin return values for the INB binding. */
8433 intrin_return_compatible_p (intrin_binding_t * inb)
8435 tree ada_return_type = TREE_TYPE (inb->ada_fntype);
8436 tree btin_return_type = TREE_TYPE (inb->btin_fntype);
8438 /* Accept function imported as procedure, common and convenient. */
8439 if (VOID_TYPE_P (ada_return_type)
8440 && !VOID_TYPE_P (btin_return_type))
8443 /* Check return types compatibility otherwise. Note that this
8444 handles void/void as well. */
8445 if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
8447 post_error ("?intrinsic binding type mismatch on return value!",
8455 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8456 compatible. Issue relevant warnings when they are not.
8458 This is intended as a light check to diagnose the most obvious cases, not
8459 as a full fledged type compatibility predicate. It is the programmer's
8460 responsibility to ensure correctness of the Ada declarations in Imports,
8461 especially when binding straight to a compiler internal. */
8464 intrin_profiles_compatible_p (intrin_binding_t * inb)
8466 /* Check compatibility on return values and argument lists, each responsible
8467 for posting warnings as appropriate. Ensure use of the proper sloc for
8470 bool arglists_compatible_p, return_compatible_p;
8471 location_t saved_location = input_location;
8473 Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
8475 return_compatible_p = intrin_return_compatible_p (inb);
8476 arglists_compatible_p = intrin_arglists_compatible_p (inb);
8478 input_location = saved_location;
8480 return return_compatible_p && arglists_compatible_p;
8483 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
8484 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
8485 specified size for this field. POS_LIST is a position list describing
8486 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
8490 create_field_decl_from (tree old_field, tree field_type, tree record_type,
8491 tree size, tree pos_list,
8492 VEC(subst_pair,heap) *subst_list)
8494 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
8495 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
8496 unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
8497 tree new_pos, new_field;
8501 if (CONTAINS_PLACEHOLDER_P (pos))
8502 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8503 pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
8505 /* If the position is now a constant, we can set it as the position of the
8506 field when we make it. Otherwise, we need to deal with it specially. */
8507 if (TREE_CONSTANT (pos))
8508 new_pos = bit_from_pos (pos, bitpos);
8510 new_pos = NULL_TREE;
8513 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
8514 size, new_pos, DECL_PACKED (old_field),
8515 !DECL_NONADDRESSABLE_P (old_field));
8519 normalize_offset (&pos, &bitpos, offset_align);
8520 DECL_FIELD_OFFSET (new_field) = pos;
8521 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
8522 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
8523 DECL_SIZE (new_field) = size;
8524 DECL_SIZE_UNIT (new_field)
8525 = convert (sizetype,
8526 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
8527 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
8530 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
8531 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
8532 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
8533 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8538 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8541 get_rep_part (tree record_type)
8543 tree field = TYPE_FIELDS (record_type);
8545 /* The REP part is the first field, internal, another record, and its name
8546 doesn't start with an underscore (i.e. is not generated by the FE). */
8547 if (DECL_INTERNAL_P (field)
8548 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8549 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
8555 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8558 get_variant_part (tree record_type)
8562 /* The variant part is the only internal field that is a qualified union. */
8563 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
8564 if (DECL_INTERNAL_P (field)
8565 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8571 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8572 the list of variants to be used and RECORD_TYPE is the type of the parent.
8573 POS_LIST is a position list describing the layout of fields present in
8574 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8578 create_variant_part_from (tree old_variant_part,
8579 VEC(variant_desc,heap) *variant_list,
8580 tree record_type, tree pos_list,
8581 VEC(subst_pair,heap) *subst_list)
8583 tree offset = DECL_FIELD_OFFSET (old_variant_part);
8584 tree old_union_type = TREE_TYPE (old_variant_part);
8585 tree new_union_type, new_variant_part;
8586 tree union_field_list = NULL_TREE;
8590 /* First create the type of the variant part from that of the old one. */
8591 new_union_type = make_node (QUAL_UNION_TYPE);
8592 TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
8594 /* If the position of the variant part is constant, subtract it from the
8595 size of the type of the parent to get the new size. This manual CSE
8596 reduces the code size when not optimizing. */
8597 if (TREE_CODE (offset) == INTEGER_CST)
8599 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8600 tree first_bit = bit_from_pos (offset, bitpos);
8601 TYPE_SIZE (new_union_type)
8602 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8603 TYPE_SIZE_UNIT (new_union_type)
8604 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8605 byte_from_pos (offset, bitpos));
8606 SET_TYPE_ADA_SIZE (new_union_type,
8607 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8609 TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
8610 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8613 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8615 /* Now finish up the new variants and populate the union type. */
8616 FOR_EACH_VEC_ELT_REVERSE (variant_desc, variant_list, ix, v)
8618 tree old_field = v->field, new_field;
8619 tree old_variant, old_variant_subpart, new_variant, field_list;
8621 /* Skip variants that don't belong to this nesting level. */
8622 if (DECL_CONTEXT (old_field) != old_union_type)
8625 /* Retrieve the list of fields already added to the new variant. */
8626 new_variant = v->record;
8627 field_list = TYPE_FIELDS (new_variant);
8629 /* If the old variant had a variant subpart, we need to create a new
8630 variant subpart and add it to the field list. */
8631 old_variant = v->type;
8632 old_variant_subpart = get_variant_part (old_variant);
8633 if (old_variant_subpart)
8635 tree new_variant_subpart
8636 = create_variant_part_from (old_variant_subpart, variant_list,
8637 new_variant, pos_list, subst_list);
8638 DECL_CHAIN (new_variant_subpart) = field_list;
8639 field_list = new_variant_subpart;
8642 /* Finish up the new variant and create the field. No need for debug
8643 info thanks to the XVS type. */
8644 finish_record_type (new_variant, nreverse (field_list), 2, false);
8645 compute_record_mode (new_variant);
8646 create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
8647 true, false, Empty);
8650 = create_field_decl_from (old_field, new_variant, new_union_type,
8651 TYPE_SIZE (new_variant),
8652 pos_list, subst_list);
8653 DECL_QUALIFIER (new_field) = v->qual;
8654 DECL_INTERNAL_P (new_field) = 1;
8655 DECL_CHAIN (new_field) = union_field_list;
8656 union_field_list = new_field;
8659 /* Finish up the union type and create the variant part. No need for debug
8660 info thanks to the XVS type. */
8661 finish_record_type (new_union_type, union_field_list, 2, false);
8662 compute_record_mode (new_union_type);
8663 create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
8664 true, false, Empty);
8667 = create_field_decl_from (old_variant_part, new_union_type, record_type,
8668 TYPE_SIZE (new_union_type),
8669 pos_list, subst_list);
8670 DECL_INTERNAL_P (new_variant_part) = 1;
8672 /* With multiple discriminants it is possible for an inner variant to be
8673 statically selected while outer ones are not; in this case, the list
8674 of fields of the inner variant is not flattened and we end up with a
8675 qualified union with a single member. Drop the useless container. */
8676 if (!DECL_CHAIN (union_field_list))
8678 DECL_CONTEXT (union_field_list) = record_type;
8679 DECL_FIELD_OFFSET (union_field_list)
8680 = DECL_FIELD_OFFSET (new_variant_part);
8681 DECL_FIELD_BIT_OFFSET (union_field_list)
8682 = DECL_FIELD_BIT_OFFSET (new_variant_part);
8683 SET_DECL_OFFSET_ALIGN (union_field_list,
8684 DECL_OFFSET_ALIGN (new_variant_part));
8685 new_variant_part = union_field_list;
8688 return new_variant_part;
8691 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8692 which are both RECORD_TYPE, after applying the substitutions described
8696 copy_and_substitute_in_size (tree new_type, tree old_type,
8697 VEC(subst_pair,heap) *subst_list)
8702 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
8703 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
8704 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
8705 TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
8706 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
8708 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
8709 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8710 TYPE_SIZE (new_type)
8711 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
8712 s->discriminant, s->replacement);
8714 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
8715 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8716 TYPE_SIZE_UNIT (new_type)
8717 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
8718 s->discriminant, s->replacement);
8720 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
8721 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8723 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
8724 s->discriminant, s->replacement));
8726 /* Finalize the size. */
8727 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
8728 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
8731 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8732 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8733 updated by replacing F with R.
8735 The function doesn't update the layout of the type, i.e. it assumes
8736 that the substitution is purely formal. That's why the replacement
8737 value R must itself contain a PLACEHOLDER_EXPR. */
8740 substitute_in_type (tree t, tree f, tree r)
8744 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
8746 switch (TREE_CODE (t))
8753 /* First the domain types of arrays. */
8754 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
8755 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
8757 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
8758 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
8760 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
8764 TYPE_GCC_MIN_VALUE (nt) = low;
8765 TYPE_GCC_MAX_VALUE (nt) = high;
8767 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
8769 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
8774 /* Then the subtypes. */
8775 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
8776 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
8778 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
8779 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
8781 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
8785 SET_TYPE_RM_MIN_VALUE (nt, low);
8786 SET_TYPE_RM_MAX_VALUE (nt, high);
8794 nt = substitute_in_type (TREE_TYPE (t), f, r);
8795 if (nt == TREE_TYPE (t))
8798 return build_complex_type (nt);
8801 /* These should never show up here. */
8806 tree component = substitute_in_type (TREE_TYPE (t), f, r);
8807 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
8809 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
8812 nt = build_nonshared_array_type (component, domain);
8813 TYPE_ALIGN (nt) = TYPE_ALIGN (t);
8814 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
8815 SET_TYPE_MODE (nt, TYPE_MODE (t));
8816 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8817 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8818 TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
8819 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
8820 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
8826 case QUAL_UNION_TYPE:
8828 bool changed_field = false;
8831 /* Start out with no fields, make new fields, and chain them
8832 in. If we haven't actually changed the type of any field,
8833 discard everything we've done and return the old type. */
8835 TYPE_FIELDS (nt) = NULL_TREE;
8837 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
8839 tree new_field = copy_node (field), new_n;
8841 new_n = substitute_in_type (TREE_TYPE (field), f, r);
8842 if (new_n != TREE_TYPE (field))
8844 TREE_TYPE (new_field) = new_n;
8845 changed_field = true;
8848 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
8849 if (new_n != DECL_FIELD_OFFSET (field))
8851 DECL_FIELD_OFFSET (new_field) = new_n;
8852 changed_field = true;
8855 /* Do the substitution inside the qualifier, if any. */
8856 if (TREE_CODE (t) == QUAL_UNION_TYPE)
8858 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
8859 if (new_n != DECL_QUALIFIER (field))
8861 DECL_QUALIFIER (new_field) = new_n;
8862 changed_field = true;
8866 DECL_CONTEXT (new_field) = nt;
8867 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
8869 DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
8870 TYPE_FIELDS (nt) = new_field;
8876 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
8877 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8878 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8879 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
8888 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8889 needed to represent the object. */
8892 rm_size (tree gnu_type)
8894 /* For integral types, we store the RM size explicitly. */
8895 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
8896 return TYPE_RM_SIZE (gnu_type);
8898 /* Return the RM size of the actual data plus the size of the template. */
8899 if (TREE_CODE (gnu_type) == RECORD_TYPE
8900 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8902 size_binop (PLUS_EXPR,
8903 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))),
8904 DECL_SIZE (TYPE_FIELDS (gnu_type)));
8906 /* For record types, we store the size explicitly. */
8907 if ((TREE_CODE (gnu_type) == RECORD_TYPE
8908 || TREE_CODE (gnu_type) == UNION_TYPE
8909 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8910 && !TYPE_FAT_POINTER_P (gnu_type)
8911 && TYPE_ADA_SIZE (gnu_type))
8912 return TYPE_ADA_SIZE (gnu_type);
8914 /* For other types, this is just the size. */
8915 return TYPE_SIZE (gnu_type);
8918 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8919 fully-qualified name, possibly with type information encoding.
8920 Otherwise, return the name. */
8923 get_entity_name (Entity_Id gnat_entity)
8925 Get_Encoded_Name (gnat_entity);
8926 return get_identifier_with_length (Name_Buffer, Name_Len);
8929 /* Return an identifier representing the external name to be used for
8930 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8931 and the specified suffix. */
8934 create_concat_name (Entity_Id gnat_entity, const char *suffix)
8936 Entity_Kind kind = Ekind (gnat_entity);
8940 String_Template temp = {1, strlen (suffix)};
8941 Fat_Pointer fp = {suffix, &temp};
8942 Get_External_Name_With_Suffix (gnat_entity, fp);
8945 Get_External_Name (gnat_entity, 0);
8947 /* A variable using the Stdcall convention lives in a DLL. We adjust
8948 its name to use the jump table, the _imp__NAME contains the address
8949 for the NAME variable. */
8950 if ((kind == E_Variable || kind == E_Constant)
8951 && Has_Stdcall_Convention (gnat_entity))
8953 const int len = 6 + Name_Len;
8954 char *new_name = (char *) alloca (len + 1);
8955 strcpy (new_name, "_imp__");
8956 strcat (new_name, Name_Buffer);
8957 return get_identifier_with_length (new_name, len);
8960 return get_identifier_with_length (Name_Buffer, Name_Len);
8963 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8964 string, return a new IDENTIFIER_NODE that is the concatenation of
8965 the name followed by "___" and the specified suffix. */
8968 concat_name (tree gnu_name, const char *suffix)
8970 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
8971 char *new_name = (char *) alloca (len + 1);
8972 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
8973 strcat (new_name, "___");
8974 strcat (new_name, suffix);
8975 return get_identifier_with_length (new_name, len);
8978 #include "gt-ada-decl.h"
OSDN Git Service
