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. Also don't convert to a record
1128 type with a variant part from a record type without one, to keep
1129 the object simpler. */
1131 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1132 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1133 && !(TYPE_IS_PADDING_P (gnu_type)
1134 && CONTAINS_PLACEHOLDER_P
1135 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
1136 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1137 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1138 && get_variant_part (gnu_type) != NULL_TREE
1139 && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
1140 gnu_expr = convert (gnu_type, gnu_expr);
1142 /* If this is a pointer that doesn't have an initializing expression,
1143 initialize it to NULL, unless the object is imported. */
1145 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1147 && !Is_Imported (gnat_entity))
1148 gnu_expr = integer_zero_node;
1150 /* If we are defining the object and it has an Address clause, we must
1151 either get the address expression from the saved GCC tree for the
1152 object if it has a Freeze node, or elaborate the address expression
1153 here since the front-end has guaranteed that the elaboration has no
1154 effects in this case. */
1155 if (definition && Present (Address_Clause (gnat_entity)))
1157 Node_Id gnat_expr = Expression (Address_Clause (gnat_entity));
1159 = present_gnu_tree (gnat_entity)
1160 ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
1162 save_gnu_tree (gnat_entity, NULL_TREE, false);
1164 /* Ignore the size. It's either meaningless or was handled
1166 gnu_size = NULL_TREE;
1167 /* Convert the type of the object to a reference type that can
1168 alias everything as per 13.3(19). */
1170 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1171 gnu_address = convert (gnu_type, gnu_address);
1174 = !Is_Public (gnat_entity)
1175 || compile_time_known_address_p (gnat_expr);
1177 /* If this is a deferred constant, the initializer is attached to
1179 if (kind == E_Constant && Present (Full_View (gnat_entity)))
1182 (Expression (Declaration_Node (Full_View (gnat_entity))));
1184 /* If we don't have an initializing expression for the underlying
1185 variable, the initializing expression for the pointer is the
1186 specified address. Otherwise, we have to make a COMPOUND_EXPR
1187 to assign both the address and the initial value. */
1189 gnu_expr = gnu_address;
1192 = build2 (COMPOUND_EXPR, gnu_type,
1194 (MODIFY_EXPR, NULL_TREE,
1195 build_unary_op (INDIRECT_REF, NULL_TREE,
1201 /* If it has an address clause and we are not defining it, mark it
1202 as an indirect object. Likewise for Stdcall objects that are
1204 if ((!definition && Present (Address_Clause (gnat_entity)))
1205 || (Is_Imported (gnat_entity)
1206 && Has_Stdcall_Convention (gnat_entity)))
1208 /* Convert the type of the object to a reference type that can
1209 alias everything as per 13.3(19). */
1211 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1212 gnu_size = NULL_TREE;
1214 /* No point in taking the address of an initializing expression
1215 that isn't going to be used. */
1216 gnu_expr = NULL_TREE;
1218 /* If it has an address clause whose value is known at compile
1219 time, make the object a CONST_DECL. This will avoid a
1220 useless dereference. */
1221 if (Present (Address_Clause (gnat_entity)))
1223 Node_Id gnat_address
1224 = Expression (Address_Clause (gnat_entity));
1226 if (compile_time_known_address_p (gnat_address))
1228 gnu_expr = gnat_to_gnu (gnat_address);
1236 /* If we are at top level and this object is of variable size,
1237 make the actual type a hidden pointer to the real type and
1238 make the initializer be a memory allocation and initialization.
1239 Likewise for objects we aren't defining (presumed to be
1240 external references from other packages), but there we do
1241 not set up an initialization.
1243 If the object's size overflows, make an allocator too, so that
1244 Storage_Error gets raised. Note that we will never free
1245 such memory, so we presume it never will get allocated. */
1246 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1247 global_bindings_p ()
1250 || (gnu_size && !allocatable_size_p (gnu_size,
1251 global_bindings_p ()
1255 gnu_type = build_reference_type (gnu_type);
1256 gnu_size = NULL_TREE;
1259 /* In case this was a aliased object whose nominal subtype is
1260 unconstrained, the pointer above will be a thin pointer and
1261 build_allocator will automatically make the template.
1263 If we have a template initializer only (that we made above),
1264 pretend there is none and rely on what build_allocator creates
1265 again anyway. Otherwise (if we have a full initializer), get
1266 the data part and feed that to build_allocator.
1268 If we are elaborating a mutable object, tell build_allocator to
1269 ignore a possibly simpler size from the initializer, if any, as
1270 we must allocate the maximum possible size in this case. */
1271 if (definition && !imported_p)
1273 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1275 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1276 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1279 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1281 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1282 && 1 == VEC_length (constructor_elt,
1283 CONSTRUCTOR_ELTS (gnu_expr)))
1287 = build_component_ref
1288 (gnu_expr, NULL_TREE,
1289 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1293 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1294 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)))
1295 post_error ("?`Storage_Error` will be raised at run time!",
1299 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1300 Empty, Empty, gnat_entity, mutable_p);
1305 gnu_expr = NULL_TREE;
1310 /* If this object would go into the stack and has an alignment larger
1311 than the largest stack alignment the back-end can honor, resort to
1312 a variable of "aligning type". */
1313 if (!global_bindings_p () && !static_p && definition
1314 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1316 /* Create the new variable. No need for extra room before the
1317 aligned field as this is in automatic storage. */
1319 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1320 TYPE_SIZE_UNIT (gnu_type),
1321 BIGGEST_ALIGNMENT, 0);
1323 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1324 NULL_TREE, gnu_new_type, NULL_TREE, false,
1325 false, false, false, NULL, gnat_entity);
1327 /* Initialize the aligned field if we have an initializer. */
1330 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1332 (gnu_new_var, NULL_TREE,
1333 TYPE_FIELDS (gnu_new_type), false),
1337 /* And setup this entity as a reference to the aligned field. */
1338 gnu_type = build_reference_type (gnu_type);
1341 (ADDR_EXPR, gnu_type,
1342 build_component_ref (gnu_new_var, NULL_TREE,
1343 TYPE_FIELDS (gnu_new_type), false));
1345 gnu_size = NULL_TREE;
1351 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1352 | TYPE_QUAL_CONST));
1354 /* Convert the expression to the type of the object except in the
1355 case where the object's type is unconstrained or the object's type
1356 is a padded record whose field is of self-referential size. In
1357 the former case, converting will generate unnecessary evaluations
1358 of the CONSTRUCTOR to compute the size and in the latter case, we
1359 want to only copy the actual data. Also don't convert to a record
1360 type with a variant part from a record type without one, to keep
1361 the object simpler. */
1363 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1364 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1365 && !(TYPE_IS_PADDING_P (gnu_type)
1366 && CONTAINS_PLACEHOLDER_P
1367 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
1368 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1369 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1370 && get_variant_part (gnu_type) != NULL_TREE
1371 && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
1372 gnu_expr = convert (gnu_type, gnu_expr);
1374 /* If this name is external or there was a name specified, use it,
1375 unless this is a VMS exception object since this would conflict
1376 with the symbol we need to export in addition. Don't use the
1377 Interface_Name if there is an address clause (see CD30005). */
1378 if (!Is_VMS_Exception (gnat_entity)
1379 && ((Present (Interface_Name (gnat_entity))
1380 && No (Address_Clause (gnat_entity)))
1381 || (Is_Public (gnat_entity)
1382 && (!Is_Imported (gnat_entity)
1383 || Is_Exported (gnat_entity)))))
1384 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1386 /* If this is an aggregate constant initialized to a constant, force it
1387 to be statically allocated. This saves an initialization copy. */
1390 && gnu_expr && TREE_CONSTANT (gnu_expr)
1391 && AGGREGATE_TYPE_P (gnu_type)
1392 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1393 && !(TYPE_IS_PADDING_P (gnu_type)
1394 && !host_integerp (TYPE_SIZE_UNIT
1395 (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
1398 /* Now create the variable or the constant and set various flags. */
1400 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1401 gnu_expr, const_flag, Is_Public (gnat_entity),
1402 imported_p || !definition, static_p, attr_list,
1404 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1405 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1407 /* If we are defining an Out parameter and optimization isn't enabled,
1408 create a fake PARM_DECL for debugging purposes and make it point to
1409 the VAR_DECL. Suppress debug info for the latter but make sure it
1410 will live on the stack so that it can be accessed from within the
1411 debugger through the PARM_DECL. */
1412 if (kind == E_Out_Parameter && definition && !optimize && debug_info_p)
1414 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1415 gnat_pushdecl (param, gnat_entity);
1416 SET_DECL_VALUE_EXPR (param, gnu_decl);
1417 DECL_HAS_VALUE_EXPR_P (param) = 1;
1418 DECL_IGNORED_P (gnu_decl) = 1;
1419 TREE_ADDRESSABLE (gnu_decl) = 1;
1422 /* If this is a renaming pointer, attach the renamed object to it and
1423 register it if we are at the global level. Note that an external
1424 constant is at the global level. */
1425 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1427 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1428 if ((!definition && kind == E_Constant) || global_bindings_p ())
1430 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1431 record_global_renaming_pointer (gnu_decl);
1435 /* If this is a constant and we are defining it or it generates a real
1436 symbol at the object level and we are referencing it, we may want
1437 or need to have a true variable to represent it:
1438 - if optimization isn't enabled, for debugging purposes,
1439 - if the constant is public and not overlaid on something else,
1440 - if its address is taken,
1441 - if either itself or its type is aliased. */
1442 if (TREE_CODE (gnu_decl) == CONST_DECL
1443 && (definition || Sloc (gnat_entity) > Standard_Location)
1444 && ((!optimize && debug_info_p)
1445 || (Is_Public (gnat_entity)
1446 && No (Address_Clause (gnat_entity)))
1447 || Address_Taken (gnat_entity)
1448 || Is_Aliased (gnat_entity)
1449 || Is_Aliased (Etype (gnat_entity))))
1452 = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1453 gnu_expr, true, Is_Public (gnat_entity),
1454 !definition, static_p, attr_list,
1457 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1459 /* As debugging information will be generated for the variable,
1460 do not generate debugging information for the constant. */
1462 DECL_IGNORED_P (gnu_decl) = 1;
1464 DECL_IGNORED_P (gnu_corr_var) = 1;
1467 /* If this is a constant, even if we don't need a true variable, we
1468 may need to avoid returning the initializer in every case. That
1469 can happen for the address of a (constant) constructor because,
1470 upon dereferencing it, the constructor will be reinjected in the
1471 tree, which may not be valid in every case; see lvalue_required_p
1472 for more details. */
1473 if (TREE_CODE (gnu_decl) == CONST_DECL)
1474 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1476 /* If this object is declared in a block that contains a block with an
1477 exception handler, and we aren't using the GCC exception mechanism,
1478 we must force this variable in memory in order to avoid an invalid
1480 if (Exception_Mechanism != Back_End_Exceptions
1481 && Has_Nested_Block_With_Handler (Scope (gnat_entity)))
1482 TREE_ADDRESSABLE (gnu_decl) = 1;
1484 /* If we are defining an object with variable size or an object with
1485 fixed size that will be dynamically allocated, and we are using the
1486 setjmp/longjmp exception mechanism, update the setjmp buffer. */
1488 && Exception_Mechanism == Setjmp_Longjmp
1489 && get_block_jmpbuf_decl ()
1490 && DECL_SIZE_UNIT (gnu_decl)
1491 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1492 || (flag_stack_check == GENERIC_STACK_CHECK
1493 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1494 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1495 add_stmt_with_node (build_call_n_expr
1496 (update_setjmp_buf_decl, 1,
1497 build_unary_op (ADDR_EXPR, NULL_TREE,
1498 get_block_jmpbuf_decl ())),
1501 /* Back-annotate Esize and Alignment of the object if not already
1502 known. Note that we pick the values of the type, not those of
1503 the object, to shield ourselves from low-level platform-dependent
1504 adjustments like alignment promotion. This is both consistent with
1505 all the treatment above, where alignment and size are set on the
1506 type of the object and not on the object directly, and makes it
1507 possible to support all confirming representation clauses. */
1508 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1509 used_by_ref, false);
1514 /* Return a TYPE_DECL for "void" that we previously made. */
1515 gnu_decl = TYPE_NAME (void_type_node);
1518 case E_Enumeration_Type:
1519 /* A special case: for the types Character and Wide_Character in
1520 Standard, we do not list all the literals. So if the literals
1521 are not specified, make this an unsigned type. */
1522 if (No (First_Literal (gnat_entity)))
1524 gnu_type = make_unsigned_type (esize);
1525 TYPE_NAME (gnu_type) = gnu_entity_name;
1527 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1528 This is needed by the DWARF-2 back-end to distinguish between
1529 unsigned integer types and character types. */
1530 TYPE_STRING_FLAG (gnu_type) = 1;
1535 /* We have a list of enumeral constants in First_Literal. We make a
1536 CONST_DECL for each one and build into GNU_LITERAL_LIST the list to
1537 be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST
1538 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1539 value of the literal. But when we have a regular boolean type, we
1540 simplify this a little by using a BOOLEAN_TYPE. */
1541 bool is_boolean = Is_Boolean_Type (gnat_entity)
1542 && !Has_Non_Standard_Rep (gnat_entity);
1543 tree gnu_literal_list = NULL_TREE;
1544 Entity_Id gnat_literal;
1546 if (Is_Unsigned_Type (gnat_entity))
1547 gnu_type = make_unsigned_type (esize);
1549 gnu_type = make_signed_type (esize);
1551 TREE_SET_CODE (gnu_type, is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1553 for (gnat_literal = First_Literal (gnat_entity);
1554 Present (gnat_literal);
1555 gnat_literal = Next_Literal (gnat_literal))
1558 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1560 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1561 gnu_type, gnu_value, true, false, false,
1562 false, NULL, gnat_literal);
1563 /* Do not generate debug info for individual enumerators. */
1564 DECL_IGNORED_P (gnu_literal) = 1;
1565 save_gnu_tree (gnat_literal, gnu_literal, false);
1566 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1567 gnu_value, gnu_literal_list);
1571 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1573 /* Note that the bounds are updated at the end of this function
1574 to avoid an infinite recursion since they refer to the type. */
1578 case E_Signed_Integer_Type:
1579 case E_Ordinary_Fixed_Point_Type:
1580 case E_Decimal_Fixed_Point_Type:
1581 /* For integer types, just make a signed type the appropriate number
1583 gnu_type = make_signed_type (esize);
1586 case E_Modular_Integer_Type:
1588 /* For modular types, make the unsigned type of the proper number
1589 of bits and then set up the modulus, if required. */
1590 tree gnu_modulus, gnu_high = NULL_TREE;
1592 /* Packed array types are supposed to be subtypes only. */
1593 gcc_assert (!Is_Packed_Array_Type (gnat_entity));
1595 gnu_type = make_unsigned_type (esize);
1597 /* Get the modulus in this type. If it overflows, assume it is because
1598 it is equal to 2**Esize. Note that there is no overflow checking
1599 done on unsigned type, so we detect the overflow by looking for
1600 a modulus of zero, which is otherwise invalid. */
1601 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1603 if (!integer_zerop (gnu_modulus))
1605 TYPE_MODULAR_P (gnu_type) = 1;
1606 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1607 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1608 convert (gnu_type, integer_one_node));
1611 /* If the upper bound is not maximal, make an extra subtype. */
1613 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1615 tree gnu_subtype = make_unsigned_type (esize);
1616 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1617 TREE_TYPE (gnu_subtype) = gnu_type;
1618 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1619 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1620 gnu_type = gnu_subtype;
1625 case E_Signed_Integer_Subtype:
1626 case E_Enumeration_Subtype:
1627 case E_Modular_Integer_Subtype:
1628 case E_Ordinary_Fixed_Point_Subtype:
1629 case E_Decimal_Fixed_Point_Subtype:
1631 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1632 not want to call create_range_type since we would like each subtype
1633 node to be distinct. ??? Historically this was in preparation for
1634 when memory aliasing is implemented, but that's obsolete now given
1635 the call to relate_alias_sets below.
1637 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1638 this fact is used by the arithmetic conversion functions.
1640 We elaborate the Ancestor_Subtype if it is not in the current unit
1641 and one of our bounds is non-static. We do this to ensure consistent
1642 naming in the case where several subtypes share the same bounds, by
1643 elaborating the first such subtype first, thus using its name. */
1646 && Present (Ancestor_Subtype (gnat_entity))
1647 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1648 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1649 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1650 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1652 /* Set the precision to the Esize except for bit-packed arrays. */
1653 if (Is_Packed_Array_Type (gnat_entity)
1654 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1655 esize = UI_To_Int (RM_Size (gnat_entity));
1657 /* This should be an unsigned type if the base type is unsigned or
1658 if the lower bound is constant and non-negative or if the type
1660 if (Is_Unsigned_Type (Etype (gnat_entity))
1661 || Is_Unsigned_Type (gnat_entity)
1662 || Has_Biased_Representation (gnat_entity))
1663 gnu_type = make_unsigned_type (esize);
1665 gnu_type = make_signed_type (esize);
1666 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1668 SET_TYPE_RM_MIN_VALUE
1670 convert (TREE_TYPE (gnu_type),
1671 elaborate_expression (Type_Low_Bound (gnat_entity),
1672 gnat_entity, get_identifier ("L"),
1674 Needs_Debug_Info (gnat_entity))));
1676 SET_TYPE_RM_MAX_VALUE
1678 convert (TREE_TYPE (gnu_type),
1679 elaborate_expression (Type_High_Bound (gnat_entity),
1680 gnat_entity, get_identifier ("U"),
1682 Needs_Debug_Info (gnat_entity))));
1684 /* One of the above calls might have caused us to be elaborated,
1685 so don't blow up if so. */
1686 if (present_gnu_tree (gnat_entity))
1688 maybe_present = true;
1692 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1693 = Has_Biased_Representation (gnat_entity);
1695 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1696 TYPE_STUB_DECL (gnu_type)
1697 = create_type_stub_decl (gnu_entity_name, gnu_type);
1699 /* Inherit our alias set from what we're a subtype of. Subtypes
1700 are not different types and a pointer can designate any instance
1701 within a subtype hierarchy. */
1702 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1704 /* For a packed array, make the original array type a parallel type. */
1706 && Is_Packed_Array_Type (gnat_entity)
1707 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1708 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1710 (Original_Array_Type (gnat_entity)));
1714 /* We have to handle clauses that under-align the type specially. */
1715 if ((Present (Alignment_Clause (gnat_entity))
1716 || (Is_Packed_Array_Type (gnat_entity)
1718 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1719 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1721 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1722 if (align >= TYPE_ALIGN (gnu_type))
1726 /* If the type we are dealing with represents a bit-packed array,
1727 we need to have the bits left justified on big-endian targets
1728 and right justified on little-endian targets. We also need to
1729 ensure that when the value is read (e.g. for comparison of two
1730 such values), we only get the good bits, since the unused bits
1731 are uninitialized. Both goals are accomplished by wrapping up
1732 the modular type in an enclosing record type. */
1733 if (Is_Packed_Array_Type (gnat_entity)
1734 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1736 tree gnu_field_type, gnu_field;
1738 /* Set the RM size before wrapping up the original type. */
1739 SET_TYPE_RM_SIZE (gnu_type,
1740 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1741 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1743 /* Create a stripped-down declaration, mainly for debugging. */
1744 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1745 debug_info_p, gnat_entity);
1747 /* Now save it and build the enclosing record type. */
1748 gnu_field_type = gnu_type;
1750 gnu_type = make_node (RECORD_TYPE);
1751 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1752 TYPE_PACKED (gnu_type) = 1;
1753 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1754 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1755 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1757 /* Propagate the alignment of the modular type to the record type,
1758 unless there is an alignment clause that under-aligns the type.
1759 This means that bit-packed arrays are given "ceil" alignment for
1760 their size by default, which may seem counter-intuitive but makes
1761 it possible to overlay them on modular types easily. */
1762 TYPE_ALIGN (gnu_type)
1763 = align > 0 ? align : TYPE_ALIGN (gnu_field_type);
1765 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1767 /* Don't declare the field as addressable since we won't be taking
1768 its address and this would prevent create_field_decl from making
1771 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
1772 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1774 /* Do not emit debug info until after the parallel type is added. */
1775 finish_record_type (gnu_type, gnu_field, 2, false);
1776 compute_record_mode (gnu_type);
1777 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1781 /* Make the original array type a parallel type. */
1782 if (present_gnu_tree (Original_Array_Type (gnat_entity)))
1783 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1785 (Original_Array_Type (gnat_entity)));
1787 rest_of_record_type_compilation (gnu_type);
1791 /* If the type we are dealing with has got a smaller alignment than the
1792 natural one, we need to wrap it up in a record type and under-align
1793 the latter. We reuse the padding machinery for this purpose. */
1796 tree gnu_field_type, gnu_field;
1798 /* Set the RM size before wrapping up the type. */
1799 SET_TYPE_RM_SIZE (gnu_type,
1800 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1802 /* Create a stripped-down declaration, mainly for debugging. */
1803 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1804 debug_info_p, gnat_entity);
1806 /* Now save it and build the enclosing record type. */
1807 gnu_field_type = gnu_type;
1809 gnu_type = make_node (RECORD_TYPE);
1810 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1811 TYPE_PACKED (gnu_type) = 1;
1812 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1813 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1814 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1815 TYPE_ALIGN (gnu_type) = align;
1816 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1818 /* Don't declare the field as addressable since we won't be taking
1819 its address and this would prevent create_field_decl from making
1822 = create_field_decl (get_identifier ("F"), gnu_field_type,
1823 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1825 finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
1826 compute_record_mode (gnu_type);
1827 TYPE_PADDING_P (gnu_type) = 1;
1832 case E_Floating_Point_Type:
1833 /* If this is a VAX floating-point type, use an integer of the proper
1834 size. All the operations will be handled with ASM statements. */
1835 if (Vax_Float (gnat_entity))
1837 gnu_type = make_signed_type (esize);
1838 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1839 SET_TYPE_DIGITS_VALUE (gnu_type,
1840 UI_To_gnu (Digits_Value (gnat_entity),
1845 /* The type of the Low and High bounds can be our type if this is
1846 a type from Standard, so set them at the end of the function. */
1847 gnu_type = make_node (REAL_TYPE);
1848 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1849 layout_type (gnu_type);
1852 case E_Floating_Point_Subtype:
1853 if (Vax_Float (gnat_entity))
1855 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1861 && Present (Ancestor_Subtype (gnat_entity))
1862 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1863 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1864 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1865 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1868 gnu_type = make_node (REAL_TYPE);
1869 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1870 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1871 TYPE_GCC_MIN_VALUE (gnu_type)
1872 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1873 TYPE_GCC_MAX_VALUE (gnu_type)
1874 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1875 layout_type (gnu_type);
1877 SET_TYPE_RM_MIN_VALUE
1879 convert (TREE_TYPE (gnu_type),
1880 elaborate_expression (Type_Low_Bound (gnat_entity),
1881 gnat_entity, get_identifier ("L"),
1883 Needs_Debug_Info (gnat_entity))));
1885 SET_TYPE_RM_MAX_VALUE
1887 convert (TREE_TYPE (gnu_type),
1888 elaborate_expression (Type_High_Bound (gnat_entity),
1889 gnat_entity, get_identifier ("U"),
1891 Needs_Debug_Info (gnat_entity))));
1893 /* One of the above calls might have caused us to be elaborated,
1894 so don't blow up if so. */
1895 if (present_gnu_tree (gnat_entity))
1897 maybe_present = true;
1901 /* Inherit our alias set from what we're a subtype of, as for
1902 integer subtypes. */
1903 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1907 /* Array and String Types and Subtypes
1909 Unconstrained array types are represented by E_Array_Type and
1910 constrained array types are represented by E_Array_Subtype. There
1911 are no actual objects of an unconstrained array type; all we have
1912 are pointers to that type.
1914 The following fields are defined on array types and subtypes:
1916 Component_Type Component type of the array.
1917 Number_Dimensions Number of dimensions (an int).
1918 First_Index Type of first index. */
1923 const bool convention_fortran_p
1924 = (Convention (gnat_entity) == Convention_Fortran);
1925 const int ndim = Number_Dimensions (gnat_entity);
1926 tree gnu_template_type = make_node (RECORD_TYPE);
1927 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1928 tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
1929 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
1930 tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
1931 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem, t;
1932 Entity_Id gnat_index, gnat_name;
1935 /* We complete an existing dummy fat pointer type in place. This both
1936 avoids further complex adjustments in update_pointer_to and yields
1937 better debugging information in DWARF by leveraging the support for
1938 incomplete declarations of "tagged" types in the DWARF back-end. */
1939 gnu_type = get_dummy_type (gnat_entity);
1940 if (gnu_type && TYPE_POINTER_TO (gnu_type))
1942 gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
1943 TYPE_NAME (gnu_fat_type) = NULL_TREE;
1944 /* Save the contents of the dummy type for update_pointer_to. */
1945 TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
1948 gnu_fat_type = make_node (RECORD_TYPE);
1950 /* Make a node for the array. If we are not defining the array
1951 suppress expanding incomplete types. */
1952 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1956 defer_incomplete_level++;
1957 this_deferred = true;
1960 /* Build the fat pointer type. Use a "void *" object instead of
1961 a pointer to the array type since we don't have the array type
1962 yet (it will reference the fat pointer via the bounds). */
1964 = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node,
1965 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
1967 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
1968 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
1970 if (COMPLETE_TYPE_P (gnu_fat_type))
1972 /* We are going to lay it out again so reset the alias set. */
1973 alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type);
1974 TYPE_ALIAS_SET (gnu_fat_type) = -1;
1975 finish_fat_pointer_type (gnu_fat_type, tem);
1976 TYPE_ALIAS_SET (gnu_fat_type) = alias_set;
1977 for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
1979 TYPE_FIELDS (t) = tem;
1980 SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
1985 finish_fat_pointer_type (gnu_fat_type, tem);
1986 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1989 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1990 is the fat pointer. This will be used to access the individual
1991 fields once we build them. */
1992 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1993 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1994 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1995 gnu_template_reference
1996 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1997 TREE_READONLY (gnu_template_reference) = 1;
1999 /* Now create the GCC type for each index and add the fields for that
2000 index to the template. */
2001 for (index = (convention_fortran_p ? ndim - 1 : 0),
2002 gnat_index = First_Index (gnat_entity);
2003 0 <= index && index < ndim;
2004 index += (convention_fortran_p ? - 1 : 1),
2005 gnat_index = Next_Index (gnat_index))
2007 char field_name[16];
2008 tree gnu_index_base_type
2009 = get_unpadded_type (Base_Type (Etype (gnat_index)));
2010 tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
2011 tree gnu_min, gnu_max, gnu_high;
2013 /* Make the FIELD_DECLs for the low and high bounds of this
2014 type and then make extractions of these fields from the
2016 sprintf (field_name, "LB%d", index);
2017 gnu_lb_field = create_field_decl (get_identifier (field_name),
2018 gnu_index_base_type,
2019 gnu_template_type, NULL_TREE,
2021 Sloc_to_locus (Sloc (gnat_entity),
2022 &DECL_SOURCE_LOCATION (gnu_lb_field));
2024 field_name[0] = 'U';
2025 gnu_hb_field = create_field_decl (get_identifier (field_name),
2026 gnu_index_base_type,
2027 gnu_template_type, NULL_TREE,
2029 Sloc_to_locus (Sloc (gnat_entity),
2030 &DECL_SOURCE_LOCATION (gnu_hb_field));
2032 gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
2034 /* We can't use build_component_ref here since the template type
2035 isn't complete yet. */
2036 gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type,
2037 gnu_template_reference, gnu_lb_field,
2039 gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type,
2040 gnu_template_reference, gnu_hb_field,
2042 TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
2044 gnu_min = convert (sizetype, gnu_orig_min);
2045 gnu_max = convert (sizetype, gnu_orig_max);
2047 /* Compute the size of this dimension. See the E_Array_Subtype
2048 case below for the rationale. */
2050 = build3 (COND_EXPR, sizetype,
2051 build2 (GE_EXPR, boolean_type_node,
2052 gnu_orig_max, gnu_orig_min),
2054 size_binop (MINUS_EXPR, gnu_min, size_one_node));
2056 /* Make a range type with the new range in the Ada base type.
2057 Then make an index type with the size range in sizetype. */
2058 gnu_index_types[index]
2059 = create_index_type (gnu_min, gnu_high,
2060 create_range_type (gnu_index_base_type,
2065 /* Update the maximum size of the array in elements. */
2068 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2070 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
2072 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
2074 = size_binop (MAX_EXPR,
2075 size_binop (PLUS_EXPR, size_one_node,
2076 size_binop (MINUS_EXPR,
2080 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2081 && TREE_OVERFLOW (gnu_this_max))
2082 gnu_max_size = NULL_TREE;
2085 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2088 TYPE_NAME (gnu_index_types[index])
2089 = create_concat_name (gnat_entity, field_name);
2092 /* Install all the fields into the template. */
2093 TYPE_NAME (gnu_template_type)
2094 = create_concat_name (gnat_entity, "XUB");
2095 gnu_template_fields = NULL_TREE;
2096 for (index = 0; index < ndim; index++)
2098 = chainon (gnu_template_fields, gnu_temp_fields[index]);
2099 finish_record_type (gnu_template_type, gnu_template_fields, 0,
2101 TYPE_READONLY (gnu_template_type) = 1;
2103 /* Now make the array of arrays and update the pointer to the array
2104 in the fat pointer. Note that it is the first field. */
2106 = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
2108 /* If Component_Size is not already specified, annotate it with the
2109 size of the component. */
2110 if (Unknown_Component_Size (gnat_entity))
2111 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
2113 /* Compute the maximum size of the array in units and bits. */
2116 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2117 TYPE_SIZE_UNIT (tem));
2118 gnu_max_size = size_binop (MULT_EXPR,
2119 convert (bitsizetype, gnu_max_size),
2123 gnu_max_size_unit = NULL_TREE;
2125 /* Now build the array type. */
2126 for (index = ndim - 1; index >= 0; index--)
2128 tem = build_nonshared_array_type (tem, gnu_index_types[index]);
2129 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2130 if (array_type_has_nonaliased_component (tem, gnat_entity))
2131 TYPE_NONALIASED_COMPONENT (tem) = 1;
2134 /* If an alignment is specified, use it if valid. But ignore it
2135 for the original type of packed array types. If the alignment
2136 was requested with an explicit alignment clause, state so. */
2137 if (No (Packed_Array_Type (gnat_entity))
2138 && Known_Alignment (gnat_entity))
2141 = validate_alignment (Alignment (gnat_entity), gnat_entity,
2143 if (Present (Alignment_Clause (gnat_entity)))
2144 TYPE_USER_ALIGN (tem) = 1;
2147 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2149 /* Adjust the type of the pointer-to-array field of the fat pointer
2150 and record the aliasing relationships if necessary. */
2151 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2152 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
2153 record_component_aliases (gnu_fat_type);
2155 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2156 corresponding fat pointer. */
2157 TREE_TYPE (gnu_type) = gnu_fat_type;
2158 TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
2159 TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2160 SET_TYPE_MODE (gnu_type, BLKmode);
2161 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
2163 /* If the maximum size doesn't overflow, use it. */
2165 && TREE_CODE (gnu_max_size) == INTEGER_CST
2166 && !TREE_OVERFLOW (gnu_max_size)
2167 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2168 && !TREE_OVERFLOW (gnu_max_size_unit))
2170 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2172 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2173 TYPE_SIZE_UNIT (tem));
2176 create_type_decl (create_concat_name (gnat_entity, "XUA"),
2177 tem, NULL, !Comes_From_Source (gnat_entity),
2178 debug_info_p, gnat_entity);
2180 /* Give the fat pointer type a name. If this is a packed type, tell
2181 the debugger how to interpret the underlying bits. */
2182 if (Present (Packed_Array_Type (gnat_entity)))
2183 gnat_name = Packed_Array_Type (gnat_entity);
2185 gnat_name = gnat_entity;
2186 create_type_decl (create_concat_name (gnat_name, "XUP"),
2187 gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
2188 debug_info_p, gnat_entity);
2190 /* Create the type to be used as what a thin pointer designates:
2191 a record type for the object and its template with the fields
2192 shifted to have the template at a negative offset. */
2193 tem = build_unc_object_type (gnu_template_type, tem,
2194 create_concat_name (gnat_name, "XUT"),
2196 shift_unc_components_for_thin_pointers (tem);
2198 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2199 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2203 case E_String_Subtype:
2204 case E_Array_Subtype:
2206 /* This is the actual data type for array variables. Multidimensional
2207 arrays are implemented as arrays of arrays. Note that arrays which
2208 have sparse enumeration subtypes as index components create sparse
2209 arrays, which is obviously space inefficient but so much easier to
2212 Also note that the subtype never refers to the unconstrained array
2213 type, which is somewhat at variance with Ada semantics.
2215 First check to see if this is simply a renaming of the array type.
2216 If so, the result is the array type. */
2218 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2219 if (!Is_Constrained (gnat_entity))
2223 Entity_Id gnat_index, gnat_base_index;
2224 const bool convention_fortran_p
2225 = (Convention (gnat_entity) == Convention_Fortran);
2226 const int ndim = Number_Dimensions (gnat_entity);
2227 tree gnu_base_type = gnu_type;
2228 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2229 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2230 bool need_index_type_struct = false;
2233 /* First create the GCC type for each index and find out whether
2234 special types are needed for debugging information. */
2235 for (index = (convention_fortran_p ? ndim - 1 : 0),
2236 gnat_index = First_Index (gnat_entity),
2238 = First_Index (Implementation_Base_Type (gnat_entity));
2239 0 <= index && index < ndim;
2240 index += (convention_fortran_p ? - 1 : 1),
2241 gnat_index = Next_Index (gnat_index),
2242 gnat_base_index = Next_Index (gnat_base_index))
2244 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2245 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2246 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2247 tree gnu_min = convert (sizetype, gnu_orig_min);
2248 tree gnu_max = convert (sizetype, gnu_orig_max);
2249 tree gnu_base_index_type
2250 = get_unpadded_type (Etype (gnat_base_index));
2251 tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2252 tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2255 /* See if the base array type is already flat. If it is, we
2256 are probably compiling an ACATS test but it will cause the
2257 code below to malfunction if we don't handle it specially. */
2258 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2259 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2260 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2262 gnu_min = size_one_node;
2263 gnu_max = size_zero_node;
2267 /* Similarly, if one of the values overflows in sizetype and the
2268 range is null, use 1..0 for the sizetype bounds. */
2269 else if (TREE_CODE (gnu_min) == INTEGER_CST
2270 && TREE_CODE (gnu_max) == INTEGER_CST
2271 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2272 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2274 gnu_min = size_one_node;
2275 gnu_max = size_zero_node;
2279 /* If the minimum and maximum values both overflow in sizetype,
2280 but the difference in the original type does not overflow in
2281 sizetype, ignore the overflow indication. */
2282 else if (TREE_CODE (gnu_min) == INTEGER_CST
2283 && TREE_CODE (gnu_max) == INTEGER_CST
2284 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2287 fold_build2 (MINUS_EXPR, gnu_index_type,
2291 TREE_OVERFLOW (gnu_min) = 0;
2292 TREE_OVERFLOW (gnu_max) = 0;
2296 /* Compute the size of this dimension in the general case. We
2297 need to provide GCC with an upper bound to use but have to
2298 deal with the "superflat" case. There are three ways to do
2299 this. If we can prove that the array can never be superflat,
2300 we can just use the high bound of the index type. */
2301 else if ((Nkind (gnat_index) == N_Range
2302 && cannot_be_superflat_p (gnat_index))
2303 /* Packed Array Types are never superflat. */
2304 || Is_Packed_Array_Type (gnat_entity))
2307 /* Otherwise, if the high bound is constant but the low bound is
2308 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2309 lower bound. Note that the comparison must be done in the
2310 original type to avoid any overflow during the conversion. */
2311 else if (TREE_CODE (gnu_max) == INTEGER_CST
2312 && TREE_CODE (gnu_min) != INTEGER_CST)
2316 = build_cond_expr (sizetype,
2317 build_binary_op (GE_EXPR,
2322 size_binop (PLUS_EXPR, gnu_max,
2326 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2327 in all the other cases. Note that, here as well as above,
2328 the condition used in the comparison must be equivalent to
2329 the condition (length != 0). This is relied upon in order
2330 to optimize array comparisons in compare_arrays. */
2333 = build_cond_expr (sizetype,
2334 build_binary_op (GE_EXPR,
2339 size_binop (MINUS_EXPR, gnu_min,
2342 /* Reuse the index type for the range type. Then make an index
2343 type with the size range in sizetype. */
2344 gnu_index_types[index]
2345 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2348 /* Update the maximum size of the array in elements. Here we
2349 see if any constraint on the index type of the base type
2350 can be used in the case of self-referential bound on the
2351 index type of the subtype. We look for a non-"infinite"
2352 and non-self-referential bound from any type involved and
2353 handle each bound separately. */
2356 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2357 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2358 tree gnu_base_index_base_type
2359 = get_base_type (gnu_base_index_type);
2360 tree gnu_base_base_min
2361 = convert (sizetype,
2362 TYPE_MIN_VALUE (gnu_base_index_base_type));
2363 tree gnu_base_base_max
2364 = convert (sizetype,
2365 TYPE_MAX_VALUE (gnu_base_index_base_type));
2367 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2368 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2369 && !TREE_OVERFLOW (gnu_base_min)))
2370 gnu_base_min = gnu_min;
2372 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2373 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2374 && !TREE_OVERFLOW (gnu_base_max)))
2375 gnu_base_max = gnu_max;
2377 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2378 && TREE_OVERFLOW (gnu_base_min))
2379 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2380 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2381 && TREE_OVERFLOW (gnu_base_max))
2382 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2383 gnu_max_size = NULL_TREE;
2387 = size_binop (MAX_EXPR,
2388 size_binop (PLUS_EXPR, size_one_node,
2389 size_binop (MINUS_EXPR,
2394 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2395 && TREE_OVERFLOW (gnu_this_max))
2396 gnu_max_size = NULL_TREE;
2399 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2403 /* We need special types for debugging information to point to
2404 the index types if they have variable bounds, are not integer
2405 types, are biased or are wider than sizetype. */
2406 if (!integer_onep (gnu_orig_min)
2407 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2408 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2409 || (TREE_TYPE (gnu_index_type)
2410 && TREE_CODE (TREE_TYPE (gnu_index_type))
2412 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
2413 || compare_tree_int (rm_size (gnu_index_type),
2414 TYPE_PRECISION (sizetype)) > 0)
2415 need_index_type_struct = true;
2418 /* Then flatten: create the array of arrays. For an array type
2419 used to implement a packed array, get the component type from
2420 the original array type since the representation clauses that
2421 can affect it are on the latter. */
2422 if (Is_Packed_Array_Type (gnat_entity)
2423 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2425 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2426 for (index = ndim - 1; index >= 0; index--)
2427 gnu_type = TREE_TYPE (gnu_type);
2429 /* One of the above calls might have caused us to be elaborated,
2430 so don't blow up if so. */
2431 if (present_gnu_tree (gnat_entity))
2433 maybe_present = true;
2439 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2442 /* One of the above calls might have caused us to be elaborated,
2443 so don't blow up if so. */
2444 if (present_gnu_tree (gnat_entity))
2446 maybe_present = true;
2451 /* Compute the maximum size of the array in units and bits. */
2454 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2455 TYPE_SIZE_UNIT (gnu_type));
2456 gnu_max_size = size_binop (MULT_EXPR,
2457 convert (bitsizetype, gnu_max_size),
2458 TYPE_SIZE (gnu_type));
2461 gnu_max_size_unit = NULL_TREE;
2463 /* Now build the array type. */
2464 for (index = ndim - 1; index >= 0; index --)
2466 gnu_type = build_nonshared_array_type (gnu_type,
2467 gnu_index_types[index]);
2468 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2469 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2470 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2473 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2474 TYPE_STUB_DECL (gnu_type)
2475 = create_type_stub_decl (gnu_entity_name, gnu_type);
2477 /* If we are at file level and this is a multi-dimensional array,
2478 we need to make a variable corresponding to the stride of the
2479 inner dimensions. */
2480 if (global_bindings_p () && ndim > 1)
2482 tree gnu_st_name = get_identifier ("ST");
2485 for (gnu_arr_type = TREE_TYPE (gnu_type);
2486 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2487 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2488 gnu_st_name = concat_name (gnu_st_name, "ST"))
2490 tree eltype = TREE_TYPE (gnu_arr_type);
2492 TYPE_SIZE (gnu_arr_type)
2493 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2494 gnat_entity, gnu_st_name,
2497 /* ??? For now, store the size as a multiple of the
2498 alignment of the element type in bytes so that we
2499 can see the alignment from the tree. */
2500 TYPE_SIZE_UNIT (gnu_arr_type)
2501 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type),
2503 concat_name (gnu_st_name, "A_U"),
2505 TYPE_ALIGN (eltype));
2507 /* ??? create_type_decl is not invoked on the inner types so
2508 the MULT_EXPR node built above will never be marked. */
2509 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2513 /* If we need to write out a record type giving the names of the
2514 bounds for debugging purposes, do it now and make the record
2515 type a parallel type. This is not needed for a packed array
2516 since the bounds are conveyed by the original array type. */
2517 if (need_index_type_struct
2519 && !Is_Packed_Array_Type (gnat_entity))
2521 tree gnu_bound_rec = make_node (RECORD_TYPE);
2522 tree gnu_field_list = NULL_TREE;
2525 TYPE_NAME (gnu_bound_rec)
2526 = create_concat_name (gnat_entity, "XA");
2528 for (index = ndim - 1; index >= 0; index--)
2530 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2531 tree gnu_index_name = TYPE_NAME (gnu_index);
2533 if (TREE_CODE (gnu_index_name) == TYPE_DECL)
2534 gnu_index_name = DECL_NAME (gnu_index_name);
2536 /* Make sure to reference the types themselves, and not just
2537 their names, as the debugger may fall back on them. */
2538 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2539 gnu_bound_rec, NULL_TREE,
2541 DECL_CHAIN (gnu_field) = gnu_field_list;
2542 gnu_field_list = gnu_field;
2545 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2546 add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
2549 /* If this is a packed array type, make the original array type a
2550 parallel type. Otherwise, do it for the base array type if it
2551 isn't artificial to make sure it is kept in the debug info. */
2554 if (Is_Packed_Array_Type (gnat_entity)
2555 && present_gnu_tree (Original_Array_Type (gnat_entity)))
2556 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2558 (Original_Array_Type (gnat_entity)));
2562 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0);
2563 if (!DECL_ARTIFICIAL (gnu_base_decl))
2564 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2565 TREE_TYPE (TREE_TYPE (gnu_base_decl)));
2569 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2570 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2571 = (Is_Packed_Array_Type (gnat_entity)
2572 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2574 /* If the size is self-referential and the maximum size doesn't
2575 overflow, use it. */
2576 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2578 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2579 && TREE_OVERFLOW (gnu_max_size))
2580 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2581 && TREE_OVERFLOW (gnu_max_size_unit)))
2583 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2584 TYPE_SIZE (gnu_type));
2585 TYPE_SIZE_UNIT (gnu_type)
2586 = size_binop (MIN_EXPR, gnu_max_size_unit,
2587 TYPE_SIZE_UNIT (gnu_type));
2590 /* Set our alias set to that of our base type. This gives all
2591 array subtypes the same alias set. */
2592 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2594 /* If this is a packed type, make this type the same as the packed
2595 array type, but do some adjusting in the type first. */
2596 if (Present (Packed_Array_Type (gnat_entity)))
2598 Entity_Id gnat_index;
2601 /* First finish the type we had been making so that we output
2602 debugging information for it. */
2603 if (Treat_As_Volatile (gnat_entity))
2605 = build_qualified_type (gnu_type,
2606 TYPE_QUALS (gnu_type)
2607 | TYPE_QUAL_VOLATILE);
2609 /* Make it artificial only if the base type was artificial too.
2610 That's sort of "morally" true and will make it possible for
2611 the debugger to look it up by name in DWARF, which is needed
2612 in order to decode the packed array type. */
2614 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
2615 !Comes_From_Source (Etype (gnat_entity))
2616 && !Comes_From_Source (gnat_entity),
2617 debug_info_p, gnat_entity);
2619 /* Save it as our equivalent in case the call below elaborates
2621 save_gnu_tree (gnat_entity, gnu_decl, false);
2623 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2625 this_made_decl = true;
2626 gnu_type = TREE_TYPE (gnu_decl);
2627 save_gnu_tree (gnat_entity, NULL_TREE, false);
2629 gnu_inner = gnu_type;
2630 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2631 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2632 || TYPE_PADDING_P (gnu_inner)))
2633 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2635 /* We need to attach the index type to the type we just made so
2636 that the actual bounds can later be put into a template. */
2637 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2638 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2639 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2640 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2642 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2644 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2645 TYPE_MODULUS for modular types so we make an extra
2646 subtype if necessary. */
2647 if (TYPE_MODULAR_P (gnu_inner))
2650 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2651 TREE_TYPE (gnu_subtype) = gnu_inner;
2652 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2653 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2654 TYPE_MIN_VALUE (gnu_inner));
2655 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2656 TYPE_MAX_VALUE (gnu_inner));
2657 gnu_inner = gnu_subtype;
2660 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2662 #ifdef ENABLE_CHECKING
2663 /* Check for other cases of overloading. */
2664 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2668 for (gnat_index = First_Index (gnat_entity);
2669 Present (gnat_index);
2670 gnat_index = Next_Index (gnat_index))
2671 SET_TYPE_ACTUAL_BOUNDS
2673 tree_cons (NULL_TREE,
2674 get_unpadded_type (Etype (gnat_index)),
2675 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2677 if (Convention (gnat_entity) != Convention_Fortran)
2678 SET_TYPE_ACTUAL_BOUNDS
2679 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2681 if (TREE_CODE (gnu_type) == RECORD_TYPE
2682 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2683 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2688 /* Abort if packed array with no Packed_Array_Type field set. */
2689 gcc_assert (!Is_Packed (gnat_entity));
2693 case E_String_Literal_Subtype:
2694 /* Create the type for a string literal. */
2696 Entity_Id gnat_full_type
2697 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2698 && Present (Full_View (Etype (gnat_entity)))
2699 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2700 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2701 tree gnu_string_array_type
2702 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2703 tree gnu_string_index_type
2704 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2705 (TYPE_DOMAIN (gnu_string_array_type))));
2706 tree gnu_lower_bound
2707 = convert (gnu_string_index_type,
2708 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2709 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2710 tree gnu_length = ssize_int (length - 1);
2711 tree gnu_upper_bound
2712 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2714 convert (gnu_string_index_type, gnu_length));
2716 = create_index_type (convert (sizetype, gnu_lower_bound),
2717 convert (sizetype, gnu_upper_bound),
2718 create_range_type (gnu_string_index_type,
2724 = build_nonshared_array_type (gnat_to_gnu_type
2725 (Component_Type (gnat_entity)),
2727 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2728 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2729 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2733 /* Record Types and Subtypes
2735 The following fields are defined on record types:
2737 Has_Discriminants True if the record has discriminants
2738 First_Discriminant Points to head of list of discriminants
2739 First_Entity Points to head of list of fields
2740 Is_Tagged_Type True if the record is tagged
2742 Implementation of Ada records and discriminated records:
2744 A record type definition is transformed into the equivalent of a C
2745 struct definition. The fields that are the discriminants which are
2746 found in the Full_Type_Declaration node and the elements of the
2747 Component_List found in the Record_Type_Definition node. The
2748 Component_List can be a recursive structure since each Variant of
2749 the Variant_Part of the Component_List has a Component_List.
2751 Processing of a record type definition comprises starting the list of
2752 field declarations here from the discriminants and the calling the
2753 function components_to_record to add the rest of the fields from the
2754 component list and return the gnu type node. The function
2755 components_to_record will call itself recursively as it traverses
2759 if (Has_Complex_Representation (gnat_entity))
2762 = build_complex_type
2764 (Etype (Defining_Entity
2765 (First (Component_Items
2768 (Declaration_Node (gnat_entity)))))))));
2774 Node_Id full_definition = Declaration_Node (gnat_entity);
2775 Node_Id record_definition = Type_Definition (full_definition);
2776 Entity_Id gnat_field;
2777 tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
2778 /* Set PACKED in keeping with gnat_to_gnu_field. */
2780 = Is_Packed (gnat_entity)
2782 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2784 : (Known_Alignment (gnat_entity)
2785 || (Strict_Alignment (gnat_entity)
2786 && Known_RM_Size (gnat_entity)))
2789 bool has_discr = Has_Discriminants (gnat_entity);
2790 bool has_rep = Has_Specified_Layout (gnat_entity);
2791 bool all_rep = has_rep;
2793 = (Is_Tagged_Type (gnat_entity)
2794 && Nkind (record_definition) == N_Derived_Type_Definition);
2795 bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2797 /* See if all fields have a rep clause. Stop when we find one
2800 for (gnat_field = First_Entity (gnat_entity);
2801 Present (gnat_field);
2802 gnat_field = Next_Entity (gnat_field))
2803 if ((Ekind (gnat_field) == E_Component
2804 || Ekind (gnat_field) == E_Discriminant)
2805 && No (Component_Clause (gnat_field)))
2811 /* If this is a record extension, go a level further to find the
2812 record definition. Also, verify we have a Parent_Subtype. */
2815 if (!type_annotate_only
2816 || Present (Record_Extension_Part (record_definition)))
2817 record_definition = Record_Extension_Part (record_definition);
2819 gcc_assert (type_annotate_only
2820 || Present (Parent_Subtype (gnat_entity)));
2823 /* Make a node for the record. If we are not defining the record,
2824 suppress expanding incomplete types. */
2825 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2826 TYPE_NAME (gnu_type) = gnu_entity_name;
2827 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2831 defer_incomplete_level++;
2832 this_deferred = true;
2835 /* If both a size and rep clause was specified, put the size in
2836 the record type now so that it can get the proper mode. */
2837 if (has_rep && Known_RM_Size (gnat_entity))
2838 TYPE_SIZE (gnu_type)
2839 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
2841 /* Always set the alignment here so that it can be used to
2842 set the mode, if it is making the alignment stricter. If
2843 it is invalid, it will be checked again below. If this is to
2844 be Atomic, choose a default alignment of a word unless we know
2845 the size and it's smaller. */
2846 if (Known_Alignment (gnat_entity))
2847 TYPE_ALIGN (gnu_type)
2848 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2849 else if (Is_Atomic (gnat_entity))
2850 TYPE_ALIGN (gnu_type)
2851 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2852 /* If a type needs strict alignment, the minimum size will be the
2853 type size instead of the RM size (see validate_size). Cap the
2854 alignment, lest it causes this type size to become too large. */
2855 else if (Strict_Alignment (gnat_entity)
2856 && Known_RM_Size (gnat_entity))
2858 unsigned int raw_size = UI_To_Int (RM_Size (gnat_entity));
2859 unsigned int raw_align = raw_size & -raw_size;
2860 if (raw_align < BIGGEST_ALIGNMENT)
2861 TYPE_ALIGN (gnu_type) = raw_align;
2864 TYPE_ALIGN (gnu_type) = 0;
2866 /* If we have a Parent_Subtype, make a field for the parent. If
2867 this record has rep clauses, force the position to zero. */
2868 if (Present (Parent_Subtype (gnat_entity)))
2870 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2873 /* A major complexity here is that the parent subtype will
2874 reference our discriminants in its Discriminant_Constraint
2875 list. But those must reference the parent component of this
2876 record which is of the parent subtype we have not built yet!
2877 To break the circle we first build a dummy COMPONENT_REF which
2878 represents the "get to the parent" operation and initialize
2879 each of those discriminants to a COMPONENT_REF of the above
2880 dummy parent referencing the corresponding discriminant of the
2881 base type of the parent subtype. */
2882 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2883 build0 (PLACEHOLDER_EXPR, gnu_type),
2884 build_decl (input_location,
2885 FIELD_DECL, NULL_TREE,
2890 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2891 Present (gnat_field);
2892 gnat_field = Next_Stored_Discriminant (gnat_field))
2893 if (Present (Corresponding_Discriminant (gnat_field)))
2896 = gnat_to_gnu_field_decl (Corresponding_Discriminant
2900 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2901 gnu_get_parent, gnu_field, NULL_TREE),
2905 /* Then we build the parent subtype. If it has discriminants but
2906 the type itself has unknown discriminants, this means that it
2907 doesn't contain information about how the discriminants are
2908 derived from those of the ancestor type, so it cannot be used
2909 directly. Instead it is built by cloning the parent subtype
2910 of the underlying record view of the type, for which the above
2911 derivation of discriminants has been made explicit. */
2912 if (Has_Discriminants (gnat_parent)
2913 && Has_Unknown_Discriminants (gnat_entity))
2915 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
2917 /* If we are defining the type, the underlying record
2918 view must already have been elaborated at this point.
2919 Otherwise do it now as its parent subtype cannot be
2920 technically elaborated on its own. */
2922 gcc_assert (present_gnu_tree (gnat_uview));
2924 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
2926 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
2928 /* Substitute the "get to the parent" of the type for that
2929 of its underlying record view in the cloned type. */
2930 for (gnat_field = First_Stored_Discriminant (gnat_uview);
2931 Present (gnat_field);
2932 gnat_field = Next_Stored_Discriminant (gnat_field))
2933 if (Present (Corresponding_Discriminant (gnat_field)))
2935 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
2937 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2938 gnu_get_parent, gnu_field, NULL_TREE);
2940 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
2944 gnu_parent = gnat_to_gnu_type (gnat_parent);
2946 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2947 initially built. The discriminants must reference the fields
2948 of the parent subtype and not those of its base type for the
2949 placeholder machinery to properly work. */
2952 /* The actual parent subtype is the full view. */
2953 if (IN (Ekind (gnat_parent), Private_Kind))
2955 if (Present (Full_View (gnat_parent)))
2956 gnat_parent = Full_View (gnat_parent);
2958 gnat_parent = Underlying_Full_View (gnat_parent);
2961 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2962 Present (gnat_field);
2963 gnat_field = Next_Stored_Discriminant (gnat_field))
2964 if (Present (Corresponding_Discriminant (gnat_field)))
2966 Entity_Id field = Empty;
2967 for (field = First_Stored_Discriminant (gnat_parent);
2969 field = Next_Stored_Discriminant (field))
2970 if (same_discriminant_p (gnat_field, field))
2972 gcc_assert (Present (field));
2973 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2974 = gnat_to_gnu_field_decl (field);
2978 /* The "get to the parent" COMPONENT_REF must be given its
2980 TREE_TYPE (gnu_get_parent) = gnu_parent;
2982 /* ...and reference the _Parent field of this record. */
2984 = create_field_decl (parent_name_id,
2985 gnu_parent, gnu_type,
2987 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
2989 ? bitsize_zero_node : NULL_TREE,
2991 DECL_INTERNAL_P (gnu_field) = 1;
2992 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
2993 TYPE_FIELDS (gnu_type) = gnu_field;
2996 /* Make the fields for the discriminants and put them into the record
2997 unless it's an Unchecked_Union. */
2999 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3000 Present (gnat_field);
3001 gnat_field = Next_Stored_Discriminant (gnat_field))
3003 /* If this is a record extension and this discriminant is the
3004 renaming of another discriminant, we've handled it above. */
3005 if (Present (Parent_Subtype (gnat_entity))
3006 && Present (Corresponding_Discriminant (gnat_field)))
3010 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
3013 /* Make an expression using a PLACEHOLDER_EXPR from the
3014 FIELD_DECL node just created and link that with the
3015 corresponding GNAT defining identifier. */
3016 save_gnu_tree (gnat_field,
3017 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3018 build0 (PLACEHOLDER_EXPR, gnu_type),
3019 gnu_field, NULL_TREE),
3022 if (!is_unchecked_union)
3024 DECL_CHAIN (gnu_field) = gnu_field_list;
3025 gnu_field_list = gnu_field;
3029 /* Add the fields into the record type and finish it up. */
3030 components_to_record (gnu_type, Component_List (record_definition),
3031 gnu_field_list, packed, definition, false,
3032 all_rep, is_unchecked_union, debug_info_p,
3033 false, OK_To_Reorder_Components (gnat_entity),
3036 /* If it is passed by reference, force BLKmode to ensure that objects
3037 of this type will always be put in memory. */
3038 if (Is_By_Reference_Type (gnat_entity))
3039 SET_TYPE_MODE (gnu_type, BLKmode);
3041 /* We used to remove the associations of the discriminants and _Parent
3042 for validity checking but we may need them if there's a Freeze_Node
3043 for a subtype used in this record. */
3044 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3046 /* Fill in locations of fields. */
3047 annotate_rep (gnat_entity, gnu_type);
3049 /* If there are any entities in the chain corresponding to components
3050 that we did not elaborate, ensure we elaborate their types if they
3052 for (gnat_temp = First_Entity (gnat_entity);
3053 Present (gnat_temp);
3054 gnat_temp = Next_Entity (gnat_temp))
3055 if ((Ekind (gnat_temp) == E_Component
3056 || Ekind (gnat_temp) == E_Discriminant)
3057 && Is_Itype (Etype (gnat_temp))
3058 && !present_gnu_tree (gnat_temp))
3059 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3061 /* If this is a record type associated with an exception definition,
3062 equate its fields to those of the standard exception type. This
3063 will make it possible to convert between them. */
3064 if (gnu_entity_name == exception_data_name_id)
3067 for (gnu_field = TYPE_FIELDS (gnu_type),
3068 gnu_std_field = TYPE_FIELDS (except_type_node);
3070 gnu_field = DECL_CHAIN (gnu_field),
3071 gnu_std_field = DECL_CHAIN (gnu_std_field))
3072 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
3073 gcc_assert (!gnu_std_field);
3078 case E_Class_Wide_Subtype:
3079 /* If an equivalent type is present, that is what we should use.
3080 Otherwise, fall through to handle this like a record subtype
3081 since it may have constraints. */
3082 if (gnat_equiv_type != gnat_entity)
3084 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
3085 maybe_present = true;
3089 /* ... fall through ... */
3091 case E_Record_Subtype:
3092 /* If Cloned_Subtype is Present it means this record subtype has
3093 identical layout to that type or subtype and we should use
3094 that GCC type for this one. The front end guarantees that
3095 the component list is shared. */
3096 if (Present (Cloned_Subtype (gnat_entity)))
3098 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
3100 maybe_present = true;
3104 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3105 changing the type, make a new type with each field having the type of
3106 the field in the new subtype but the position computed by transforming
3107 every discriminant reference according to the constraints. We don't
3108 see any difference between private and non-private type here since
3109 derivations from types should have been deferred until the completion
3110 of the private type. */
3113 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
3118 defer_incomplete_level++;
3119 this_deferred = true;
3122 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
3124 if (present_gnu_tree (gnat_entity))
3126 maybe_present = true;
3130 /* If this is a record subtype associated with a dispatch table,
3131 strip the suffix. This is necessary to make sure 2 different
3132 subtypes associated with the imported and exported views of a
3133 dispatch table are properly merged in LTO mode. */
3134 if (Is_Dispatch_Table_Entity (gnat_entity))
3137 Get_Encoded_Name (gnat_entity);
3138 p = strchr (Name_Buffer, '_');
3140 strcpy (p+2, "dtS");
3141 gnu_entity_name = get_identifier (Name_Buffer);
3144 /* When the subtype has discriminants and these discriminants affect
3145 the initial shape it has inherited, factor them in. But for an
3146 Unchecked_Union (it must be an Itype), just return the type.
3147 We can't just test Is_Constrained because private subtypes without
3148 discriminants of types with discriminants with default expressions
3149 are Is_Constrained but aren't constrained! */
3150 if (IN (Ekind (gnat_base_type), Record_Kind)
3151 && !Is_Unchecked_Union (gnat_base_type)
3152 && !Is_For_Access_Subtype (gnat_entity)
3153 && Is_Constrained (gnat_entity)
3154 && Has_Discriminants (gnat_entity)
3155 && Present (Discriminant_Constraint (gnat_entity))
3156 && Stored_Constraint (gnat_entity) != No_Elist)
3158 VEC(subst_pair,heap) *gnu_subst_list
3159 = build_subst_list (gnat_entity, gnat_base_type, definition);
3160 tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
3161 tree gnu_pos_list, gnu_field_list = NULL_TREE;
3162 bool selected_variant = false;
3163 Entity_Id gnat_field;
3164 VEC(variant_desc,heap) *gnu_variant_list;
3166 gnu_type = make_node (RECORD_TYPE);
3167 TYPE_NAME (gnu_type) = gnu_entity_name;
3169 /* Set the size, alignment and alias set of the new type to
3170 match that of the old one, doing required substitutions. */
3171 copy_and_substitute_in_size (gnu_type, gnu_base_type,
3174 if (TYPE_IS_PADDING_P (gnu_base_type))
3175 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3177 gnu_unpad_base_type = gnu_base_type;
3179 /* Look for a REP part in the base type. */
3180 gnu_rep_part = get_rep_part (gnu_unpad_base_type);
3182 /* Look for a variant part in the base type. */
3183 gnu_variant_part = get_variant_part (gnu_unpad_base_type);
3185 /* If there is a variant part, we must compute whether the
3186 constraints statically select a particular variant. If
3187 so, we simply drop the qualified union and flatten the
3188 list of fields. Otherwise we'll build a new qualified
3189 union for the variants that are still relevant. */
3190 if (gnu_variant_part)
3196 = build_variant_list (TREE_TYPE (gnu_variant_part),
3197 gnu_subst_list, NULL);
3199 /* If all the qualifiers are unconditionally true, the
3200 innermost variant is statically selected. */
3201 selected_variant = true;
3202 FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
3204 if (!integer_onep (v->qual))
3206 selected_variant = false;
3210 /* Otherwise, create the new variants. */
3211 if (!selected_variant)
3212 FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
3215 tree old_variant = v->type;
3216 tree new_variant = make_node (RECORD_TYPE);
3217 TYPE_NAME (new_variant)
3218 = DECL_NAME (TYPE_NAME (old_variant));
3219 copy_and_substitute_in_size (new_variant, old_variant,
3221 v->record = new_variant;
3226 gnu_variant_list = NULL;
3227 selected_variant = false;
3231 = build_position_list (gnu_unpad_base_type,
3232 gnu_variant_list && !selected_variant,
3233 size_zero_node, bitsize_zero_node,
3234 BIGGEST_ALIGNMENT, NULL_TREE);
3236 for (gnat_field = First_Entity (gnat_entity);
3237 Present (gnat_field);
3238 gnat_field = Next_Entity (gnat_field))
3239 if ((Ekind (gnat_field) == E_Component
3240 || Ekind (gnat_field) == E_Discriminant)
3241 && !(Present (Corresponding_Discriminant (gnat_field))
3242 && Is_Tagged_Type (gnat_base_type))
3243 && Underlying_Type (Scope (Original_Record_Component
3247 Name_Id gnat_name = Chars (gnat_field);
3248 Entity_Id gnat_old_field
3249 = Original_Record_Component (gnat_field);
3251 = gnat_to_gnu_field_decl (gnat_old_field);
3252 tree gnu_context = DECL_CONTEXT (gnu_old_field);
3253 tree gnu_field, gnu_field_type, gnu_size;
3254 tree gnu_cont_type, gnu_last = NULL_TREE;
3256 /* If the type is the same, retrieve the GCC type from the
3257 old field to take into account possible adjustments. */
3258 if (Etype (gnat_field) == Etype (gnat_old_field))
3259 gnu_field_type = TREE_TYPE (gnu_old_field);
3261 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3263 /* If there was a component clause, the field types must be
3264 the same for the type and subtype, so copy the data from
3265 the old field to avoid recomputation here. Also if the
3266 field is justified modular and the optimization in
3267 gnat_to_gnu_field was applied. */
3268 if (Present (Component_Clause (gnat_old_field))
3269 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3270 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3271 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3272 == TREE_TYPE (gnu_old_field)))
3274 gnu_size = DECL_SIZE (gnu_old_field);
3275 gnu_field_type = TREE_TYPE (gnu_old_field);
3278 /* If the old field was packed and of constant size, we
3279 have to get the old size here, as it might differ from
3280 what the Etype conveys and the latter might overlap
3281 onto the following field. Try to arrange the type for
3282 possible better packing along the way. */
3283 else if (DECL_PACKED (gnu_old_field)
3284 && TREE_CODE (DECL_SIZE (gnu_old_field))
3287 gnu_size = DECL_SIZE (gnu_old_field);
3288 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
3289 && !TYPE_FAT_POINTER_P (gnu_field_type)
3290 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3292 = make_packable_type (gnu_field_type, true);
3296 gnu_size = TYPE_SIZE (gnu_field_type);
3298 /* If the context of the old field is the base type or its
3299 REP part (if any), put the field directly in the new
3300 type; otherwise look up the context in the variant list
3301 and put the field either in the new type if there is a
3302 selected variant or in one of the new variants. */
3303 if (gnu_context == gnu_unpad_base_type
3305 && gnu_context == TREE_TYPE (gnu_rep_part)))
3306 gnu_cont_type = gnu_type;
3313 FOR_EACH_VEC_ELT_REVERSE (variant_desc,
3314 gnu_variant_list, ix, v)
3315 if (v->type == gnu_context)
3322 if (selected_variant)
3323 gnu_cont_type = gnu_type;
3325 gnu_cont_type = v->record;
3328 /* The front-end may pass us "ghost" components if
3329 it fails to recognize that a constrained subtype
3330 is statically constrained. Discard them. */
3334 /* Now create the new field modeled on the old one. */
3336 = create_field_decl_from (gnu_old_field, gnu_field_type,
3337 gnu_cont_type, gnu_size,
3338 gnu_pos_list, gnu_subst_list);
3340 /* Put it in one of the new variants directly. */
3341 if (gnu_cont_type != gnu_type)
3343 DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3344 TYPE_FIELDS (gnu_cont_type) = gnu_field;
3347 /* To match the layout crafted in components_to_record,
3348 if this is the _Tag or _Parent field, put it before
3349 any other fields. */
3350 else if (gnat_name == Name_uTag
3351 || gnat_name == Name_uParent)
3352 gnu_field_list = chainon (gnu_field_list, gnu_field);
3354 /* Similarly, if this is the _Controller field, put
3355 it before the other fields except for the _Tag or
3357 else if (gnat_name == Name_uController && gnu_last)
3359 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
3360 DECL_CHAIN (gnu_last) = gnu_field;
3363 /* Otherwise, if this is a regular field, put it after
3364 the other fields. */
3367 DECL_CHAIN (gnu_field) = gnu_field_list;
3368 gnu_field_list = gnu_field;
3370 gnu_last = gnu_field;
3373 save_gnu_tree (gnat_field, gnu_field, false);
3376 /* If there is a variant list and no selected variant, we need
3377 to create the nest of variant parts from the old nest. */
3378 if (gnu_variant_list && !selected_variant)
3380 tree new_variant_part
3381 = create_variant_part_from (gnu_variant_part,
3382 gnu_variant_list, gnu_type,
3383 gnu_pos_list, gnu_subst_list);
3384 DECL_CHAIN (new_variant_part) = gnu_field_list;
3385 gnu_field_list = new_variant_part;
3388 /* Now go through the entities again looking for Itypes that
3389 we have not elaborated but should (e.g., Etypes of fields
3390 that have Original_Components). */
3391 for (gnat_field = First_Entity (gnat_entity);
3392 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3393 if ((Ekind (gnat_field) == E_Discriminant
3394 || Ekind (gnat_field) == E_Component)
3395 && !present_gnu_tree (Etype (gnat_field)))
3396 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3398 /* Do not emit debug info for the type yet since we're going to
3400 gnu_field_list = nreverse (gnu_field_list);
3401 finish_record_type (gnu_type, gnu_field_list, 2, false);
3403 /* See the E_Record_Type case for the rationale. */
3404 if (Is_By_Reference_Type (gnat_entity))
3405 SET_TYPE_MODE (gnu_type, BLKmode);
3407 compute_record_mode (gnu_type);
3409 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3411 /* Fill in locations of fields. */
3412 annotate_rep (gnat_entity, gnu_type);
3414 /* If debugging information is being written for the type, write
3415 a record that shows what we are a subtype of and also make a
3416 variable that indicates our size, if still variable. */
3419 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3420 tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type);
3421 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3423 if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL)
3424 gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name);
3426 TYPE_NAME (gnu_subtype_marker)
3427 = create_concat_name (gnat_entity, "XVS");
3428 finish_record_type (gnu_subtype_marker,
3429 create_field_decl (gnu_unpad_base_name,
3430 build_reference_type
3431 (gnu_unpad_base_type),
3433 NULL_TREE, NULL_TREE,
3437 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3438 gnu_subtype_marker);
3441 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3442 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3443 TYPE_SIZE_UNIT (gnu_subtype_marker)
3444 = create_var_decl (create_concat_name (gnat_entity,
3446 NULL_TREE, sizetype, gnu_size_unit,
3447 false, false, false, false, NULL,
3451 VEC_free (variant_desc, heap, gnu_variant_list);
3452 VEC_free (subst_pair, heap, gnu_subst_list);
3454 /* Now we can finalize it. */
3455 rest_of_record_type_compilation (gnu_type);
3458 /* Otherwise, go down all the components in the new type and make
3459 them equivalent to those in the base type. */
3462 gnu_type = gnu_base_type;
3464 for (gnat_temp = First_Entity (gnat_entity);
3465 Present (gnat_temp);
3466 gnat_temp = Next_Entity (gnat_temp))
3467 if ((Ekind (gnat_temp) == E_Discriminant
3468 && !Is_Unchecked_Union (gnat_base_type))
3469 || Ekind (gnat_temp) == E_Component)
3470 save_gnu_tree (gnat_temp,
3471 gnat_to_gnu_field_decl
3472 (Original_Record_Component (gnat_temp)),
3478 case E_Access_Subprogram_Type:
3479 /* Use the special descriptor type for dispatch tables if needed,
3480 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3481 Note that we are only required to do so for static tables in
3482 order to be compatible with the C++ ABI, but Ada 2005 allows
3483 to extend library level tagged types at the local level so
3484 we do it in the non-static case as well. */
3485 if (TARGET_VTABLE_USES_DESCRIPTORS
3486 && Is_Dispatch_Table_Entity (gnat_entity))
3488 gnu_type = fdesc_type_node;
3489 gnu_size = TYPE_SIZE (gnu_type);
3493 /* ... fall through ... */
3495 case E_Anonymous_Access_Subprogram_Type:
3496 /* If we are not defining this entity, and we have incomplete
3497 entities being processed above us, make a dummy type and
3498 fill it in later. */
3499 if (!definition && defer_incomplete_level != 0)
3501 struct incomplete *p
3502 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3505 = build_pointer_type
3506 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3507 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3508 !Comes_From_Source (gnat_entity),
3509 debug_info_p, gnat_entity);
3510 this_made_decl = true;
3511 gnu_type = TREE_TYPE (gnu_decl);
3512 save_gnu_tree (gnat_entity, gnu_decl, false);
3515 p->old_type = TREE_TYPE (gnu_type);
3516 p->full_type = Directly_Designated_Type (gnat_entity);
3517 p->next = defer_incomplete_list;
3518 defer_incomplete_list = p;
3522 /* ... fall through ... */
3524 case E_Allocator_Type:
3526 case E_Access_Attribute_Type:
3527 case E_Anonymous_Access_Type:
3528 case E_General_Access_Type:
3530 /* The designated type and its equivalent type for gigi. */
3531 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3532 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3533 /* Whether it comes from a limited with. */
3534 bool is_from_limited_with
3535 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3536 && From_With_Type (gnat_desig_equiv));
3537 /* The "full view" of the designated type. If this is an incomplete
3538 entity from a limited with, treat its non-limited view as the full
3539 view. Otherwise, if this is an incomplete or private type, use the
3540 full view. In the former case, we might point to a private type,
3541 in which case, we need its full view. Also, we want to look at the
3542 actual type used for the representation, so this takes a total of
3544 Entity_Id gnat_desig_full_direct_first
3545 = (is_from_limited_with
3546 ? Non_Limited_View (gnat_desig_equiv)
3547 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3548 ? Full_View (gnat_desig_equiv) : Empty));
3549 Entity_Id gnat_desig_full_direct
3550 = ((is_from_limited_with
3551 && Present (gnat_desig_full_direct_first)
3552 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3553 ? Full_View (gnat_desig_full_direct_first)
3554 : gnat_desig_full_direct_first);
3555 Entity_Id gnat_desig_full
3556 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3557 /* The type actually used to represent the designated type, either
3558 gnat_desig_full or gnat_desig_equiv. */
3559 Entity_Id gnat_desig_rep;
3560 /* True if this is a pointer to an unconstrained array. */
3561 bool is_unconstrained_array;
3562 /* We want to know if we'll be seeing the freeze node for any
3563 incomplete type we may be pointing to. */
3565 = (Present (gnat_desig_full)
3566 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3567 : In_Extended_Main_Code_Unit (gnat_desig_type));
3568 /* True if we make a dummy type here. */
3569 bool made_dummy = false;
3570 /* The mode to be used for the pointer type. */
3571 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3572 /* The GCC type used for the designated type. */
3573 tree gnu_desig_type = NULL_TREE;
3575 if (!targetm.valid_pointer_mode (p_mode))
3578 /* If either the designated type or its full view is an unconstrained
3579 array subtype, replace it with the type it's a subtype of. This
3580 avoids problems with multiple copies of unconstrained array types.
3581 Likewise, if the designated type is a subtype of an incomplete
3582 record type, use the parent type to avoid order of elaboration
3583 issues. This can lose some code efficiency, but there is no
3585 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3586 && !Is_Constrained (gnat_desig_equiv))
3587 gnat_desig_equiv = Etype (gnat_desig_equiv);
3588 if (Present (gnat_desig_full)
3589 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3590 && !Is_Constrained (gnat_desig_full))
3591 || (Ekind (gnat_desig_full) == E_Record_Subtype
3592 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3593 gnat_desig_full = Etype (gnat_desig_full);
3595 /* Set the type that's actually the representation of the designated
3596 type and also flag whether we have a unconstrained array. */
3598 = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
3599 is_unconstrained_array
3600 = Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep);
3602 /* If we are pointing to an incomplete type whose completion is an
3603 unconstrained array, make dummy fat and thin pointer types to it.
3604 Likewise if the type itself is dummy or an unconstrained array. */
3605 if (is_unconstrained_array
3606 && (Present (gnat_desig_full)
3607 || (present_gnu_tree (gnat_desig_equiv)
3609 (TREE_TYPE (get_gnu_tree (gnat_desig_equiv))))
3611 && defer_incomplete_level != 0
3612 && !present_gnu_tree (gnat_desig_equiv))
3614 && is_from_limited_with
3615 && Present (Freeze_Node (gnat_desig_equiv)))))
3617 if (present_gnu_tree (gnat_desig_rep))
3618 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
3621 gnu_desig_type = make_dummy_type (gnat_desig_rep);
3625 /* If the call above got something that has a pointer, the pointer
3626 is our type. This could have happened either because the type
3627 was elaborated or because somebody else executed the code. */
3628 if (!TYPE_POINTER_TO (gnu_desig_type))
3629 build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
3630 gnu_type = TYPE_POINTER_TO (gnu_desig_type);
3633 /* If we already know what the full type is, use it. */
3634 else if (Present (gnat_desig_full)
3635 && present_gnu_tree (gnat_desig_full))
3636 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3638 /* Get the type of the thing we are to point to and build a pointer to
3639 it. If it is a reference to an incomplete or private type with a
3640 full view that is a record, make a dummy type node and get the
3641 actual type later when we have verified it is safe. */
3642 else if ((!in_main_unit
3643 && !present_gnu_tree (gnat_desig_equiv)
3644 && Present (gnat_desig_full)
3645 && !present_gnu_tree (gnat_desig_full)
3646 && Is_Record_Type (gnat_desig_full))
3647 /* Likewise if we are pointing to a record or array and we are
3648 to defer elaborating incomplete types. We do this as this
3649 access type may be the full view of a private type. Note
3650 that the unconstrained array case is handled above. */
3651 || ((!in_main_unit || imported_p)
3652 && defer_incomplete_level != 0
3653 && !present_gnu_tree (gnat_desig_equiv)
3654 && (Is_Record_Type (gnat_desig_rep)
3655 || Is_Array_Type (gnat_desig_rep)))
3656 /* If this is a reference from a limited_with type back to our
3657 main unit and there's a freeze node for it, either we have
3658 already processed the declaration and made the dummy type,
3659 in which case we just reuse the latter, or we have not yet,
3660 in which case we make the dummy type and it will be reused
3661 when the declaration is finally processed. In both cases,
3662 the pointer eventually created below will be automatically
3663 adjusted when the freeze node is processed. Note that the
3664 unconstrained array case is handled above. */
3666 && is_from_limited_with
3667 && Present (Freeze_Node (gnat_desig_rep))))
3669 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3673 /* Otherwise handle the case of a pointer to itself. */
3674 else if (gnat_desig_equiv == gnat_entity)
3677 = build_pointer_type_for_mode (void_type_node, p_mode,
3678 No_Strict_Aliasing (gnat_entity));
3679 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3682 /* If expansion is disabled, the equivalent type of a concurrent type
3683 is absent, so build a dummy pointer type. */
3684 else if (type_annotate_only && No (gnat_desig_equiv))
3685 gnu_type = ptr_void_type_node;
3687 /* Finally, handle the default case where we can just elaborate our
3690 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3692 /* It is possible that a call to gnat_to_gnu_type above resolved our
3693 type. If so, just return it. */
3694 if (present_gnu_tree (gnat_entity))
3696 maybe_present = true;
3700 /* If we have not done it yet, build the pointer type the usual way. */
3703 /* Modify the designated type if we are pointing only to constant
3704 objects, but don't do it for unconstrained arrays. */
3705 if (Is_Access_Constant (gnat_entity)
3706 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3709 = build_qualified_type
3711 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3713 /* Some extra processing is required if we are building a
3714 pointer to an incomplete type (in the GCC sense). We might
3715 have such a type if we just made a dummy, or directly out
3716 of the call to gnat_to_gnu_type above if we are processing
3717 an access type for a record component designating the
3718 record type itself. */
3719 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3721 /* We must ensure that the pointer to variant we make will
3722 be processed by update_pointer_to when the initial type
3723 is completed. Pretend we made a dummy and let further
3724 processing act as usual. */
3727 /* We must ensure that update_pointer_to will not retrieve
3728 the dummy variant when building a properly qualified
3729 version of the complete type. We take advantage of the
3730 fact that get_qualified_type is requiring TYPE_NAMEs to
3731 match to influence build_qualified_type and then also
3732 update_pointer_to here. */
3733 TYPE_NAME (gnu_desig_type)
3734 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3739 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3740 No_Strict_Aliasing (gnat_entity));
3743 /* If we are not defining this object and we have made a dummy pointer,
3744 save our current definition, evaluate the actual type, and replace
3745 the tentative type we made with the actual one. If we are to defer
3746 actually looking up the actual type, make an entry in the deferred
3747 list. If this is from a limited with, we may have to defer to the
3748 end of the current unit. */
3749 if ((!in_main_unit || is_from_limited_with) && made_dummy)
3751 tree gnu_old_desig_type;
3753 if (TYPE_IS_FAT_POINTER_P (gnu_type))
3755 gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
3756 if (esize == POINTER_SIZE)
3757 gnu_type = build_pointer_type
3758 (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
3761 gnu_old_desig_type = TREE_TYPE (gnu_type);
3763 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3764 !Comes_From_Source (gnat_entity),
3765 debug_info_p, gnat_entity);
3766 this_made_decl = true;
3767 gnu_type = TREE_TYPE (gnu_decl);
3768 save_gnu_tree (gnat_entity, gnu_decl, false);
3771 /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
3772 update gnu_old_desig_type directly, in which case it will not be
3773 a dummy type any more when we get into update_pointer_to.
3775 This can happen e.g. when the designated type is a record type,
3776 because their elaboration starts with an initial node from
3777 make_dummy_type, which may be the same node as the one we got.
3779 Besides, variants of this non-dummy type might have been created
3780 along the way. update_pointer_to is expected to properly take
3781 care of those situations. */
3782 if (defer_incomplete_level == 0 && !is_from_limited_with)
3784 defer_finalize_level++;
3785 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
3786 gnat_to_gnu_type (gnat_desig_equiv));
3787 defer_finalize_level--;
3791 struct incomplete *p = XNEW (struct incomplete);
3792 struct incomplete **head
3793 = (is_from_limited_with
3794 ? &defer_limited_with : &defer_incomplete_list);
3795 p->old_type = gnu_old_desig_type;
3796 p->full_type = gnat_desig_equiv;
3804 case E_Access_Protected_Subprogram_Type:
3805 case E_Anonymous_Access_Protected_Subprogram_Type:
3806 if (type_annotate_only && No (gnat_equiv_type))
3807 gnu_type = ptr_void_type_node;
3810 /* The run-time representation is the equivalent type. */
3811 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3812 maybe_present = true;
3815 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3816 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3817 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3818 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3819 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3824 case E_Access_Subtype:
3826 /* We treat this as identical to its base type; any constraint is
3827 meaningful only to the front end.
3829 The designated type must be elaborated as well, if it does
3830 not have its own freeze node. Designated (sub)types created
3831 for constrained components of records with discriminants are
3832 not frozen by the front end and thus not elaborated by gigi,
3833 because their use may appear before the base type is frozen,
3834 and because it is not clear that they are needed anywhere in
3835 Gigi. With the current model, there is no correct place where
3836 they could be elaborated. */
3838 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3839 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3840 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3841 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3842 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3844 /* If we are not defining this entity, and we have incomplete
3845 entities being processed above us, make a dummy type and
3846 elaborate it later. */
3847 if (!definition && defer_incomplete_level != 0)
3849 struct incomplete *p
3850 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3852 = build_pointer_type
3853 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3855 p->old_type = TREE_TYPE (gnu_ptr_type);
3856 p->full_type = Directly_Designated_Type (gnat_entity);
3857 p->next = defer_incomplete_list;
3858 defer_incomplete_list = p;
3860 else if (!IN (Ekind (Base_Type
3861 (Directly_Designated_Type (gnat_entity))),
3862 Incomplete_Or_Private_Kind))
3863 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3867 maybe_present = true;
3870 /* Subprogram Entities
3872 The following access functions are defined for subprograms:
3874 Etype Return type or Standard_Void_Type.
3875 First_Formal The first formal parameter.
3876 Is_Imported Indicates that the subprogram has appeared in
3877 an INTERFACE or IMPORT pragma. For now we
3878 assume that the external language is C.
3879 Is_Exported Likewise but for an EXPORT pragma.
3880 Is_Inlined True if the subprogram is to be inlined.
3882 Each parameter is first checked by calling must_pass_by_ref on its
3883 type to determine if it is passed by reference. For parameters which
3884 are copied in, if they are Ada In Out or Out parameters, their return
3885 value becomes part of a record which becomes the return type of the
3886 function (C function - note that this applies only to Ada procedures
3887 so there is no Ada return type). Additional code to store back the
3888 parameters will be generated on the caller side. This transformation
3889 is done here, not in the front-end.
3891 The intended result of the transformation can be seen from the
3892 equivalent source rewritings that follow:
3894 struct temp {int a,b};
3895 procedure P (A,B: In Out ...) is temp P (int A,B)
3898 end P; return {A,B};
3905 For subprogram types we need to perform mainly the same conversions to
3906 GCC form that are needed for procedures and function declarations. The
3907 only difference is that at the end, we make a type declaration instead
3908 of a function declaration. */
3910 case E_Subprogram_Type:
3914 /* The type returned by a function or else Standard_Void_Type for a
3916 Entity_Id gnat_return_type = Etype (gnat_entity);
3917 tree gnu_return_type;
3918 /* The first GCC parameter declaration (a PARM_DECL node). The
3919 PARM_DECL nodes are chained through the DECL_CHAIN field, so this
3920 actually is the head of this parameter list. */
3921 tree gnu_param_list = NULL_TREE;
3922 /* Likewise for the stub associated with an exported procedure. */
3923 tree gnu_stub_param_list = NULL_TREE;
3924 /* Non-null for subprograms containing parameters passed by copy-in
3925 copy-out (Ada In Out or Out parameters not passed by reference),
3926 in which case it is the list of nodes used to specify the values
3927 of the In Out/Out parameters that are returned as a record upon
3928 procedure return. The TREE_PURPOSE of an element of this list is
3929 a field of the record and the TREE_VALUE is the PARM_DECL
3930 corresponding to that field. This list will be saved in the
3931 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3932 tree gnu_cico_list = NULL_TREE;
3933 /* List of fields in return type of procedure with copy-in copy-out
3935 tree gnu_field_list = NULL_TREE;
3936 /* If an import pragma asks to map this subprogram to a GCC builtin,
3937 this is the builtin DECL node. */
3938 tree gnu_builtin_decl = NULL_TREE;
3939 /* For the stub associated with an exported procedure. */
3940 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3941 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3942 Entity_Id gnat_param;
3943 bool inline_flag = Is_Inlined (gnat_entity);
3944 bool public_flag = Is_Public (gnat_entity) || imported_p;
3946 = (Is_Public (gnat_entity) && !definition) || imported_p;
3947 bool artificial_flag = !Comes_From_Source (gnat_entity);
3948 /* The semantics of "pure" in Ada essentially matches that of "const"
3949 in the back-end. In particular, both properties are orthogonal to
3950 the "nothrow" property if the EH circuitry is explicit in the
3951 internal representation of the back-end. If we are to completely
3952 hide the EH circuitry from it, we need to declare that calls to pure
3953 Ada subprograms that can throw have side effects since they can
3954 trigger an "abnormal" transfer of control flow; thus they can be
3955 neither "const" nor "pure" in the back-end sense. */
3957 = (Exception_Mechanism == Back_End_Exceptions
3958 && Is_Pure (gnat_entity));
3959 bool volatile_flag = No_Return (gnat_entity);
3960 bool return_by_direct_ref_p = false;
3961 bool return_by_invisi_ref_p = false;
3962 bool return_unconstrained_p = false;
3963 bool has_stub = false;
3966 /* A parameter may refer to this type, so defer completion of any
3967 incomplete types. */
3968 if (kind == E_Subprogram_Type && !definition)
3970 defer_incomplete_level++;
3971 this_deferred = true;
3974 /* If the subprogram has an alias, it is probably inherited, so
3975 we can use the original one. If the original "subprogram"
3976 is actually an enumeration literal, it may be the first use
3977 of its type, so we must elaborate that type now. */
3978 if (Present (Alias (gnat_entity)))
3980 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3981 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3983 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0);
3985 /* Elaborate any Itypes in the parameters of this entity. */
3986 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3987 Present (gnat_temp);
3988 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3989 if (Is_Itype (Etype (gnat_temp)))
3990 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3995 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3996 corresponding DECL node. Proper generation of calls later on need
3997 proper parameter associations so we don't "break;" here. */
3998 if (Convention (gnat_entity) == Convention_Intrinsic
3999 && Present (Interface_Name (gnat_entity)))
4001 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
4003 /* Inability to find the builtin decl most often indicates a
4004 genuine mistake, but imports of unregistered intrinsics are
4005 sometimes issued on purpose to allow hooking in alternate
4006 bodies. We post a warning conditioned on Wshadow in this case,
4007 to let developers be notified on demand without risking false
4008 positives with common default sets of options. */
4010 if (gnu_builtin_decl == NULL_TREE && warn_shadow)
4011 post_error ("?gcc intrinsic not found for&!", gnat_entity);
4014 /* ??? What if we don't find the builtin node above ? warn ? err ?
4015 In the current state we neither warn nor err, and calls will just
4016 be handled as for regular subprograms. */
4018 /* Look into the return type and get its associated GCC tree. If it
4019 is not void, compute various flags for the subprogram type. */
4020 if (Ekind (gnat_return_type) == E_Void)
4021 gnu_return_type = void_type_node;
4024 gnu_return_type = gnat_to_gnu_type (gnat_return_type);
4026 /* If this function returns by reference, make the actual return
4027 type the pointer type and make a note of that. */
4028 if (Returns_By_Ref (gnat_entity))
4030 gnu_return_type = build_pointer_type (gnu_return_type);
4031 return_by_direct_ref_p = true;
4034 /* If we are supposed to return an unconstrained array type, make
4035 the actual return type the fat pointer type. */
4036 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
4038 gnu_return_type = TREE_TYPE (gnu_return_type);
4039 return_unconstrained_p = true;
4042 /* Likewise, if the return type requires a transient scope, the
4043 return value will be allocated on the secondary stack so the
4044 actual return type is the pointer type. */
4045 else if (Requires_Transient_Scope (gnat_return_type))
4047 gnu_return_type = build_pointer_type (gnu_return_type);
4048 return_unconstrained_p = true;
4051 /* If the Mechanism is By_Reference, ensure this function uses the
4052 target's by-invisible-reference mechanism, which may not be the
4053 same as above (e.g. it might be passing an extra parameter). */
4054 else if (kind == E_Function
4055 && Mechanism (gnat_entity) == By_Reference)
4056 return_by_invisi_ref_p = true;
4058 /* Likewise, if the return type is itself By_Reference. */
4059 else if (TREE_ADDRESSABLE (gnu_return_type))
4060 return_by_invisi_ref_p = true;
4062 /* If the type is a padded type and the underlying type would not
4063 be passed by reference or the function has a foreign convention,
4064 return the underlying type. */
4065 else if (TYPE_IS_PADDING_P (gnu_return_type)
4066 && (!default_pass_by_ref
4067 (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
4068 || Has_Foreign_Convention (gnat_entity)))
4069 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
4071 /* If the return type is unconstrained, that means it must have a
4072 maximum size. Use the padded type as the effective return type.
4073 And ensure the function uses the target's by-invisible-reference
4074 mechanism to avoid copying too much data when it returns. */
4075 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
4078 = maybe_pad_type (gnu_return_type,
4079 max_size (TYPE_SIZE (gnu_return_type),
4081 0, gnat_entity, false, false, false, true);
4083 /* Declare it now since it will never be declared otherwise.
4084 This is necessary to ensure that its subtrees are properly
4086 create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
4087 NULL, true, debug_info_p, gnat_entity);
4089 return_by_invisi_ref_p = true;
4092 /* If the return type has a size that overflows, we cannot have
4093 a function that returns that type. This usage doesn't make
4094 sense anyway, so give an error here. */
4095 if (TYPE_SIZE_UNIT (gnu_return_type)
4096 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
4097 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
4099 post_error ("cannot return type whose size overflows",
4101 gnu_return_type = copy_node (gnu_return_type);
4102 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
4103 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
4104 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
4105 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
4109 /* Loop over the parameters and get their associated GCC tree. While
4110 doing this, build a copy-in copy-out structure if we need one. */
4111 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
4112 Present (gnat_param);
4113 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
4115 tree gnu_param_name = get_entity_name (gnat_param);
4116 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
4117 tree gnu_param, gnu_field;
4118 bool copy_in_copy_out = false;
4119 Mechanism_Type mech = Mechanism (gnat_param);
4121 /* Builtins are expanded inline and there is no real call sequence
4122 involved. So the type expected by the underlying expander is
4123 always the type of each argument "as is". */
4124 if (gnu_builtin_decl)
4126 /* Handle the first parameter of a valued procedure specially. */
4127 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
4128 mech = By_Copy_Return;
4129 /* Otherwise, see if a Mechanism was supplied that forced this
4130 parameter to be passed one way or another. */
4131 else if (mech == Default
4132 || mech == By_Copy || mech == By_Reference)
4134 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
4135 mech = By_Descriptor;
4137 else if (By_Short_Descriptor_Last <= mech &&
4138 mech <= By_Short_Descriptor)
4139 mech = By_Short_Descriptor;
4143 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
4144 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
4145 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
4147 mech = By_Reference;
4153 post_error ("unsupported mechanism for&", gnat_param);
4158 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4159 Has_Foreign_Convention (gnat_entity),
4162 /* We are returned either a PARM_DECL or a type if no parameter
4163 needs to be passed; in either case, adjust the type. */
4164 if (DECL_P (gnu_param))
4165 gnu_param_type = TREE_TYPE (gnu_param);
4168 gnu_param_type = gnu_param;
4169 gnu_param = NULL_TREE;
4172 /* The failure of this assertion will very likely come from an
4173 order of elaboration issue for the type of the parameter. */
4174 gcc_assert (kind == E_Subprogram_Type
4175 || !TYPE_IS_DUMMY_P (gnu_param_type));
4179 /* If it's an exported subprogram, we build a parameter list
4180 in parallel, in case we need to emit a stub for it. */
4181 if (Is_Exported (gnat_entity))
4184 = chainon (gnu_param, gnu_stub_param_list);
4185 /* Change By_Descriptor parameter to By_Reference for
4186 the internal version of an exported subprogram. */
4187 if (mech == By_Descriptor || mech == By_Short_Descriptor)
4190 = gnat_to_gnu_param (gnat_param, By_Reference,
4196 gnu_param = copy_node (gnu_param);
4199 gnu_param_list = chainon (gnu_param, gnu_param_list);
4200 Sloc_to_locus (Sloc (gnat_param),
4201 &DECL_SOURCE_LOCATION (gnu_param));
4202 save_gnu_tree (gnat_param, gnu_param, false);
4204 /* If a parameter is a pointer, this function may modify
4205 memory through it and thus shouldn't be considered
4206 a const function. Also, the memory may be modified
4207 between two calls, so they can't be CSE'ed. The latter
4208 case also handles by-ref parameters. */
4209 if (POINTER_TYPE_P (gnu_param_type)
4210 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4214 if (copy_in_copy_out)
4218 tree gnu_new_ret_type = make_node (RECORD_TYPE);
4220 /* If this is a function, we also need a field for the
4221 return value to be placed. */
4222 if (TREE_CODE (gnu_return_type) != VOID_TYPE)
4225 = create_field_decl (get_identifier ("RETVAL"),
4227 gnu_new_ret_type, NULL_TREE,
4229 Sloc_to_locus (Sloc (gnat_entity),
4230 &DECL_SOURCE_LOCATION (gnu_field));
4231 gnu_field_list = gnu_field;
4233 = tree_cons (gnu_field, void_type_node, NULL_TREE);
4236 gnu_return_type = gnu_new_ret_type;
4237 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4238 /* Set a default alignment to speed up accesses. */
4239 TYPE_ALIGN (gnu_return_type)
4240 = get_mode_alignment (ptr_mode);
4244 = create_field_decl (gnu_param_name, gnu_param_type,
4245 gnu_return_type, NULL_TREE, NULL_TREE,
4247 /* Set a minimum alignment to speed up accesses. */
4248 if (DECL_ALIGN (gnu_field) < TYPE_ALIGN (gnu_return_type))
4249 DECL_ALIGN (gnu_field) = TYPE_ALIGN (gnu_return_type);
4250 Sloc_to_locus (Sloc (gnat_param),
4251 &DECL_SOURCE_LOCATION (gnu_field));
4252 DECL_CHAIN (gnu_field) = gnu_field_list;
4253 gnu_field_list = gnu_field;
4255 = tree_cons (gnu_field, gnu_param, gnu_cico_list);
4261 /* If we have a CICO list but it has only one entry, we convert
4262 this function into a function that returns this object. */
4263 if (list_length (gnu_cico_list) == 1)
4264 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
4266 /* Do not finalize the return type if the subprogram is stubbed
4267 since structures are incomplete for the back-end. */
4268 else if (Convention (gnat_entity) != Convention_Stubbed)
4270 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4273 /* Try to promote the mode of the return type if it is passed
4274 in registers, again to speed up accesses. */
4275 if (TYPE_MODE (gnu_return_type) == BLKmode
4276 && !targetm.calls.return_in_memory (gnu_return_type,
4280 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
4281 unsigned int i = BITS_PER_UNIT;
4282 enum machine_mode mode;
4286 mode = mode_for_size (i, MODE_INT, 0);
4287 if (mode != BLKmode)
4289 SET_TYPE_MODE (gnu_return_type, mode);
4290 TYPE_ALIGN (gnu_return_type)
4291 = GET_MODE_ALIGNMENT (mode);
4292 TYPE_SIZE (gnu_return_type)
4293 = bitsize_int (GET_MODE_BITSIZE (mode));
4294 TYPE_SIZE_UNIT (gnu_return_type)
4295 = size_int (GET_MODE_SIZE (mode));
4300 rest_of_record_type_compilation (gnu_return_type);
4304 if (Has_Stdcall_Convention (gnat_entity))
4305 prepend_one_attribute_to
4306 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4307 get_identifier ("stdcall"), NULL_TREE,
4310 /* If we should request stack realignment for a foreign convention
4311 subprogram, do so. Note that this applies to task entry points in
4313 if (FOREIGN_FORCE_REALIGN_STACK
4314 && Has_Foreign_Convention (gnat_entity))
4315 prepend_one_attribute_to
4316 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4317 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4320 /* The lists have been built in reverse. */
4321 gnu_param_list = nreverse (gnu_param_list);
4323 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4324 gnu_cico_list = nreverse (gnu_cico_list);
4326 if (kind == E_Function)
4327 Set_Mechanism (gnat_entity, return_unconstrained_p
4328 || return_by_direct_ref_p
4329 || return_by_invisi_ref_p
4330 ? By_Reference : By_Copy);
4332 = create_subprog_type (gnu_return_type, gnu_param_list,
4333 gnu_cico_list, return_unconstrained_p,
4334 return_by_direct_ref_p,
4335 return_by_invisi_ref_p);
4339 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4340 gnu_cico_list, return_unconstrained_p,
4341 return_by_direct_ref_p,
4342 return_by_invisi_ref_p);
4344 /* A subprogram (something that doesn't return anything) shouldn't
4345 be considered const since there would be no reason for such a
4346 subprogram. Note that procedures with Out (or In Out) parameters
4347 have already been converted into a function with a return type. */
4348 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4352 = build_qualified_type (gnu_type,
4353 TYPE_QUALS (gnu_type)
4354 | (TYPE_QUAL_CONST * const_flag)
4355 | (TYPE_QUAL_VOLATILE * volatile_flag));
4359 = build_qualified_type (gnu_stub_type,
4360 TYPE_QUALS (gnu_stub_type)
4361 | (TYPE_QUAL_CONST * const_flag)
4362 | (TYPE_QUAL_VOLATILE * volatile_flag));
4364 /* If we have a builtin decl for that function, use it. Check if the
4365 profiles are compatible and warn if they are not. The checker is
4366 expected to post extra diagnostics in this case. */
4367 if (gnu_builtin_decl)
4369 intrin_binding_t inb;
4371 inb.gnat_entity = gnat_entity;
4372 inb.ada_fntype = gnu_type;
4373 inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
4375 if (!intrin_profiles_compatible_p (&inb))
4377 ("?profile of& doesn''t match the builtin it binds!",
4380 gnu_decl = gnu_builtin_decl;
4381 gnu_type = TREE_TYPE (gnu_builtin_decl);
4385 /* If there was no specified Interface_Name and the external and
4386 internal names of the subprogram are the same, only use the
4387 internal name to allow disambiguation of nested subprograms. */
4388 if (No (Interface_Name (gnat_entity))
4389 && gnu_ext_name == gnu_entity_name)
4390 gnu_ext_name = NULL_TREE;
4392 /* If we are defining the subprogram and it has an Address clause
4393 we must get the address expression from the saved GCC tree for the
4394 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4395 the address expression here since the front-end has guaranteed
4396 in that case that the elaboration has no effects. If there is
4397 an Address clause and we are not defining the object, just
4398 make it a constant. */
4399 if (Present (Address_Clause (gnat_entity)))
4401 tree gnu_address = NULL_TREE;
4405 = (present_gnu_tree (gnat_entity)
4406 ? get_gnu_tree (gnat_entity)
4407 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4409 save_gnu_tree (gnat_entity, NULL_TREE, false);
4411 /* Convert the type of the object to a reference type that can
4412 alias everything as per 13.3(19). */
4414 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4416 gnu_address = convert (gnu_type, gnu_address);
4419 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4420 gnu_address, false, Is_Public (gnat_entity),
4421 extern_flag, false, NULL, gnat_entity);
4422 DECL_BY_REF_P (gnu_decl) = 1;
4425 else if (kind == E_Subprogram_Type)
4427 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4428 artificial_flag, debug_info_p, gnat_entity);
4433 gnu_stub_name = gnu_ext_name;
4434 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4435 public_flag = false;
4436 artificial_flag = true;
4440 = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4441 gnu_param_list, inline_flag, public_flag,
4442 extern_flag, artificial_flag, attr_list,
4447 = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4448 gnu_stub_type, gnu_stub_param_list,
4449 inline_flag, true, extern_flag,
4450 false, attr_list, gnat_entity);
4451 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4454 /* This is unrelated to the stub built right above. */
4455 DECL_STUBBED_P (gnu_decl)
4456 = Convention (gnat_entity) == Convention_Stubbed;
4461 case E_Incomplete_Type:
4462 case E_Incomplete_Subtype:
4463 case E_Private_Type:
4464 case E_Private_Subtype:
4465 case E_Limited_Private_Type:
4466 case E_Limited_Private_Subtype:
4467 case E_Record_Type_With_Private:
4468 case E_Record_Subtype_With_Private:
4470 /* Get the "full view" of this entity. If this is an incomplete
4471 entity from a limited with, treat its non-limited view as the
4472 full view. Otherwise, use either the full view or the underlying
4473 full view, whichever is present. This is used in all the tests
4476 = (IN (kind, Incomplete_Kind) && From_With_Type (gnat_entity))
4477 ? Non_Limited_View (gnat_entity)
4478 : Present (Full_View (gnat_entity))
4479 ? Full_View (gnat_entity)
4480 : Underlying_Full_View (gnat_entity);
4482 /* If this is an incomplete type with no full view, it must be a Taft
4483 Amendment type, in which case we return a dummy type. Otherwise,
4484 just get the type from its Etype. */
4487 if (kind == E_Incomplete_Type)
4489 gnu_type = make_dummy_type (gnat_entity);
4490 gnu_decl = TYPE_STUB_DECL (gnu_type);
4494 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4496 maybe_present = true;
4501 /* If we already made a type for the full view, reuse it. */
4502 else if (present_gnu_tree (full_view))
4504 gnu_decl = get_gnu_tree (full_view);
4508 /* Otherwise, if we are not defining the type now, get the type
4509 from the full view. But always get the type from the full view
4510 for define on use types, since otherwise we won't see them! */
4511 else if (!definition
4512 || (Is_Itype (full_view)
4513 && No (Freeze_Node (gnat_entity)))
4514 || (Is_Itype (gnat_entity)
4515 && No (Freeze_Node (full_view))))
4517 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4518 maybe_present = true;
4522 /* For incomplete types, make a dummy type entry which will be
4523 replaced later. Save it as the full declaration's type so
4524 we can do any needed updates when we see it. */
4525 gnu_type = make_dummy_type (gnat_entity);
4526 gnu_decl = TYPE_STUB_DECL (gnu_type);
4527 if (Has_Completion_In_Body (gnat_entity))
4528 DECL_TAFT_TYPE_P (gnu_decl) = 1;
4529 save_gnu_tree (full_view, gnu_decl, 0);
4533 case E_Class_Wide_Type:
4534 /* Class-wide types are always transformed into their root type. */
4535 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4536 maybe_present = true;
4540 case E_Task_Subtype:
4541 case E_Protected_Type:
4542 case E_Protected_Subtype:
4543 /* Concurrent types are always transformed into their record type. */
4544 if (type_annotate_only && No (gnat_equiv_type))
4545 gnu_type = void_type_node;
4547 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4548 maybe_present = true;
4552 gnu_decl = create_label_decl (gnu_entity_name);
4557 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4558 we've already saved it, so we don't try to. */
4559 gnu_decl = error_mark_node;
4567 /* If we had a case where we evaluated another type and it might have
4568 defined this one, handle it here. */
4569 if (maybe_present && present_gnu_tree (gnat_entity))
4571 gnu_decl = get_gnu_tree (gnat_entity);
4575 /* If we are processing a type and there is either no decl for it or
4576 we just made one, do some common processing for the type, such as
4577 handling alignment and possible padding. */
4578 if (is_type && (!gnu_decl || this_made_decl))
4580 /* Tell the middle-end that objects of tagged types are guaranteed to
4581 be properly aligned. This is necessary because conversions to the
4582 class-wide type are translated into conversions to the root type,
4583 which can be less aligned than some of its derived types. */
4584 if (Is_Tagged_Type (gnat_entity)
4585 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4586 TYPE_ALIGN_OK (gnu_type) = 1;
4588 /* If the type is passed by reference, objects of this type must be
4589 fully addressable and cannot be copied. */
4590 if (Is_By_Reference_Type (gnat_entity))
4591 TREE_ADDRESSABLE (gnu_type) = 1;
4593 /* ??? Don't set the size for a String_Literal since it is either
4594 confirming or we don't handle it properly (if the low bound is
4596 if (!gnu_size && kind != E_String_Literal_Subtype)
4598 Uint gnat_size = Known_Esize (gnat_entity)
4599 ? Esize (gnat_entity) : RM_Size (gnat_entity);
4601 = validate_size (gnat_size, gnu_type, gnat_entity, TYPE_DECL,
4602 false, Has_Size_Clause (gnat_entity));
4605 /* If a size was specified, see if we can make a new type of that size
4606 by rearranging the type, for example from a fat to a thin pointer. */
4610 = make_type_from_size (gnu_type, gnu_size,
4611 Has_Biased_Representation (gnat_entity));
4613 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4614 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4618 /* If the alignment hasn't already been processed and this is
4619 not an unconstrained array, see if an alignment is specified.
4620 If not, we pick a default alignment for atomic objects. */
4621 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4623 else if (Known_Alignment (gnat_entity))
4625 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4626 TYPE_ALIGN (gnu_type));
4628 /* Warn on suspiciously large alignments. This should catch
4629 errors about the (alignment,byte)/(size,bit) discrepancy. */
4630 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4634 /* If a size was specified, take it into account. Otherwise
4635 use the RM size for records as the type size has already
4636 been adjusted to the alignment. */
4639 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4640 || TREE_CODE (gnu_type) == UNION_TYPE
4641 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4642 && !TYPE_FAT_POINTER_P (gnu_type))
4643 size = rm_size (gnu_type);
4645 size = TYPE_SIZE (gnu_type);
4647 /* Consider an alignment as suspicious if the alignment/size
4648 ratio is greater or equal to the byte/bit ratio. */
4649 if (host_integerp (size, 1)
4650 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4651 post_error_ne ("?suspiciously large alignment specified for&",
4652 Expression (Alignment_Clause (gnat_entity)),
4656 else if (Is_Atomic (gnat_entity) && !gnu_size
4657 && host_integerp (TYPE_SIZE (gnu_type), 1)
4658 && integer_pow2p (TYPE_SIZE (gnu_type)))
4659 align = MIN (BIGGEST_ALIGNMENT,
4660 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4661 else if (Is_Atomic (gnat_entity) && gnu_size
4662 && host_integerp (gnu_size, 1)
4663 && integer_pow2p (gnu_size))
4664 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4666 /* See if we need to pad the type. If we did, and made a record,
4667 the name of the new type may be changed. So get it back for
4668 us when we make the new TYPE_DECL below. */
4669 if (gnu_size || align > 0)
4670 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4671 false, !gnu_decl, definition, false);
4673 if (TYPE_IS_PADDING_P (gnu_type))
4675 gnu_entity_name = TYPE_NAME (gnu_type);
4676 if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
4677 gnu_entity_name = DECL_NAME (gnu_entity_name);
4680 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4682 /* If we are at global level, GCC will have applied variable_size to
4683 the type, but that won't have done anything. So, if it's not
4684 a constant or self-referential, call elaborate_expression_1 to
4685 make a variable for the size rather than calculating it each time.
4686 Handle both the RM size and the actual size. */
4687 if (global_bindings_p ()
4688 && TYPE_SIZE (gnu_type)
4689 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4690 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4692 tree size = TYPE_SIZE (gnu_type);
4694 TYPE_SIZE (gnu_type)
4695 = elaborate_expression_1 (size, gnat_entity,
4696 get_identifier ("SIZE"),
4699 /* ??? For now, store the size as a multiple of the alignment in
4700 bytes so that we can see the alignment from the tree. */
4701 TYPE_SIZE_UNIT (gnu_type)
4702 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity,
4703 get_identifier ("SIZE_A_UNIT"),
4705 TYPE_ALIGN (gnu_type));
4707 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4708 may not be marked by the call to create_type_decl below. */
4709 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
4711 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4713 tree variant_part = get_variant_part (gnu_type);
4714 tree ada_size = TYPE_ADA_SIZE (gnu_type);
4718 tree union_type = TREE_TYPE (variant_part);
4719 tree offset = DECL_FIELD_OFFSET (variant_part);
4721 /* If the position of the variant part is constant, subtract
4722 it from the size of the type of the parent to get the new
4723 size. This manual CSE reduces the data size. */
4724 if (TREE_CODE (offset) == INTEGER_CST)
4726 tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part);
4727 TYPE_SIZE (union_type)
4728 = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type),
4729 bit_from_pos (offset, bitpos));
4730 TYPE_SIZE_UNIT (union_type)
4731 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type),
4732 byte_from_pos (offset, bitpos));
4736 TYPE_SIZE (union_type)
4737 = elaborate_expression_1 (TYPE_SIZE (union_type),
4739 get_identifier ("VSIZE"),
4742 /* ??? For now, store the size as a multiple of the
4743 alignment in bytes so that we can see the alignment
4745 TYPE_SIZE_UNIT (union_type)
4746 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type),
4751 TYPE_ALIGN (union_type));
4753 /* ??? For now, store the offset as a multiple of the
4754 alignment in bytes so that we can see the alignment
4756 DECL_FIELD_OFFSET (variant_part)
4757 = elaborate_expression_2 (offset,
4759 get_identifier ("VOFFSET"),
4765 DECL_SIZE (variant_part) = TYPE_SIZE (union_type);
4766 DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
4769 if (operand_equal_p (ada_size, size, 0))
4770 ada_size = TYPE_SIZE (gnu_type);
4773 = elaborate_expression_1 (ada_size, gnat_entity,
4774 get_identifier ("RM_SIZE"),
4776 SET_TYPE_ADA_SIZE (gnu_type, ada_size);
4780 /* If this is a record type or subtype, call elaborate_expression_1 on
4781 any field position. Do this for both global and local types.
4782 Skip any fields that we haven't made trees for to avoid problems with
4783 class wide types. */
4784 if (IN (kind, Record_Kind))
4785 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4786 gnat_temp = Next_Entity (gnat_temp))
4787 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4789 tree gnu_field = get_gnu_tree (gnat_temp);
4791 /* ??? For now, store the offset as a multiple of the alignment
4792 in bytes so that we can see the alignment from the tree. */
4793 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4795 DECL_FIELD_OFFSET (gnu_field)
4796 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
4798 get_identifier ("OFFSET"),
4800 DECL_OFFSET_ALIGN (gnu_field));
4802 /* ??? The context of gnu_field is not necessarily gnu_type
4803 so the MULT_EXPR node built above may not be marked by
4804 the call to create_type_decl below. */
4805 if (global_bindings_p ())
4806 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4810 if (Treat_As_Volatile (gnat_entity))
4812 = build_qualified_type (gnu_type,
4813 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
4815 if (Is_Atomic (gnat_entity))
4816 check_ok_for_atomic (gnu_type, gnat_entity, false);
4818 if (Present (Alignment_Clause (gnat_entity)))
4819 TYPE_USER_ALIGN (gnu_type) = 1;
4821 if (Universal_Aliasing (gnat_entity))
4822 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4825 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4826 !Comes_From_Source (gnat_entity),
4827 debug_info_p, gnat_entity);
4830 TREE_TYPE (gnu_decl) = gnu_type;
4831 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4835 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4837 gnu_type = TREE_TYPE (gnu_decl);
4839 /* If this is a derived type, relate its alias set to that of its parent
4840 to avoid troubles when a call to an inherited primitive is inlined in
4841 a context where a derived object is accessed. The inlined code works
4842 on the parent view so the resulting code may access the same object
4843 using both the parent and the derived alias sets, which thus have to
4844 conflict. As the same issue arises with component references, the
4845 parent alias set also has to conflict with composite types enclosing
4846 derived components. For instance, if we have:
4853 we want T to conflict with both D and R, in addition to R being a
4854 superset of D by record/component construction.
4856 One way to achieve this is to perform an alias set copy from the
4857 parent to the derived type. This is not quite appropriate, though,
4858 as we don't want separate derived types to conflict with each other:
4860 type I1 is new Integer;
4861 type I2 is new Integer;
4863 We want I1 and I2 to both conflict with Integer but we do not want
4864 I1 to conflict with I2, and an alias set copy on derivation would
4867 The option chosen is to make the alias set of the derived type a
4868 superset of that of its parent type. It trivially fulfills the
4869 simple requirement for the Integer derivation example above, and
4870 the component case as well by superset transitivity:
4873 R ----------> D ----------> T
4875 However, for composite types, conversions between derived types are
4876 translated into VIEW_CONVERT_EXPRs so a sequence like:
4878 type Comp1 is new Comp;
4879 type Comp2 is new Comp;
4880 procedure Proc (C : Comp1);
4888 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4890 and gimplified into:
4897 i.e. generates code involving type punning. Therefore, Comp1 needs
4898 to conflict with Comp2 and an alias set copy is required.
4900 The language rules ensure the parent type is already frozen here. */
4901 if (Is_Derived_Type (gnat_entity))
4903 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
4904 relate_alias_sets (gnu_type, gnu_parent_type,
4905 Is_Composite_Type (gnat_entity)
4906 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
4909 /* Back-annotate the Alignment of the type if not already in the
4910 tree. Likewise for sizes. */
4911 if (Unknown_Alignment (gnat_entity))
4913 unsigned int double_align, align;
4914 bool is_capped_double, align_clause;
4916 /* If the default alignment of "double" or larger scalar types is
4917 specifically capped and this is not an array with an alignment
4918 clause on the component type, return the cap. */
4919 if ((double_align = double_float_alignment) > 0)
4921 = is_double_float_or_array (gnat_entity, &align_clause);
4922 else if ((double_align = double_scalar_alignment) > 0)
4924 = is_double_scalar_or_array (gnat_entity, &align_clause);
4926 is_capped_double = align_clause = false;
4928 if (is_capped_double && !align_clause)
4929 align = double_align;
4931 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4933 Set_Alignment (gnat_entity, UI_From_Int (align));
4936 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4938 tree gnu_size = TYPE_SIZE (gnu_type);
4940 /* If the size is self-referential, annotate the maximum value. */
4941 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4942 gnu_size = max_size (gnu_size, true);
4944 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4946 /* In this mode, the tag and the parent components are not
4947 generated by the front-end so the sizes must be adjusted. */
4948 tree pointer_size = bitsize_int (POINTER_SIZE), offset;
4951 if (Is_Derived_Type (gnat_entity))
4953 offset = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
4955 Set_Alignment (gnat_entity,
4956 Alignment (Etype (Base_Type (gnat_entity))));
4959 offset = pointer_size;
4961 gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
4962 gnu_size = size_binop (MULT_EXPR, pointer_size,
4963 size_binop (CEIL_DIV_EXPR,
4966 uint_size = annotate_value (gnu_size);
4967 Set_Esize (gnat_entity, uint_size);
4968 Set_RM_Size (gnat_entity, uint_size);
4971 Set_Esize (gnat_entity, annotate_value (gnu_size));
4974 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4975 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4978 /* If we really have a ..._DECL node, set a couple of flags on it. But we
4979 cannot do so if we are reusing the ..._DECL node made for an alias or a
4980 renamed object as the predicates don't apply to it but to GNAT_ENTITY. */
4981 if (DECL_P (gnu_decl)
4982 && !Present (Alias (gnat_entity))
4983 && !(Present (Renamed_Object (gnat_entity)) && saved))
4985 if (!Comes_From_Source (gnat_entity))
4986 DECL_ARTIFICIAL (gnu_decl) = 1;
4989 DECL_IGNORED_P (gnu_decl) = 1;
4992 /* If we haven't already, associate the ..._DECL node that we just made with
4993 the input GNAT entity node. */
4995 save_gnu_tree (gnat_entity, gnu_decl, false);
4997 /* If this is an enumeration or floating-point type, we were not able to set
4998 the bounds since they refer to the type. These are always static. */
4999 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
5000 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
5002 tree gnu_scalar_type = gnu_type;
5003 tree gnu_low_bound, gnu_high_bound;
5005 /* If this is a padded type, we need to use the underlying type. */
5006 if (TYPE_IS_PADDING_P (gnu_scalar_type))
5007 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
5009 /* If this is a floating point type and we haven't set a floating
5010 point type yet, use this in the evaluation of the bounds. */
5011 if (!longest_float_type_node && kind == E_Floating_Point_Type)
5012 longest_float_type_node = gnu_scalar_type;
5014 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
5015 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
5017 if (kind == E_Enumeration_Type)
5019 /* Enumeration types have specific RM bounds. */
5020 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
5021 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
5023 /* Write full debugging information. */
5024 rest_of_type_decl_compilation (gnu_decl);
5029 /* Floating-point types don't have specific RM bounds. */
5030 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
5031 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
5035 /* If we deferred processing of incomplete types, re-enable it. If there
5036 were no other disables and we have deferred types to process, do so. */
5038 && --defer_incomplete_level == 0
5039 && defer_incomplete_list)
5041 struct incomplete *p, *next;
5043 /* We are back to level 0 for the deferring of incomplete types.
5044 But processing these incomplete types below may itself require
5045 deferring, so preserve what we have and restart from scratch. */
5046 p = defer_incomplete_list;
5047 defer_incomplete_list = NULL;
5049 /* For finalization, however, all types must be complete so we
5050 cannot do the same because deferred incomplete types may end up
5051 referencing each other. Process them all recursively first. */
5052 defer_finalize_level++;
5059 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5060 gnat_to_gnu_type (p->full_type));
5064 defer_finalize_level--;
5067 /* If all the deferred incomplete types have been processed, we can proceed
5068 with the finalization of the deferred types. */
5069 if (defer_incomplete_level == 0
5070 && defer_finalize_level == 0
5071 && defer_finalize_list)
5076 FOR_EACH_VEC_ELT (tree, defer_finalize_list, i, t)
5077 rest_of_type_decl_compilation_no_defer (t);
5079 VEC_free (tree, heap, defer_finalize_list);
5082 /* If we are not defining this type, see if it's on one of the lists of
5083 incomplete types. If so, handle the list entry now. */
5084 if (is_type && !definition)
5086 struct incomplete *p;
5088 for (p = defer_incomplete_list; p; p = p->next)
5089 if (p->old_type && p->full_type == gnat_entity)
5091 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5092 TREE_TYPE (gnu_decl));
5093 p->old_type = NULL_TREE;
5096 for (p = defer_limited_with; p; p = p->next)
5097 if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
5099 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5100 TREE_TYPE (gnu_decl));
5101 p->old_type = NULL_TREE;
5108 /* If this is a packed array type whose original array type is itself
5109 an Itype without freeze node, make sure the latter is processed. */
5110 if (Is_Packed_Array_Type (gnat_entity)
5111 && Is_Itype (Original_Array_Type (gnat_entity))
5112 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
5113 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
5114 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
5119 /* Similar, but if the returned value is a COMPONENT_REF, return the
5123 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
5125 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5127 if (TREE_CODE (gnu_field) == COMPONENT_REF)
5128 gnu_field = TREE_OPERAND (gnu_field, 1);
5133 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5134 the GCC type corresponding to that entity. */
5137 gnat_to_gnu_type (Entity_Id gnat_entity)
5141 /* The back end never attempts to annotate generic types. */
5142 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
5143 return void_type_node;
5145 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5146 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
5148 return TREE_TYPE (gnu_decl);
5151 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5152 the unpadded version of the GCC type corresponding to that entity. */
5155 get_unpadded_type (Entity_Id gnat_entity)
5157 tree type = gnat_to_gnu_type (gnat_entity);
5159 if (TYPE_IS_PADDING_P (type))
5160 type = TREE_TYPE (TYPE_FIELDS (type));
5165 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
5166 Every TYPE_DECL generated for a type definition must be passed
5167 to this function once everything else has been done for it. */
5170 rest_of_type_decl_compilation (tree decl)
5172 /* We need to defer finalizing the type if incomplete types
5173 are being deferred or if they are being processed. */
5174 if (defer_incomplete_level != 0 || defer_finalize_level != 0)
5175 VEC_safe_push (tree, heap, defer_finalize_list, decl);
5177 rest_of_type_decl_compilation_no_defer (decl);
5180 /* Same as above but without deferring the compilation. This
5181 function should not be invoked directly on a TYPE_DECL. */
5184 rest_of_type_decl_compilation_no_defer (tree decl)
5186 const int toplev = global_bindings_p ();
5187 tree t = TREE_TYPE (decl);
5189 rest_of_decl_compilation (decl, toplev, 0);
5191 /* Now process all the variants. This is needed for STABS. */
5192 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
5194 if (t == TREE_TYPE (decl))
5197 if (!TYPE_STUB_DECL (t))
5198 TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
5200 rest_of_type_compilation (t, toplev);
5204 /* Finalize the processing of From_With_Type incomplete types. */
5207 finalize_from_with_types (void)
5209 struct incomplete *p, *next;
5211 p = defer_limited_with;
5212 defer_limited_with = NULL;
5219 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5220 gnat_to_gnu_type (p->full_type));
5225 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
5226 kind of type (such E_Task_Type) that has a different type which Gigi
5227 uses for its representation. If the type does not have a special type
5228 for its representation, return GNAT_ENTITY. If a type is supposed to
5229 exist, but does not, abort unless annotating types, in which case
5230 return Empty. If GNAT_ENTITY is Empty, return Empty. */
5233 Gigi_Equivalent_Type (Entity_Id gnat_entity)
5235 Entity_Id gnat_equiv = gnat_entity;
5237 if (No (gnat_entity))
5240 switch (Ekind (gnat_entity))
5242 case E_Class_Wide_Subtype:
5243 if (Present (Equivalent_Type (gnat_entity)))
5244 gnat_equiv = Equivalent_Type (gnat_entity);
5247 case E_Access_Protected_Subprogram_Type:
5248 case E_Anonymous_Access_Protected_Subprogram_Type:
5249 gnat_equiv = Equivalent_Type (gnat_entity);
5252 case E_Class_Wide_Type:
5253 gnat_equiv = Root_Type (gnat_entity);
5257 case E_Task_Subtype:
5258 case E_Protected_Type:
5259 case E_Protected_Subtype:
5260 gnat_equiv = Corresponding_Record_Type (gnat_entity);
5267 gcc_assert (Present (gnat_equiv) || type_annotate_only);
5271 /* Return a GCC tree for a type corresponding to the component type of the
5272 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5273 is for an array being defined. DEBUG_INFO_P is true if we need to write
5274 debug information for other types that we may create in the process. */
5277 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5280 const Entity_Id gnat_type = Component_Type (gnat_array);
5281 tree gnu_type = gnat_to_gnu_type (gnat_type);
5284 /* Try to get a smaller form of the component if needed. */
5285 if ((Is_Packed (gnat_array)
5286 || Has_Component_Size_Clause (gnat_array))
5287 && !Is_Bit_Packed_Array (gnat_array)
5288 && !Has_Aliased_Components (gnat_array)
5289 && !Strict_Alignment (gnat_type)
5290 && TREE_CODE (gnu_type) == RECORD_TYPE
5291 && !TYPE_FAT_POINTER_P (gnu_type)
5292 && host_integerp (TYPE_SIZE (gnu_type), 1))
5293 gnu_type = make_packable_type (gnu_type, false);
5295 if (Has_Atomic_Components (gnat_array))
5296 check_ok_for_atomic (gnu_type, gnat_array, true);
5298 /* Get and validate any specified Component_Size. */
5300 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5301 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5302 true, Has_Component_Size_Clause (gnat_array));
5304 /* If the array has aliased components and the component size can be zero,
5305 force at least unit size to ensure that the components have distinct
5308 && Has_Aliased_Components (gnat_array)
5309 && (integer_zerop (TYPE_SIZE (gnu_type))
5310 || (TREE_CODE (gnu_type) == ARRAY_TYPE
5311 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5313 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5315 /* If the component type is a RECORD_TYPE that has a self-referential size,
5316 then use the maximum size for the component size. */
5318 && TREE_CODE (gnu_type) == RECORD_TYPE
5319 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5320 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5322 /* Honor the component size. This is not needed for bit-packed arrays. */
5323 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5325 tree orig_type = gnu_type;
5326 unsigned int max_align;
5328 /* If an alignment is specified, use it as a cap on the component type
5329 so that it can be honored for the whole type. But ignore it for the
5330 original type of packed array types. */
5331 if (No (Packed_Array_Type (gnat_array)) && Known_Alignment (gnat_array))
5332 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5336 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5337 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5338 gnu_type = orig_type;
5340 orig_type = gnu_type;
5342 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5343 true, false, definition, true);
5345 /* If a padding record was made, declare it now since it will never be
5346 declared otherwise. This is necessary to ensure that its subtrees
5347 are properly marked. */
5348 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5349 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
5350 debug_info_p, gnat_array);
5353 if (Has_Volatile_Components (gnat_array))
5355 = build_qualified_type (gnu_type,
5356 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
5361 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5362 using MECH as its passing mechanism, to be placed in the parameter
5363 list built for GNAT_SUBPROG. Assume a foreign convention for the
5364 latter if FOREIGN is true. Also set CICO to true if the parameter
5365 must use the copy-in copy-out implementation mechanism.
5367 The returned tree is a PARM_DECL, except for those cases where no
5368 parameter needs to be actually passed to the subprogram; the type
5369 of this "shadow" parameter is then returned instead. */
5372 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5373 Entity_Id gnat_subprog, bool foreign, bool *cico)
5375 tree gnu_param_name = get_entity_name (gnat_param);
5376 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5377 tree gnu_param_type_alt = NULL_TREE;
5378 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5379 /* The parameter can be indirectly modified if its address is taken. */
5380 bool ro_param = in_param && !Address_Taken (gnat_param);
5381 bool by_return = false, by_component_ptr = false;
5382 bool by_ref = false, by_double_ref = false;
5385 /* Copy-return is used only for the first parameter of a valued procedure.
5386 It's a copy mechanism for which a parameter is never allocated. */
5387 if (mech == By_Copy_Return)
5389 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5394 /* If this is either a foreign function or if the underlying type won't
5395 be passed by reference, strip off possible padding type. */
5396 if (TYPE_IS_PADDING_P (gnu_param_type))
5398 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5400 if (mech == By_Reference
5402 || (!must_pass_by_ref (unpadded_type)
5403 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
5404 gnu_param_type = unpadded_type;
5407 /* If this is a read-only parameter, make a variant of the type that is
5408 read-only. ??? However, if this is an unconstrained array, that type
5409 can be very complex, so skip it for now. Likewise for any other
5410 self-referential type. */
5412 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5413 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5414 gnu_param_type = build_qualified_type (gnu_param_type,
5415 (TYPE_QUALS (gnu_param_type)
5416 | TYPE_QUAL_CONST));
5418 /* For foreign conventions, pass arrays as pointers to the element type.
5419 First check for unconstrained array and get the underlying array. */
5420 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5422 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5424 /* For GCC builtins, pass Address integer types as (void *) */
5425 if (Convention (gnat_subprog) == Convention_Intrinsic
5426 && Present (Interface_Name (gnat_subprog))
5427 && Is_Descendent_Of_Address (Etype (gnat_param)))
5428 gnu_param_type = ptr_void_type_node;
5430 /* VMS descriptors are themselves passed by reference. */
5431 if (mech == By_Short_Descriptor ||
5432 (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
5434 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5435 Mechanism (gnat_param),
5437 else if (mech == By_Descriptor)
5439 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5440 chosen in fill_vms_descriptor. */
5442 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5443 Mechanism (gnat_param),
5446 = build_pointer_type (build_vms_descriptor (gnu_param_type,
5447 Mechanism (gnat_param),
5451 /* Arrays are passed as pointers to element type for foreign conventions. */
5454 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5456 /* Strip off any multi-dimensional entries, then strip
5457 off the last array to get the component type. */
5458 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5459 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5460 gnu_param_type = TREE_TYPE (gnu_param_type);
5462 by_component_ptr = true;
5463 gnu_param_type = TREE_TYPE (gnu_param_type);
5466 gnu_param_type = build_qualified_type (gnu_param_type,
5467 (TYPE_QUALS (gnu_param_type)
5468 | TYPE_QUAL_CONST));
5470 gnu_param_type = build_pointer_type (gnu_param_type);
5473 /* Fat pointers are passed as thin pointers for foreign conventions. */
5474 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5476 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5478 /* If we must pass or were requested to pass by reference, do so.
5479 If we were requested to pass by copy, do so.
5480 Otherwise, for foreign conventions, pass In Out or Out parameters
5481 or aggregates by reference. For COBOL and Fortran, pass all
5482 integer and FP types that way too. For Convention Ada, use
5483 the standard Ada default. */
5484 else if (must_pass_by_ref (gnu_param_type)
5485 || mech == By_Reference
5488 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5490 && (Convention (gnat_subprog) == Convention_Fortran
5491 || Convention (gnat_subprog) == Convention_COBOL)
5492 && (INTEGRAL_TYPE_P (gnu_param_type)
5493 || FLOAT_TYPE_P (gnu_param_type)))
5495 && default_pass_by_ref (gnu_param_type)))))
5497 gnu_param_type = build_reference_type (gnu_param_type);
5500 /* In some ABIs, e.g. SPARC 32-bit, fat pointer types are themselves
5501 passed by reference. Pass them by explicit reference, this will
5502 generate more debuggable code at -O0. */
5503 if (TYPE_IS_FAT_POINTER_P (gnu_param_type)
5504 && targetm.calls.pass_by_reference (pack_cumulative_args (NULL),
5505 TYPE_MODE (gnu_param_type),
5509 gnu_param_type = build_reference_type (gnu_param_type);
5510 by_double_ref = true;
5514 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5518 if (mech == By_Copy && (by_ref || by_component_ptr))
5519 post_error ("?cannot pass & by copy", gnat_param);
5521 /* If this is an Out parameter that isn't passed by reference and isn't
5522 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5523 it will be a VAR_DECL created when we process the procedure, so just
5524 return its type. For the special parameter of a valued procedure,
5527 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5528 Out parameters with discriminants or implicit initial values to be
5529 handled like In Out parameters. These type are normally built as
5530 aggregates, hence passed by reference, except for some packed arrays
5531 which end up encoded in special integer types.
5533 The exception we need to make is then for packed arrays of records
5534 with discriminants or implicit initial values. We have no light/easy
5535 way to check for the latter case, so we merely check for packed arrays
5536 of records. This may lead to useless copy-in operations, but in very
5537 rare cases only, as these would be exceptions in a set of already
5538 exceptional situations. */
5539 if (Ekind (gnat_param) == E_Out_Parameter
5542 || (mech != By_Descriptor
5543 && mech != By_Short_Descriptor
5544 && !POINTER_TYPE_P (gnu_param_type)
5545 && !AGGREGATE_TYPE_P (gnu_param_type)))
5546 && !(Is_Array_Type (Etype (gnat_param))
5547 && Is_Packed (Etype (gnat_param))
5548 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5549 return gnu_param_type;
5551 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5552 ro_param || by_ref || by_component_ptr);
5553 DECL_BY_REF_P (gnu_param) = by_ref;
5554 DECL_BY_DOUBLE_REF_P (gnu_param) = by_double_ref;
5555 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5556 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
5557 mech == By_Short_Descriptor);
5558 DECL_POINTS_TO_READONLY_P (gnu_param)
5559 = (ro_param && (by_ref || by_component_ptr));
5561 /* Save the alternate descriptor type, if any. */
5562 if (gnu_param_type_alt)
5563 SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5565 /* If no Mechanism was specified, indicate what we're using, then
5566 back-annotate it. */
5567 if (mech == Default)
5568 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5570 Set_Mechanism (gnat_param, mech);
5574 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5577 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5579 while (Present (Corresponding_Discriminant (discr1)))
5580 discr1 = Corresponding_Discriminant (discr1);
5582 while (Present (Corresponding_Discriminant (discr2)))
5583 discr2 = Corresponding_Discriminant (discr2);
5586 Original_Record_Component (discr1) == Original_Record_Component (discr2);
5589 /* Return true if the array type GNU_TYPE, which represents a dimension of
5590 GNAT_TYPE, has a non-aliased component in the back-end sense. */
5593 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
5595 /* If the array type is not the innermost dimension of the GNAT type,
5596 then it has a non-aliased component. */
5597 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5598 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5601 /* If the array type has an aliased component in the front-end sense,
5602 then it also has an aliased component in the back-end sense. */
5603 if (Has_Aliased_Components (gnat_type))
5606 /* If this is a derived type, then it has a non-aliased component if
5607 and only if its parent type also has one. */
5608 if (Is_Derived_Type (gnat_type))
5610 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
5612 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
5614 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
5615 for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
5616 gnu_parent_type = TREE_TYPE (gnu_parent_type);
5617 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
5620 /* Otherwise, rely exclusively on properties of the element type. */
5621 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5624 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5627 compile_time_known_address_p (Node_Id gnat_address)
5629 /* Catch System'To_Address. */
5630 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5631 gnat_address = Expression (gnat_address);
5633 return Compile_Time_Known_Value (gnat_address);
5636 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
5637 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
5640 cannot_be_superflat_p (Node_Id gnat_range)
5642 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
5643 Node_Id scalar_range;
5644 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
5646 /* If the low bound is not constant, try to find an upper bound. */
5647 while (Nkind (gnat_lb) != N_Integer_Literal
5648 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
5649 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
5650 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
5651 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5652 || Nkind (scalar_range) == N_Range))
5653 gnat_lb = High_Bound (scalar_range);
5655 /* If the high bound is not constant, try to find a lower bound. */
5656 while (Nkind (gnat_hb) != N_Integer_Literal
5657 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
5658 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
5659 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
5660 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5661 || Nkind (scalar_range) == N_Range))
5662 gnat_hb = Low_Bound (scalar_range);
5664 /* If we have failed to find constant bounds, punt. */
5665 if (Nkind (gnat_lb) != N_Integer_Literal
5666 || Nkind (gnat_hb) != N_Integer_Literal)
5669 /* We need at least a signed 64-bit type to catch most cases. */
5670 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
5671 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
5672 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
5675 /* If the low bound is the smallest integer, nothing can be smaller. */
5676 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
5677 if (TREE_OVERFLOW (gnu_lb_minus_one))
5680 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
5683 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
5686 constructor_address_p (tree gnu_expr)
5688 while (TREE_CODE (gnu_expr) == NOP_EXPR
5689 || TREE_CODE (gnu_expr) == CONVERT_EXPR
5690 || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
5691 gnu_expr = TREE_OPERAND (gnu_expr, 0);
5693 return (TREE_CODE (gnu_expr) == ADDR_EXPR
5694 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
5697 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5698 be elaborated at the point of its definition, but do nothing else. */
5701 elaborate_entity (Entity_Id gnat_entity)
5703 switch (Ekind (gnat_entity))
5705 case E_Signed_Integer_Subtype:
5706 case E_Modular_Integer_Subtype:
5707 case E_Enumeration_Subtype:
5708 case E_Ordinary_Fixed_Point_Subtype:
5709 case E_Decimal_Fixed_Point_Subtype:
5710 case E_Floating_Point_Subtype:
5712 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5713 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5715 /* ??? Tests to avoid Constraint_Error in static expressions
5716 are needed until after the front stops generating bogus
5717 conversions on bounds of real types. */
5718 if (!Raises_Constraint_Error (gnat_lb))
5719 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5720 true, false, Needs_Debug_Info (gnat_entity));
5721 if (!Raises_Constraint_Error (gnat_hb))
5722 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5723 true, false, Needs_Debug_Info (gnat_entity));
5729 Node_Id full_definition = Declaration_Node (gnat_entity);
5730 Node_Id record_definition = Type_Definition (full_definition);
5732 /* If this is a record extension, go a level further to find the
5733 record definition. */
5734 if (Nkind (record_definition) == N_Derived_Type_Definition)
5735 record_definition = Record_Extension_Part (record_definition);
5739 case E_Record_Subtype:
5740 case E_Private_Subtype:
5741 case E_Limited_Private_Subtype:
5742 case E_Record_Subtype_With_Private:
5743 if (Is_Constrained (gnat_entity)
5744 && Has_Discriminants (gnat_entity)
5745 && Present (Discriminant_Constraint (gnat_entity)))
5747 Node_Id gnat_discriminant_expr;
5748 Entity_Id gnat_field;
5751 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
5752 gnat_discriminant_expr
5753 = First_Elmt (Discriminant_Constraint (gnat_entity));
5754 Present (gnat_field);
5755 gnat_field = Next_Discriminant (gnat_field),
5756 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5757 /* ??? For now, ignore access discriminants. */
5758 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5759 elaborate_expression (Node (gnat_discriminant_expr),
5760 gnat_entity, get_entity_name (gnat_field),
5761 true, false, false);
5768 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5769 any entities on its entity chain similarly. */
5772 mark_out_of_scope (Entity_Id gnat_entity)
5774 Entity_Id gnat_sub_entity;
5775 unsigned int kind = Ekind (gnat_entity);
5777 /* If this has an entity list, process all in the list. */
5778 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5779 || IN (kind, Private_Kind)
5780 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5781 || kind == E_Function || kind == E_Generic_Function
5782 || kind == E_Generic_Package || kind == E_Generic_Procedure
5783 || kind == E_Loop || kind == E_Operator || kind == E_Package
5784 || kind == E_Package_Body || kind == E_Procedure
5785 || kind == E_Record_Type || kind == E_Record_Subtype
5786 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5787 for (gnat_sub_entity = First_Entity (gnat_entity);
5788 Present (gnat_sub_entity);
5789 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5790 if (Scope (gnat_sub_entity) == gnat_entity
5791 && gnat_sub_entity != gnat_entity)
5792 mark_out_of_scope (gnat_sub_entity);
5794 /* Now clear this if it has been defined, but only do so if it isn't
5795 a subprogram or parameter. We could refine this, but it isn't
5796 worth it. If this is statically allocated, it is supposed to
5797 hang around out of cope. */
5798 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5799 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5801 save_gnu_tree (gnat_entity, NULL_TREE, true);
5802 save_gnu_tree (gnat_entity, error_mark_node, true);
5806 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5807 If this is a multi-dimensional array type, do this recursively.
5810 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5811 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5812 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5815 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
5817 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5818 of a one-dimensional array, since the padding has the same alias set
5819 as the field type, but if it's a multi-dimensional array, we need to
5820 see the inner types. */
5821 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5822 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5823 || TYPE_PADDING_P (gnu_old_type)))
5824 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5826 /* Unconstrained array types are deemed incomplete and would thus be given
5827 alias set 0. Retrieve the underlying array type. */
5828 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5830 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5831 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
5833 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
5835 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5836 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5837 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5838 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
5842 case ALIAS_SET_COPY:
5843 /* The alias set shouldn't be copied between array types with different
5844 aliasing settings because this can break the aliasing relationship
5845 between the array type and its element type. */
5846 #ifndef ENABLE_CHECKING
5847 if (flag_strict_aliasing)
5849 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
5850 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
5851 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
5852 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
5854 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5857 case ALIAS_SET_SUBSET:
5858 case ALIAS_SET_SUPERSET:
5860 alias_set_type old_set = get_alias_set (gnu_old_type);
5861 alias_set_type new_set = get_alias_set (gnu_new_type);
5863 /* Do nothing if the alias sets conflict. This ensures that we
5864 never call record_alias_subset several times for the same pair
5865 or at all for alias set 0. */
5866 if (!alias_sets_conflict_p (old_set, new_set))
5868 if (op == ALIAS_SET_SUBSET)
5869 record_alias_subset (old_set, new_set);
5871 record_alias_subset (new_set, old_set);
5880 record_component_aliases (gnu_new_type);
5883 /* Return true if the size represented by GNU_SIZE can be handled by an
5884 allocation. If STATIC_P is true, consider only what can be done with a
5885 static allocation. */
5888 allocatable_size_p (tree gnu_size, bool static_p)
5890 HOST_WIDE_INT our_size;
5892 /* If this is not a static allocation, the only case we want to forbid
5893 is an overflowing size. That will be converted into a raise a
5896 return !(TREE_CODE (gnu_size) == INTEGER_CST
5897 && TREE_OVERFLOW (gnu_size));
5899 /* Otherwise, we need to deal with both variable sizes and constant
5900 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5901 since assemblers may not like very large sizes. */
5902 if (!host_integerp (gnu_size, 1))
5905 our_size = tree_low_cst (gnu_size, 1);
5906 return (int) our_size == our_size;
5909 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5910 NAME, ARGS and ERROR_POINT. */
5913 prepend_one_attribute_to (struct attrib ** attr_list,
5914 enum attr_type attr_type,
5917 Node_Id attr_error_point)
5919 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5921 attr->type = attr_type;
5922 attr->name = attr_name;
5923 attr->args = attr_args;
5924 attr->error_point = attr_error_point;
5926 attr->next = *attr_list;
5930 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5933 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5937 /* Attributes are stored as Representation Item pragmas. */
5939 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5940 gnat_temp = Next_Rep_Item (gnat_temp))
5941 if (Nkind (gnat_temp) == N_Pragma)
5943 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5944 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5945 enum attr_type etype;
5947 /* Map the kind of pragma at hand. Skip if this is not one
5948 we know how to handle. */
5950 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5952 case Pragma_Machine_Attribute:
5953 etype = ATTR_MACHINE_ATTRIBUTE;
5956 case Pragma_Linker_Alias:
5957 etype = ATTR_LINK_ALIAS;
5960 case Pragma_Linker_Section:
5961 etype = ATTR_LINK_SECTION;
5964 case Pragma_Linker_Constructor:
5965 etype = ATTR_LINK_CONSTRUCTOR;
5968 case Pragma_Linker_Destructor:
5969 etype = ATTR_LINK_DESTRUCTOR;
5972 case Pragma_Weak_External:
5973 etype = ATTR_WEAK_EXTERNAL;
5976 case Pragma_Thread_Local_Storage:
5977 etype = ATTR_THREAD_LOCAL_STORAGE;
5984 /* See what arguments we have and turn them into GCC trees for
5985 attribute handlers. These expect identifier for strings. We
5986 handle at most two arguments, static expressions only. */
5988 if (Present (gnat_assoc) && Present (First (gnat_assoc)))
5990 Node_Id gnat_arg0 = Next (First (gnat_assoc));
5991 Node_Id gnat_arg1 = Empty;
5993 if (Present (gnat_arg0)
5994 && Is_Static_Expression (Expression (gnat_arg0)))
5996 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
5998 if (TREE_CODE (gnu_arg0) == STRING_CST)
5999 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
6001 gnat_arg1 = Next (gnat_arg0);
6004 if (Present (gnat_arg1)
6005 && Is_Static_Expression (Expression (gnat_arg1)))
6007 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
6009 if (TREE_CODE (gnu_arg1) == STRING_CST)
6010 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
6014 /* Prepend to the list now. Make a list of the argument we might
6015 have, as GCC expects it. */
6016 prepend_one_attribute_to
6019 (gnu_arg1 != NULL_TREE)
6020 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
6021 Present (Next (First (gnat_assoc)))
6022 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
6026 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6027 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6028 return the GCC tree to use for that expression. GNU_NAME is the suffix
6029 to use if a variable needs to be created and DEFINITION is true if this
6030 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6031 otherwise, we are just elaborating the expression for side-effects. If
6032 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6033 isn't needed for code generation. */
6036 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
6037 bool definition, bool need_value, bool need_debug)
6041 /* If we already elaborated this expression (e.g. it was involved
6042 in the definition of a private type), use the old value. */
6043 if (present_gnu_tree (gnat_expr))
6044 return get_gnu_tree (gnat_expr);
6046 /* If we don't need a value and this is static or a discriminant,
6047 we don't need to do anything. */
6049 && (Is_OK_Static_Expression (gnat_expr)
6050 || (Nkind (gnat_expr) == N_Identifier
6051 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
6054 /* If it's a static expression, we don't need a variable for debugging. */
6055 if (need_debug && Is_OK_Static_Expression (gnat_expr))
6058 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6059 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
6060 gnu_name, definition, need_debug);
6062 /* Save the expression in case we try to elaborate this entity again. Since
6063 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6064 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
6065 save_gnu_tree (gnat_expr, gnu_expr, true);
6067 return need_value ? gnu_expr : error_mark_node;
6070 /* Similar, but take a GNU expression and always return a result. */
6073 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6074 bool definition, bool need_debug)
6076 const bool expr_global_p = Is_Public (gnat_entity) || global_bindings_p ();
6077 bool expr_variable_p, use_variable;
6079 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
6080 reference will have been replaced with a COMPONENT_REF when the type
6081 is being elaborated. However, there are some cases involving child
6082 types where we will. So convert it to a COMPONENT_REF. We hope it
6083 will be at the highest level of the expression in these cases. */
6084 if (TREE_CODE (gnu_expr) == FIELD_DECL)
6085 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
6086 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
6087 gnu_expr, NULL_TREE);
6089 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6090 that an expression cannot contain both a discriminant and a variable. */
6091 if (CONTAINS_PLACEHOLDER_P (gnu_expr))
6094 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6095 a variable that is initialized to contain the expression when the package
6096 containing the definition is elaborated. If this entity is defined at top
6097 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6098 if this is necessary. */
6099 if (CONSTANT_CLASS_P (gnu_expr))
6100 expr_variable_p = false;
6103 /* Skip any conversions and simple arithmetics to see if the expression
6104 is based on a read-only variable.
6105 ??? This really should remain read-only, but we have to think about
6106 the typing of the tree here. */
6108 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
6110 if (handled_component_p (inner))
6112 HOST_WIDE_INT bitsize, bitpos;
6114 enum machine_mode mode;
6115 int unsignedp, volatilep;
6117 inner = get_inner_reference (inner, &bitsize, &bitpos, &offset,
6118 &mode, &unsignedp, &volatilep, false);
6119 /* If the offset is variable, err on the side of caution. */
6126 && TREE_CODE (inner) == VAR_DECL
6127 && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
6130 /* We only need to use the variable if we are in a global context since GCC
6131 can do the right thing in the local case. However, when not optimizing,
6132 use it for bounds of loop iteration scheme to avoid code duplication. */
6133 use_variable = expr_variable_p
6136 && Is_Itype (gnat_entity)
6137 && Nkind (Associated_Node_For_Itype (gnat_entity))
6138 == N_Loop_Parameter_Specification));
6140 /* Now create it, possibly only for debugging purposes. */
6141 if (use_variable || need_debug)
6144 = create_var_decl (create_concat_name (gnat_entity,
6145 IDENTIFIER_POINTER (gnu_name)),
6146 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
6147 !need_debug, Is_Public (gnat_entity),
6148 !definition, expr_global_p, NULL, gnat_entity);
6154 return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
6157 /* Similar, but take an alignment factor and make it explicit in the tree. */
6160 elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6161 bool definition, bool need_debug, unsigned int align)
6163 tree unit_align = size_int (align / BITS_PER_UNIT);
6165 size_binop (MULT_EXPR,
6166 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR,
6169 gnat_entity, gnu_name, definition,
6174 /* Create a record type that contains a SIZE bytes long field of TYPE with a
6175 starting bit position so that it is aligned to ALIGN bits, and leaving at
6176 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
6177 record is guaranteed to get. */
6180 make_aligning_type (tree type, unsigned int align, tree size,
6181 unsigned int base_align, int room)
6183 /* We will be crafting a record type with one field at a position set to be
6184 the next multiple of ALIGN past record'address + room bytes. We use a
6185 record placeholder to express record'address. */
6186 tree record_type = make_node (RECORD_TYPE);
6187 tree record = build0 (PLACEHOLDER_EXPR, record_type);
6190 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
6192 /* The diagram below summarizes the shape of what we manipulate:
6194 <--------- pos ---------->
6195 { +------------+-------------+-----------------+
6196 record =>{ |############| ... | field (type) |
6197 { +------------+-------------+-----------------+
6198 |<-- room -->|<- voffset ->|<---- size ----->|
6201 record_addr vblock_addr
6203 Every length is in sizetype bytes there, except "pos" which has to be
6204 set as a bit position in the GCC tree for the record. */
6205 tree room_st = size_int (room);
6206 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
6207 tree voffset_st, pos, field;
6209 tree name = TYPE_NAME (type);
6211 if (TREE_CODE (name) == TYPE_DECL)
6212 name = DECL_NAME (name);
6213 name = concat_name (name, "ALIGN");
6214 TYPE_NAME (record_type) = name;
6216 /* Compute VOFFSET and then POS. The next byte position multiple of some
6217 alignment after some address is obtained by "and"ing the alignment minus
6218 1 with the two's complement of the address. */
6219 voffset_st = size_binop (BIT_AND_EXPR,
6220 fold_build1 (NEGATE_EXPR, sizetype, vblock_addr_st),
6221 size_int ((align / BITS_PER_UNIT) - 1));
6223 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
6224 pos = size_binop (MULT_EXPR,
6225 convert (bitsizetype,
6226 size_binop (PLUS_EXPR, room_st, voffset_st)),
6229 /* Craft the GCC record representation. We exceptionally do everything
6230 manually here because 1) our generic circuitry is not quite ready to
6231 handle the complex position/size expressions we are setting up, 2) we
6232 have a strong simplifying factor at hand: we know the maximum possible
6233 value of voffset, and 3) we have to set/reset at least the sizes in
6234 accordance with this maximum value anyway, as we need them to convey
6235 what should be "alloc"ated for this type.
6237 Use -1 as the 'addressable' indication for the field to prevent the
6238 creation of a bitfield. We don't need one, it would have damaging
6239 consequences on the alignment computation, and create_field_decl would
6240 make one without this special argument, for instance because of the
6241 complex position expression. */
6242 field = create_field_decl (get_identifier ("F"), type, record_type, size,
6244 TYPE_FIELDS (record_type) = field;
6246 TYPE_ALIGN (record_type) = base_align;
6247 TYPE_USER_ALIGN (record_type) = 1;
6249 TYPE_SIZE (record_type)
6250 = size_binop (PLUS_EXPR,
6251 size_binop (MULT_EXPR, convert (bitsizetype, size),
6253 bitsize_int (align + room * BITS_PER_UNIT));
6254 TYPE_SIZE_UNIT (record_type)
6255 = size_binop (PLUS_EXPR, size,
6256 size_int (room + align / BITS_PER_UNIT));
6258 SET_TYPE_MODE (record_type, BLKmode);
6259 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
6261 /* Declare it now since it will never be declared otherwise. This is
6262 necessary to ensure that its subtrees are properly marked. */
6263 create_type_decl (name, record_type, NULL, true, false, Empty);
6268 /* Return the result of rounding T up to ALIGN. */
6270 static inline unsigned HOST_WIDE_INT
6271 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
6279 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
6280 as the field type of a packed record if IN_RECORD is true, or as the
6281 component type of a packed array if IN_RECORD is false. See if we can
6282 rewrite it either as a type that has a non-BLKmode, which we can pack
6283 tighter in the packed record case, or as a smaller type. If so, return
6284 the new type. If not, return the original type. */
6287 make_packable_type (tree type, bool in_record)
6289 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
6290 unsigned HOST_WIDE_INT new_size;
6291 tree new_type, old_field, field_list = NULL_TREE;
6293 /* No point in doing anything if the size is zero. */
6297 new_type = make_node (TREE_CODE (type));
6299 /* Copy the name and flags from the old type to that of the new.
6300 Note that we rely on the pointer equality created here for
6301 TYPE_NAME to look through conversions in various places. */
6302 TYPE_NAME (new_type) = TYPE_NAME (type);
6303 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
6304 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
6305 if (TREE_CODE (type) == RECORD_TYPE)
6306 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
6308 /* If we are in a record and have a small size, set the alignment to
6309 try for an integral mode. Otherwise set it to try for a smaller
6310 type with BLKmode. */
6311 if (in_record && size <= MAX_FIXED_MODE_SIZE)
6313 TYPE_ALIGN (new_type) = ceil_alignment (size);
6314 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
6318 unsigned HOST_WIDE_INT align;
6320 /* Do not try to shrink the size if the RM size is not constant. */
6321 if (TYPE_CONTAINS_TEMPLATE_P (type)
6322 || !host_integerp (TYPE_ADA_SIZE (type), 1))
6325 /* Round the RM size up to a unit boundary to get the minimal size
6326 for a BLKmode record. Give up if it's already the size. */
6327 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
6328 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
6329 if (new_size == size)
6332 align = new_size & -new_size;
6333 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
6336 TYPE_USER_ALIGN (new_type) = 1;
6338 /* Now copy the fields, keeping the position and size as we don't want
6339 to change the layout by propagating the packedness downwards. */
6340 for (old_field = TYPE_FIELDS (type); old_field;
6341 old_field = DECL_CHAIN (old_field))
6343 tree new_field_type = TREE_TYPE (old_field);
6344 tree new_field, new_size;
6346 if ((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 && host_integerp (TYPE_SIZE (new_field_type), 1))
6351 new_field_type = make_packable_type (new_field_type, true);
6353 /* However, for the last field in a not already packed record type
6354 that is of an aggregate type, we need to use the RM size in the
6355 packable version of the record type, see finish_record_type. */
6356 if (!DECL_CHAIN (old_field)
6357 && !TYPE_PACKED (type)
6358 && (TREE_CODE (new_field_type) == RECORD_TYPE
6359 || TREE_CODE (new_field_type) == UNION_TYPE
6360 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
6361 && !TYPE_FAT_POINTER_P (new_field_type)
6362 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
6363 && TYPE_ADA_SIZE (new_field_type))
6364 new_size = TYPE_ADA_SIZE (new_field_type);
6366 new_size = DECL_SIZE (old_field);
6369 = create_field_decl (DECL_NAME (old_field), new_field_type, new_type,
6370 new_size, bit_position (old_field),
6372 !DECL_NONADDRESSABLE_P (old_field));
6374 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
6375 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
6376 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
6377 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
6379 DECL_CHAIN (new_field) = field_list;
6380 field_list = new_field;
6383 finish_record_type (new_type, nreverse (field_list), 2, false);
6384 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
6385 SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
6386 DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)));
6388 /* If this is a padding record, we never want to make the size smaller
6389 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
6390 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
6392 TYPE_SIZE (new_type) = TYPE_SIZE (type);
6393 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
6398 TYPE_SIZE (new_type) = bitsize_int (new_size);
6399 TYPE_SIZE_UNIT (new_type)
6400 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
6403 if (!TYPE_CONTAINS_TEMPLATE_P (type))
6404 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
6406 compute_record_mode (new_type);
6408 /* Try harder to get a packable type if necessary, for example
6409 in case the record itself contains a BLKmode field. */
6410 if (in_record && TYPE_MODE (new_type) == BLKmode)
6411 SET_TYPE_MODE (new_type,
6412 mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
6414 /* If neither the mode nor the size has shrunk, return the old type. */
6415 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
6421 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
6422 if needed. We have already verified that SIZE and TYPE are large enough.
6423 GNAT_ENTITY is used to name the resulting record and to issue a warning.
6424 IS_COMPONENT_TYPE is true if this is being done for the component type
6425 of an array. IS_USER_TYPE is true if we must complete the original type.
6426 DEFINITION is true if this type is being defined. SAME_RM_SIZE is true
6427 if the RM size of the resulting type is to be set to SIZE too; otherwise,
6428 it's set to the RM size of the original type. */
6431 maybe_pad_type (tree type, tree size, unsigned int align,
6432 Entity_Id gnat_entity, bool is_component_type,
6433 bool is_user_type, bool definition, bool same_rm_size)
6435 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
6436 tree orig_size = TYPE_SIZE (type);
6439 /* If TYPE is a padded type, see if it agrees with any size and alignment
6440 we were given. If so, return the original type. Otherwise, strip
6441 off the padding, since we will either be returning the inner type
6442 or repadding it. If no size or alignment is specified, use that of
6443 the original padded type. */
6444 if (TYPE_IS_PADDING_P (type))
6447 || operand_equal_p (round_up (size,
6448 MAX (align, TYPE_ALIGN (type))),
6449 round_up (TYPE_SIZE (type),
6450 MAX (align, TYPE_ALIGN (type))),
6452 && (align == 0 || align == TYPE_ALIGN (type)))
6456 size = TYPE_SIZE (type);
6458 align = TYPE_ALIGN (type);
6460 type = TREE_TYPE (TYPE_FIELDS (type));
6461 orig_size = TYPE_SIZE (type);
6464 /* If the size is either not being changed or is being made smaller (which
6465 is not done here and is only valid for bitfields anyway), show the size
6466 isn't changing. Likewise, clear the alignment if it isn't being
6467 changed. Then return if we aren't doing anything. */
6469 && (operand_equal_p (size, orig_size, 0)
6470 || (TREE_CODE (orig_size) == INTEGER_CST
6471 && tree_int_cst_lt (size, orig_size))))
6474 if (align == TYPE_ALIGN (type))
6477 if (align == 0 && !size)
6480 /* If requested, complete the original type and give it a name. */
6482 create_type_decl (get_entity_name (gnat_entity), type,
6483 NULL, !Comes_From_Source (gnat_entity),
6485 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6486 && DECL_IGNORED_P (TYPE_NAME (type))),
6489 /* We used to modify the record in place in some cases, but that could
6490 generate incorrect debugging information. So make a new record
6492 record = make_node (RECORD_TYPE);
6493 TYPE_PADDING_P (record) = 1;
6495 if (Present (gnat_entity))
6496 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
6498 TYPE_VOLATILE (record)
6499 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
6501 TYPE_ALIGN (record) = align;
6502 TYPE_SIZE (record) = size ? size : orig_size;
6503 TYPE_SIZE_UNIT (record)
6504 = convert (sizetype,
6505 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
6506 bitsize_unit_node));
6508 /* If we are changing the alignment and the input type is a record with
6509 BLKmode and a small constant size, try to make a form that has an
6510 integral mode. This might allow the padding record to also have an
6511 integral mode, which will be much more efficient. There is no point
6512 in doing so if a size is specified unless it is also a small constant
6513 size and it is incorrect to do so if we cannot guarantee that the mode
6514 will be naturally aligned since the field must always be addressable.
6516 ??? This might not always be a win when done for a stand-alone object:
6517 since the nominal and the effective type of the object will now have
6518 different modes, a VIEW_CONVERT_EXPR will be required for converting
6519 between them and it might be hard to overcome afterwards, including
6520 at the RTL level when the stand-alone object is accessed as a whole. */
6522 && TREE_CODE (type) == RECORD_TYPE
6523 && TYPE_MODE (type) == BLKmode
6524 && TREE_CODE (orig_size) == INTEGER_CST
6525 && !TREE_OVERFLOW (orig_size)
6526 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
6528 || (TREE_CODE (size) == INTEGER_CST
6529 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
6531 tree packable_type = make_packable_type (type, true);
6532 if (TYPE_MODE (packable_type) != BLKmode
6533 && align >= TYPE_ALIGN (packable_type))
6534 type = packable_type;
6537 /* Now create the field with the original size. */
6538 field = create_field_decl (get_identifier ("F"), type, record, orig_size,
6539 bitsize_zero_node, 0, 1);
6540 DECL_INTERNAL_P (field) = 1;
6542 /* Do not emit debug info until after the auxiliary record is built. */
6543 finish_record_type (record, field, 1, false);
6545 /* Set the same size for its RM size if requested; otherwise reuse
6546 the RM size of the original type. */
6547 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
6549 /* Unless debugging information isn't being written for the input type,
6550 write a record that shows what we are a subtype of and also make a
6551 variable that indicates our size, if still variable. */
6552 if (TREE_CODE (orig_size) != INTEGER_CST
6553 && TYPE_NAME (record)
6555 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6556 && DECL_IGNORED_P (TYPE_NAME (type))))
6558 tree marker = make_node (RECORD_TYPE);
6559 tree name = TYPE_NAME (record);
6560 tree orig_name = TYPE_NAME (type);
6562 if (TREE_CODE (name) == TYPE_DECL)
6563 name = DECL_NAME (name);
6565 if (TREE_CODE (orig_name) == TYPE_DECL)
6566 orig_name = DECL_NAME (orig_name);
6568 TYPE_NAME (marker) = concat_name (name, "XVS");
6569 finish_record_type (marker,
6570 create_field_decl (orig_name,
6571 build_reference_type (type),
6572 marker, NULL_TREE, NULL_TREE,
6576 add_parallel_type (TYPE_STUB_DECL (record), marker);
6578 if (definition && size && TREE_CODE (size) != INTEGER_CST)
6579 TYPE_SIZE_UNIT (marker)
6580 = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
6581 TYPE_SIZE_UNIT (record), false, false, false,
6582 false, NULL, gnat_entity);
6585 rest_of_record_type_compilation (record);
6587 /* If the size was widened explicitly, maybe give a warning. Take the
6588 original size as the maximum size of the input if there was an
6589 unconstrained record involved and round it up to the specified alignment,
6590 if one was specified. */
6591 if (CONTAINS_PLACEHOLDER_P (orig_size))
6592 orig_size = max_size (orig_size, true);
6595 orig_size = round_up (orig_size, align);
6597 if (Present (gnat_entity)
6599 && TREE_CODE (size) != MAX_EXPR
6600 && TREE_CODE (size) != COND_EXPR
6601 && !operand_equal_p (size, orig_size, 0)
6602 && !(TREE_CODE (size) == INTEGER_CST
6603 && TREE_CODE (orig_size) == INTEGER_CST
6604 && (TREE_OVERFLOW (size)
6605 || TREE_OVERFLOW (orig_size)
6606 || tree_int_cst_lt (size, orig_size))))
6608 Node_Id gnat_error_node = Empty;
6610 if (Is_Packed_Array_Type (gnat_entity))
6611 gnat_entity = Original_Array_Type (gnat_entity);
6613 if ((Ekind (gnat_entity) == E_Component
6614 || Ekind (gnat_entity) == E_Discriminant)
6615 && Present (Component_Clause (gnat_entity)))
6616 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
6617 else if (Present (Size_Clause (gnat_entity)))
6618 gnat_error_node = Expression (Size_Clause (gnat_entity));
6620 /* Generate message only for entities that come from source, since
6621 if we have an entity created by expansion, the message will be
6622 generated for some other corresponding source entity. */
6623 if (Comes_From_Source (gnat_entity))
6625 if (Present (gnat_error_node))
6626 post_error_ne_tree ("{^ }bits of & unused?",
6627 gnat_error_node, gnat_entity,
6628 size_diffop (size, orig_size));
6629 else if (is_component_type)
6630 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6631 gnat_entity, gnat_entity,
6632 size_diffop (size, orig_size));
6639 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6640 the value passed against the list of choices. */
6643 choices_to_gnu (tree operand, Node_Id choices)
6647 tree result = boolean_false_node;
6648 tree this_test, low = 0, high = 0, single = 0;
6650 for (choice = First (choices); Present (choice); choice = Next (choice))
6652 switch (Nkind (choice))
6655 low = gnat_to_gnu (Low_Bound (choice));
6656 high = gnat_to_gnu (High_Bound (choice));
6659 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6660 build_binary_op (GE_EXPR, boolean_type_node,
6662 build_binary_op (LE_EXPR, boolean_type_node,
6667 case N_Subtype_Indication:
6668 gnat_temp = Range_Expression (Constraint (choice));
6669 low = gnat_to_gnu (Low_Bound (gnat_temp));
6670 high = gnat_to_gnu (High_Bound (gnat_temp));
6673 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6674 build_binary_op (GE_EXPR, boolean_type_node,
6676 build_binary_op (LE_EXPR, boolean_type_node,
6681 case N_Expanded_Name:
6682 /* This represents either a subtype range, an enumeration
6683 literal, or a constant Ekind says which. If an enumeration
6684 literal or constant, fall through to the next case. */
6685 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6686 && Ekind (Entity (choice)) != E_Constant)
6688 tree type = gnat_to_gnu_type (Entity (choice));
6690 low = TYPE_MIN_VALUE (type);
6691 high = TYPE_MAX_VALUE (type);
6694 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6695 build_binary_op (GE_EXPR, boolean_type_node,
6697 build_binary_op (LE_EXPR, boolean_type_node,
6702 /* ... fall through ... */
6704 case N_Character_Literal:
6705 case N_Integer_Literal:
6706 single = gnat_to_gnu (choice);
6707 this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
6711 case N_Others_Choice:
6712 this_test = boolean_true_node;
6719 result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
6726 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6727 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6730 adjust_packed (tree field_type, tree record_type, int packed)
6732 /* If the field contains an item of variable size, we cannot pack it
6733 because we cannot create temporaries of non-fixed size in case
6734 we need to take the address of the field. See addressable_p and
6735 the notes on the addressability issues for further details. */
6736 if (is_variable_size (field_type))
6739 /* If the alignment of the record is specified and the field type
6740 is over-aligned, request Storage_Unit alignment for the field. */
6743 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6752 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6753 placed in GNU_RECORD_TYPE.
6755 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6756 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6757 record has a specified alignment.
6759 DEFINITION is true if this field is for a record being defined.
6761 DEBUG_INFO_P is true if we need to write debug information for types
6762 that we may create in the process. */
6765 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6766 bool definition, bool debug_info_p)
6768 const Entity_Id gnat_field_type = Etype (gnat_field);
6769 tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
6770 tree gnu_field_id = get_entity_name (gnat_field);
6771 tree gnu_field, gnu_size, gnu_pos;
6773 = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
6774 bool needs_strict_alignment
6776 || Is_Aliased (gnat_field)
6777 || Strict_Alignment (gnat_field_type));
6779 /* If this field requires strict alignment, we cannot pack it because
6780 it would very likely be under-aligned in the record. */
6781 if (needs_strict_alignment)
6784 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6786 /* If a size is specified, use it. Otherwise, if the record type is packed,
6787 use the official RM size. See "Handling of Type'Size Values" in Einfo
6788 for further details. */
6789 if (Known_Esize (gnat_field))
6790 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6791 gnat_field, FIELD_DECL, false, true);
6792 else if (packed == 1)
6793 gnu_size = validate_size (RM_Size (gnat_field_type), gnu_field_type,
6794 gnat_field, FIELD_DECL, false, true);
6796 gnu_size = NULL_TREE;
6798 /* If we have a specified size that is smaller than that of the field's type,
6799 or a position is specified, and the field's type is a record that doesn't
6800 require strict alignment, see if we can get either an integral mode form
6801 of the type or a smaller form. If we can, show a size was specified for
6802 the field if there wasn't one already, so we know to make this a bitfield
6803 and avoid making things wider.
6805 Changing to an integral mode form is useful when the record is packed as
6806 we can then place the field at a non-byte-aligned position and so achieve
6807 tighter packing. This is in addition required if the field shares a byte
6808 with another field and the front-end lets the back-end handle the access
6809 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6811 Changing to a smaller form is required if the specified size is smaller
6812 than that of the field's type and the type contains sub-fields that are
6813 padded, in order to avoid generating accesses to these sub-fields that
6814 are wider than the field.
6816 We avoid the transformation if it is not required or potentially useful,
6817 as it might entail an increase of the field's alignment and have ripple
6818 effects on the outer record type. A typical case is a field known to be
6819 byte-aligned and not to share a byte with another field. */
6820 if (!needs_strict_alignment
6821 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6822 && !TYPE_FAT_POINTER_P (gnu_field_type)
6823 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6826 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6827 || (Present (Component_Clause (gnat_field))
6828 && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6829 % BITS_PER_UNIT == 0
6830 && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6832 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6833 if (gnu_packable_type != gnu_field_type)
6835 gnu_field_type = gnu_packable_type;
6837 gnu_size = rm_size (gnu_field_type);
6841 /* If we are packing the record and the field is BLKmode, round the
6842 size up to a byte boundary. */
6843 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6844 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6846 if (Present (Component_Clause (gnat_field)))
6848 Entity_Id gnat_parent
6849 = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6851 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6852 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6853 gnat_field, FIELD_DECL, false, true);
6855 /* Ensure the position does not overlap with the parent subtype, if there
6856 is one. This test is omitted if the parent of the tagged type has a
6857 full rep clause since, in this case, component clauses are allowed to
6858 overlay the space allocated for the parent type and the front-end has
6859 checked that there are no overlapping components. */
6860 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6862 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6864 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6865 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6868 ("offset of& must be beyond parent{, minimum allowed is ^}",
6869 First_Bit (Component_Clause (gnat_field)), gnat_field,
6870 TYPE_SIZE_UNIT (gnu_parent));
6874 /* If this field needs strict alignment, ensure the record is
6875 sufficiently aligned and that that position and size are
6876 consistent with the alignment. */
6877 if (needs_strict_alignment)
6879 TYPE_ALIGN (gnu_record_type)
6880 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6883 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6885 if (Is_Atomic (gnat_field) || Is_Atomic (gnat_field_type))
6887 ("atomic field& must be natural size of type{ (^)}",
6888 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6889 TYPE_SIZE (gnu_field_type));
6891 else if (Is_Aliased (gnat_field))
6893 ("size of aliased field& must be ^ bits",
6894 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6895 TYPE_SIZE (gnu_field_type));
6897 else if (Strict_Alignment (gnat_field_type))
6899 ("size of & with aliased or tagged components not ^ bits",
6900 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6901 TYPE_SIZE (gnu_field_type));
6903 gnu_size = NULL_TREE;
6906 if (!integer_zerop (size_binop
6907 (TRUNC_MOD_EXPR, gnu_pos,
6908 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6912 ("position of volatile field& must be multiple of ^ bits",
6913 First_Bit (Component_Clause (gnat_field)), gnat_field,
6914 TYPE_ALIGN (gnu_field_type));
6916 else if (Is_Aliased (gnat_field))
6918 ("position of aliased field& must be multiple of ^ bits",
6919 First_Bit (Component_Clause (gnat_field)), gnat_field,
6920 TYPE_ALIGN (gnu_field_type));
6922 else if (Strict_Alignment (gnat_field_type))
6924 ("position of & with aliased or tagged components not multiple of ^ bits",
6925 First_Bit (Component_Clause (gnat_field)), gnat_field,
6926 TYPE_ALIGN (gnu_field_type));
6931 gnu_pos = NULL_TREE;
6935 if (Is_Atomic (gnat_field))
6936 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6939 /* If the record has rep clauses and this is the tag field, make a rep
6940 clause for it as well. */
6941 else if (Has_Specified_Layout (Scope (gnat_field))
6942 && Chars (gnat_field) == Name_uTag)
6944 gnu_pos = bitsize_zero_node;
6945 gnu_size = TYPE_SIZE (gnu_field_type);
6949 gnu_pos = NULL_TREE;
6951 /* We need to make the size the maximum for the type if it is
6952 self-referential and an unconstrained type. In that case, we can't
6953 pack the field since we can't make a copy to align it. */
6954 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6956 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6957 && !Is_Constrained (Underlying_Type (gnat_field_type)))
6959 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6963 /* If a size is specified, adjust the field's type to it. */
6966 tree orig_field_type;
6968 /* If the field's type is justified modular, we would need to remove
6969 the wrapper to (better) meet the layout requirements. However we
6970 can do so only if the field is not aliased to preserve the unique
6971 layout and if the prescribed size is not greater than that of the
6972 packed array to preserve the justification. */
6973 if (!needs_strict_alignment
6974 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6975 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6976 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6978 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6981 = make_type_from_size (gnu_field_type, gnu_size,
6982 Has_Biased_Representation (gnat_field));
6984 orig_field_type = gnu_field_type;
6985 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6986 false, false, definition, true);
6988 /* If a padding record was made, declare it now since it will never be
6989 declared otherwise. This is necessary to ensure that its subtrees
6990 are properly marked. */
6991 if (gnu_field_type != orig_field_type
6992 && !DECL_P (TYPE_NAME (gnu_field_type)))
6993 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL,
6994 true, debug_info_p, gnat_field);
6997 /* Otherwise (or if there was an error), don't specify a position. */
6999 gnu_pos = NULL_TREE;
7001 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
7002 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
7004 /* Now create the decl for the field. */
7006 = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
7007 gnu_size, gnu_pos, packed, Is_Aliased (gnat_field));
7008 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
7009 TREE_THIS_VOLATILE (gnu_field) = TREE_SIDE_EFFECTS (gnu_field) = is_volatile;
7011 if (Ekind (gnat_field) == E_Discriminant)
7012 DECL_DISCRIMINANT_NUMBER (gnu_field)
7013 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
7018 /* Return true if TYPE is a type with variable size, a padding type with a
7019 field of variable size or is a record that has a field such a field. */
7022 is_variable_size (tree type)
7026 if (!TREE_CONSTANT (TYPE_SIZE (type)))
7029 if (TYPE_IS_PADDING_P (type)
7030 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
7033 if (TREE_CODE (type) != RECORD_TYPE
7034 && TREE_CODE (type) != UNION_TYPE
7035 && TREE_CODE (type) != QUAL_UNION_TYPE)
7038 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
7039 if (is_variable_size (TREE_TYPE (field)))
7045 /* qsort comparer for the bit positions of two record components. */
7048 compare_field_bitpos (const PTR rt1, const PTR rt2)
7050 const_tree const field1 = * (const_tree const *) rt1;
7051 const_tree const field2 = * (const_tree const *) rt2;
7053 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
7055 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
7058 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
7059 the result as the field list of GNU_RECORD_TYPE and finish it up. When
7060 called from gnat_to_gnu_entity during the processing of a record type
7061 definition, the GCC node for the parent, if any, will be the single field
7062 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
7063 GNU_FIELD_LIST. The other calls to this function are recursive calls for
7064 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
7066 PACKED is 1 if this is for a packed record, -1 if this is for a record
7067 with Component_Alignment of Storage_Unit, -2 if this is for a record
7068 with a specified alignment.
7070 DEFINITION is true if we are defining this record type.
7072 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
7073 out the record. This means the alignment only serves to force fields to
7074 be bitfields, but not to require the record to be that aligned. This is
7077 ALL_REP is true if a rep clause is present for all the fields.
7079 UNCHECKED_UNION is true if we are building this type for a record with a
7080 Pragma Unchecked_Union.
7082 DEBUG_INFO is true if we need to write debug information about the type.
7084 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
7085 mean that its contents may be unused as well, only the container itself.
7087 REORDER is true if we are permitted to reorder components of this type.
7089 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
7090 with a rep clause is to be added; in this case, that is all that should
7091 be done with such fields. */
7094 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
7095 tree gnu_field_list, int packed, bool definition,
7096 bool cancel_alignment, bool all_rep,
7097 bool unchecked_union, bool debug_info,
7098 bool maybe_unused, bool reorder,
7099 tree *p_gnu_rep_list)
7101 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
7102 bool layout_with_rep = false;
7103 Node_Id component_decl, variant_part;
7104 tree gnu_field, gnu_next, gnu_last;
7105 tree gnu_variant_part = NULL_TREE;
7106 tree gnu_rep_list = NULL_TREE;
7107 tree gnu_var_list = NULL_TREE;
7108 tree gnu_self_list = NULL_TREE;
7110 /* For each component referenced in a component declaration create a GCC
7111 field and add it to the list, skipping pragmas in the GNAT list. */
7112 gnu_last = tree_last (gnu_field_list);
7113 if (Present (Component_Items (gnat_component_list)))
7115 = First_Non_Pragma (Component_Items (gnat_component_list));
7116 Present (component_decl);
7117 component_decl = Next_Non_Pragma (component_decl))
7119 Entity_Id gnat_field = Defining_Entity (component_decl);
7120 Name_Id gnat_name = Chars (gnat_field);
7122 /* If present, the _Parent field must have been created as the single
7123 field of the record type. Put it before any other fields. */
7124 if (gnat_name == Name_uParent)
7126 gnu_field = TYPE_FIELDS (gnu_record_type);
7127 gnu_field_list = chainon (gnu_field_list, gnu_field);
7131 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
7132 definition, debug_info);
7134 /* If this is the _Tag field, put it before any other fields. */
7135 if (gnat_name == Name_uTag)
7136 gnu_field_list = chainon (gnu_field_list, gnu_field);
7138 /* If this is the _Controller field, put it before the other
7139 fields except for the _Tag or _Parent field. */
7140 else if (gnat_name == Name_uController && gnu_last)
7142 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
7143 DECL_CHAIN (gnu_last) = gnu_field;
7146 /* If this is a regular field, put it after the other fields. */
7149 DECL_CHAIN (gnu_field) = gnu_field_list;
7150 gnu_field_list = gnu_field;
7152 gnu_last = gnu_field;
7156 save_gnu_tree (gnat_field, gnu_field, false);
7159 /* At the end of the component list there may be a variant part. */
7160 variant_part = Variant_Part (gnat_component_list);
7162 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7163 mutually exclusive and should go in the same memory. To do this we need
7164 to treat each variant as a record whose elements are created from the
7165 component list for the variant. So here we create the records from the
7166 lists for the variants and put them all into the QUAL_UNION_TYPE.
7167 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7168 use GNU_RECORD_TYPE if there are no fields so far. */
7169 if (Present (variant_part))
7171 Node_Id gnat_discr = Name (variant_part), variant;
7172 tree gnu_discr = gnat_to_gnu (gnat_discr);
7173 tree gnu_name = TYPE_NAME (gnu_record_type);
7175 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
7177 tree gnu_union_type, gnu_union_name;
7178 tree gnu_variant_list = NULL_TREE;
7180 if (TREE_CODE (gnu_name) == TYPE_DECL)
7181 gnu_name = DECL_NAME (gnu_name);
7184 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
7186 /* Reuse an enclosing union if all fields are in the variant part
7187 and there is no representation clause on the record, to match
7188 the layout of C unions. There is an associated check below. */
7190 && TREE_CODE (gnu_record_type) == UNION_TYPE
7191 && !TYPE_PACKED (gnu_record_type))
7192 gnu_union_type = gnu_record_type;
7196 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
7198 TYPE_NAME (gnu_union_type) = gnu_union_name;
7199 TYPE_ALIGN (gnu_union_type) = 0;
7200 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
7203 for (variant = First_Non_Pragma (Variants (variant_part));
7205 variant = Next_Non_Pragma (variant))
7207 tree gnu_variant_type = make_node (RECORD_TYPE);
7208 tree gnu_inner_name;
7211 Get_Variant_Encoding (variant);
7212 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
7213 TYPE_NAME (gnu_variant_type)
7214 = concat_name (gnu_union_name,
7215 IDENTIFIER_POINTER (gnu_inner_name));
7217 /* Set the alignment of the inner type in case we need to make
7218 inner objects into bitfields, but then clear it out so the
7219 record actually gets only the alignment required. */
7220 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
7221 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
7223 /* Similarly, if the outer record has a size specified and all
7224 fields have record rep clauses, we can propagate the size
7225 into the variant part. */
7226 if (all_rep_and_size)
7228 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
7229 TYPE_SIZE_UNIT (gnu_variant_type)
7230 = TYPE_SIZE_UNIT (gnu_record_type);
7233 /* Add the fields into the record type for the variant. Note that
7234 we aren't sure to really use it at this point, see below. */
7235 components_to_record (gnu_variant_type, Component_List (variant),
7236 NULL_TREE, packed, definition,
7237 !all_rep_and_size, all_rep,
7238 unchecked_union, debug_info,
7239 true, reorder, &gnu_rep_list);
7241 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
7243 Set_Present_Expr (variant, annotate_value (gnu_qual));
7245 /* If this is an Unchecked_Union and we have exactly one field,
7246 use this field directly to match the layout of C unions. */
7248 && TYPE_FIELDS (gnu_variant_type)
7249 && !DECL_CHAIN (TYPE_FIELDS (gnu_variant_type)))
7250 gnu_field = TYPE_FIELDS (gnu_variant_type);
7253 /* Deal with packedness like in gnat_to_gnu_field. */
7255 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
7257 /* Finalize the record type now. We used to throw away
7258 empty records but we no longer do that because we need
7259 them to generate complete debug info for the variant;
7260 otherwise, the union type definition will be lacking
7261 the fields associated with these empty variants. */
7262 rest_of_record_type_compilation (gnu_variant_type);
7263 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
7264 NULL, true, debug_info, gnat_component_list);
7267 = create_field_decl (gnu_inner_name, gnu_variant_type,
7270 ? TYPE_SIZE (gnu_variant_type) : 0,
7272 ? bitsize_zero_node : 0,
7275 DECL_INTERNAL_P (gnu_field) = 1;
7277 if (!unchecked_union)
7278 DECL_QUALIFIER (gnu_field) = gnu_qual;
7281 DECL_CHAIN (gnu_field) = gnu_variant_list;
7282 gnu_variant_list = gnu_field;
7285 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7286 if (gnu_variant_list)
7288 int union_field_packed;
7290 if (all_rep_and_size)
7292 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
7293 TYPE_SIZE_UNIT (gnu_union_type)
7294 = TYPE_SIZE_UNIT (gnu_record_type);
7297 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
7298 all_rep_and_size ? 1 : 0, debug_info);
7300 /* If GNU_UNION_TYPE is our record type, it means we must have an
7301 Unchecked_Union with no fields. Verify that and, if so, just
7303 if (gnu_union_type == gnu_record_type)
7305 gcc_assert (unchecked_union
7311 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
7312 NULL, true, debug_info, gnat_component_list);
7314 /* Deal with packedness like in gnat_to_gnu_field. */
7316 = adjust_packed (gnu_union_type, gnu_record_type, packed);
7319 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
7320 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
7321 all_rep ? bitsize_zero_node : 0,
7322 union_field_packed, 0);
7324 DECL_INTERNAL_P (gnu_variant_part) = 1;
7325 DECL_CHAIN (gnu_variant_part) = gnu_field_list;
7326 gnu_field_list = gnu_variant_part;
7330 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
7331 permitted to reorder components, self-referential sizes or variable sizes.
7332 If they do, pull them out and put them onto the appropriate list. We have
7333 to do this in a separate pass since we want to handle the discriminants
7334 but can't play with them until we've used them in debugging data above.
7336 ??? If we reorder them, debugging information will be wrong but there is
7337 nothing that can be done about this at the moment. */
7338 gnu_last = NULL_TREE;
7340 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7343 DECL_CHAIN (gnu_last) = gnu_next; \
7345 gnu_field_list = gnu_next; \
7347 DECL_CHAIN (gnu_field) = (LIST); \
7348 (LIST) = gnu_field; \
7351 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
7353 gnu_next = DECL_CHAIN (gnu_field);
7355 if (DECL_FIELD_OFFSET (gnu_field))
7357 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
7363 /* Pull out the variant part and put it onto GNU_SELF_LIST. */
7364 if (gnu_field == gnu_variant_part)
7366 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7370 /* Skip internal fields and fields with fixed size. */
7371 if (!DECL_INTERNAL_P (gnu_field)
7372 && !(DECL_SIZE (gnu_field)
7373 && TREE_CODE (DECL_SIZE (gnu_field)) == INTEGER_CST))
7375 tree type_size = TYPE_SIZE (TREE_TYPE (gnu_field));
7377 if (CONTAINS_PLACEHOLDER_P (type_size))
7379 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7383 if (TREE_CODE (type_size) != INTEGER_CST)
7385 MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
7391 gnu_last = gnu_field;
7394 #undef MOVE_FROM_FIELD_LIST_TO
7396 /* If permitted, we reorder the components as follows:
7398 1) all fixed length fields,
7399 2) all fields whose length doesn't depend on discriminants,
7400 3) all fields whose length depends on discriminants,
7401 4) the variant part,
7403 within the record and within each variant recursively. */
7406 = chainon (nreverse (gnu_self_list),
7407 chainon (nreverse (gnu_var_list), gnu_field_list));
7409 /* If we have any fields in our rep'ed field list and it is not the case that
7410 all the fields in the record have rep clauses and P_REP_LIST is nonzero,
7411 set it and ignore these fields. */
7412 if (gnu_rep_list && p_gnu_rep_list && !all_rep)
7413 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
7415 /* Otherwise, sort the fields by bit position and put them into their own
7416 record, before the others, if we also have fields without rep clauses. */
7417 else if (gnu_rep_list)
7420 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
7421 int i, len = list_length (gnu_rep_list);
7422 tree *gnu_arr = XALLOCAVEC (tree, len);
7424 for (gnu_field = gnu_rep_list, i = 0;
7426 gnu_field = DECL_CHAIN (gnu_field), i++)
7427 gnu_arr[i] = gnu_field;
7429 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7431 /* Put the fields in the list in order of increasing position, which
7432 means we start from the end. */
7433 gnu_rep_list = NULL_TREE;
7434 for (i = len - 1; i >= 0; i--)
7436 DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
7437 gnu_rep_list = gnu_arr[i];
7438 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7443 finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info);
7445 = create_field_decl (get_identifier ("REP"), gnu_rep_type,
7446 gnu_record_type, NULL_TREE, NULL_TREE, 0, 1);
7447 DECL_INTERNAL_P (gnu_field) = 1;
7448 gnu_field_list = chainon (gnu_field_list, gnu_field);
7452 layout_with_rep = true;
7453 gnu_field_list = nreverse (gnu_rep_list);
7457 if (cancel_alignment)
7458 TYPE_ALIGN (gnu_record_type) = 0;
7460 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
7461 layout_with_rep ? 1 : 0, debug_info && !maybe_unused);
7464 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7465 placed into an Esize, Component_Bit_Offset, or Component_Size value
7466 in the GNAT tree. */
7469 annotate_value (tree gnu_size)
7472 Node_Ref_Or_Val ops[3], ret;
7473 struct tree_int_map **h = NULL;
7476 /* See if we've already saved the value for this node. */
7477 if (EXPR_P (gnu_size))
7479 struct tree_int_map in;
7480 if (!annotate_value_cache)
7481 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
7482 tree_int_map_eq, 0);
7483 in.base.from = gnu_size;
7484 h = (struct tree_int_map **)
7485 htab_find_slot (annotate_value_cache, &in, INSERT);
7488 return (Node_Ref_Or_Val) (*h)->to;
7491 /* If we do not return inside this switch, TCODE will be set to the
7492 code to use for a Create_Node operand and LEN (set above) will be
7493 the number of recursive calls for us to make. */
7495 switch (TREE_CODE (gnu_size))
7498 if (TREE_OVERFLOW (gnu_size))
7501 /* This may come from a conversion from some smaller type, so ensure
7502 this is in bitsizetype. */
7503 gnu_size = convert (bitsizetype, gnu_size);
7505 /* For a negative value, build NEGATE_EXPR of the opposite. Such values
7506 appear in expressions containing aligning patterns. Note that, since
7507 sizetype is sign-extended but nonetheless unsigned, we don't directly
7508 use tree_int_cst_sgn. */
7509 if (TREE_INT_CST_HIGH (gnu_size) < 0)
7511 tree op_size = fold_build1 (NEGATE_EXPR, bitsizetype, gnu_size);
7512 return annotate_value (build1 (NEGATE_EXPR, bitsizetype, op_size));
7515 return UI_From_gnu (gnu_size);
7518 /* The only case we handle here is a simple discriminant reference. */
7519 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
7520 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
7521 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7522 return Create_Node (Discrim_Val,
7523 annotate_value (DECL_DISCRIMINANT_NUMBER
7524 (TREE_OPERAND (gnu_size, 1))),
7529 CASE_CONVERT: case NON_LVALUE_EXPR:
7530 return annotate_value (TREE_OPERAND (gnu_size, 0));
7532 /* Now just list the operations we handle. */
7533 case COND_EXPR: tcode = Cond_Expr; break;
7534 case PLUS_EXPR: tcode = Plus_Expr; break;
7535 case MINUS_EXPR: tcode = Minus_Expr; break;
7536 case MULT_EXPR: tcode = Mult_Expr; break;
7537 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
7538 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
7539 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
7540 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
7541 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
7542 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
7543 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
7544 case NEGATE_EXPR: tcode = Negate_Expr; break;
7545 case MIN_EXPR: tcode = Min_Expr; break;
7546 case MAX_EXPR: tcode = Max_Expr; break;
7547 case ABS_EXPR: tcode = Abs_Expr; break;
7548 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
7549 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
7550 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
7551 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
7552 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
7553 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
7554 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
7555 case LT_EXPR: tcode = Lt_Expr; break;
7556 case LE_EXPR: tcode = Le_Expr; break;
7557 case GT_EXPR: tcode = Gt_Expr; break;
7558 case GE_EXPR: tcode = Ge_Expr; break;
7559 case EQ_EXPR: tcode = Eq_Expr; break;
7560 case NE_EXPR: tcode = Ne_Expr; break;
7564 tree t = maybe_inline_call_in_expr (gnu_size);
7566 return annotate_value (t);
7569 /* Fall through... */
7575 /* Now get each of the operands that's relevant for this code. If any
7576 cannot be expressed as a repinfo node, say we can't. */
7577 for (i = 0; i < 3; i++)
7580 for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
7582 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7583 if (ops[i] == No_Uint)
7587 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7589 /* Save the result in the cache. */
7592 *h = ggc_alloc_tree_int_map ();
7593 (*h)->base.from = gnu_size;
7600 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7601 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7602 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7603 BY_REF is true if the object is used by reference and BY_DOUBLE_REF is
7604 true if the object is used by double reference. */
7607 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref,
7613 gnu_type = TREE_TYPE (gnu_type);
7615 if (TYPE_IS_FAT_POINTER_P (gnu_type))
7616 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7618 gnu_type = TREE_TYPE (gnu_type);
7621 if (Unknown_Esize (gnat_entity))
7623 if (TREE_CODE (gnu_type) == RECORD_TYPE
7624 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7625 size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
7627 size = TYPE_SIZE (gnu_type);
7630 Set_Esize (gnat_entity, annotate_value (size));
7633 if (Unknown_Alignment (gnat_entity))
7634 Set_Alignment (gnat_entity,
7635 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7638 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7639 Return NULL_TREE if there is no such element in the list. */
7642 purpose_member_field (const_tree elem, tree list)
7646 tree field = TREE_PURPOSE (list);
7647 if (SAME_FIELD_P (field, elem))
7649 list = TREE_CHAIN (list);
7654 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7655 set Component_Bit_Offset and Esize of the components to the position and
7656 size used by Gigi. */
7659 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7661 Entity_Id gnat_field;
7664 /* We operate by first making a list of all fields and their position (we
7665 can get the size easily) and then update all the sizes in the tree. */
7667 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7668 BIGGEST_ALIGNMENT, NULL_TREE);
7670 for (gnat_field = First_Entity (gnat_entity);
7671 Present (gnat_field);
7672 gnat_field = Next_Entity (gnat_field))
7673 if (Ekind (gnat_field) == E_Component
7674 || (Ekind (gnat_field) == E_Discriminant
7675 && !Is_Unchecked_Union (Scope (gnat_field))))
7677 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
7683 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
7685 /* In this mode the tag and parent components are not
7686 generated, so we add the appropriate offset to each
7687 component. For a component appearing in the current
7688 extension, the offset is the size of the parent. */
7689 if (Is_Derived_Type (gnat_entity)
7690 && Original_Record_Component (gnat_field) == gnat_field)
7692 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7695 parent_offset = bitsize_int (POINTER_SIZE);
7698 parent_offset = bitsize_zero_node;
7700 Set_Component_Bit_Offset
7703 (size_binop (PLUS_EXPR,
7704 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7705 TREE_VEC_ELT (TREE_VALUE (t), 2)),
7708 Set_Esize (gnat_field,
7709 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7711 else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7713 /* If there is no entry, this is an inherited component whose
7714 position is the same as in the parent type. */
7715 Set_Component_Bit_Offset
7717 Component_Bit_Offset (Original_Record_Component (gnat_field)));
7719 Set_Esize (gnat_field,
7720 Esize (Original_Record_Component (gnat_field)));
7725 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7726 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7727 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7728 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7729 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7730 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7731 pre-existing list to be chained to the newly created entries. */
7734 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
7735 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
7739 for (gnu_field = TYPE_FIELDS (gnu_type);
7741 gnu_field = DECL_CHAIN (gnu_field))
7743 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
7744 DECL_FIELD_BIT_OFFSET (gnu_field));
7745 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
7746 DECL_FIELD_OFFSET (gnu_field));
7747 unsigned int our_offset_align
7748 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
7749 tree v = make_tree_vec (3);
7751 TREE_VEC_ELT (v, 0) = gnu_our_offset;
7752 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
7753 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
7754 gnu_list = tree_cons (gnu_field, v, gnu_list);
7756 /* Recurse on internal fields, flattening the nested fields except for
7757 those in the variant part, if requested. */
7758 if (DECL_INTERNAL_P (gnu_field))
7760 tree gnu_field_type = TREE_TYPE (gnu_field);
7761 if (do_not_flatten_variant
7762 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
7764 = build_position_list (gnu_field_type, do_not_flatten_variant,
7765 size_zero_node, bitsize_zero_node,
7766 BIGGEST_ALIGNMENT, gnu_list);
7769 = build_position_list (gnu_field_type, do_not_flatten_variant,
7770 gnu_our_offset, gnu_our_bitpos,
7771 our_offset_align, gnu_list);
7778 /* Return a VEC describing the substitutions needed to reflect the
7779 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7780 be in any order. The values in an element of the VEC are in the form
7781 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
7782 a definition of GNAT_SUBTYPE. */
7784 static VEC(subst_pair,heap) *
7785 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
7787 VEC(subst_pair,heap) *gnu_vec = NULL;
7788 Entity_Id gnat_discrim;
7791 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
7792 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
7793 Present (gnat_discrim);
7794 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
7795 gnat_value = Next_Elmt (gnat_value))
7796 /* Ignore access discriminants. */
7797 if (!Is_Access_Type (Etype (Node (gnat_value))))
7799 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
7800 tree replacement = convert (TREE_TYPE (gnu_field),
7801 elaborate_expression
7802 (Node (gnat_value), gnat_subtype,
7803 get_entity_name (gnat_discrim),
7804 definition, true, false));
7805 subst_pair *s = VEC_safe_push (subst_pair, heap, gnu_vec, NULL);
7806 s->discriminant = gnu_field;
7807 s->replacement = replacement;
7813 /* Scan all fields in QUAL_UNION_TYPE and return a VEC describing the
7814 variants of QUAL_UNION_TYPE that are still relevant after applying
7815 the substitutions described in SUBST_LIST. VARIANT_LIST is a
7816 pre-existing VEC onto which newly created entries should be
7819 static VEC(variant_desc,heap) *
7820 build_variant_list (tree qual_union_type, VEC(subst_pair,heap) *subst_list,
7821 VEC(variant_desc,heap) *variant_list)
7825 for (gnu_field = TYPE_FIELDS (qual_union_type);
7827 gnu_field = DECL_CHAIN (gnu_field))
7829 tree qual = DECL_QUALIFIER (gnu_field);
7833 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
7834 qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
7836 /* If the new qualifier is not unconditionally false, its variant may
7837 still be accessed. */
7838 if (!integer_zerop (qual))
7841 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
7843 v = VEC_safe_push (variant_desc, heap, variant_list, NULL);
7844 v->type = variant_type;
7845 v->field = gnu_field;
7847 v->record = NULL_TREE;
7849 /* Recurse on the variant subpart of the variant, if any. */
7850 variant_subpart = get_variant_part (variant_type);
7851 if (variant_subpart)
7852 variant_list = build_variant_list (TREE_TYPE (variant_subpart),
7853 subst_list, variant_list);
7855 /* If the new qualifier is unconditionally true, the subsequent
7856 variants cannot be accessed. */
7857 if (integer_onep (qual))
7862 return variant_list;
7865 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7866 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
7867 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
7868 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
7869 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
7870 true if we are being called to process the Component_Size of GNAT_OBJECT;
7871 this is used only for error messages. ZERO_OK is true if a size of zero
7872 is permitted; if ZERO_OK is false, it means that a size of zero should be
7873 treated as an unspecified size. */
7876 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
7877 enum tree_code kind, bool component_p, bool zero_ok)
7879 Node_Id gnat_error_node;
7880 tree type_size, size;
7882 /* Return 0 if no size was specified. */
7883 if (uint_size == No_Uint)
7886 /* Ignore a negative size since that corresponds to our back-annotation. */
7887 if (UI_Lt (uint_size, Uint_0))
7890 /* Find the node to use for error messages. */
7891 if ((Ekind (gnat_object) == E_Component
7892 || Ekind (gnat_object) == E_Discriminant)
7893 && Present (Component_Clause (gnat_object)))
7894 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
7895 else if (Present (Size_Clause (gnat_object)))
7896 gnat_error_node = Expression (Size_Clause (gnat_object));
7898 gnat_error_node = gnat_object;
7900 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7901 but cannot be represented in bitsizetype. */
7902 size = UI_To_gnu (uint_size, bitsizetype);
7903 if (TREE_OVERFLOW (size))
7906 post_error_ne ("component size for& is too large", gnat_error_node,
7909 post_error_ne ("size for& is too large", gnat_error_node,
7914 /* Ignore a zero size if it is not permitted. */
7915 if (!zero_ok && integer_zerop (size))
7918 /* The size of objects is always a multiple of a byte. */
7919 if (kind == VAR_DECL
7920 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
7923 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7924 gnat_error_node, gnat_object);
7926 post_error_ne ("size for& is not a multiple of Storage_Unit",
7927 gnat_error_node, gnat_object);
7931 /* If this is an integral type or a packed array type, the front-end has
7932 already verified the size, so we need not do it here (which would mean
7933 checking against the bounds). However, if this is an aliased object,
7934 it may not be smaller than the type of the object. */
7935 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7936 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7939 /* If the object is a record that contains a template, add the size of the
7940 template to the specified size. */
7941 if (TREE_CODE (gnu_type) == RECORD_TYPE
7942 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7943 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7945 if (kind == VAR_DECL
7946 /* If a type needs strict alignment, a component of this type in
7947 a packed record cannot be packed and thus uses the type size. */
7948 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
7949 type_size = TYPE_SIZE (gnu_type);
7951 type_size = rm_size (gnu_type);
7953 /* Modify the size of a discriminated type to be the maximum size. */
7954 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7955 type_size = max_size (type_size, true);
7957 /* If this is an access type or a fat pointer, the minimum size is that given
7958 by the smallest integral mode that's valid for pointers. */
7959 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
7961 enum machine_mode p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7962 while (!targetm.valid_pointer_mode (p_mode))
7963 p_mode = GET_MODE_WIDER_MODE (p_mode);
7964 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7967 /* Issue an error either if the default size of the object isn't a constant
7968 or if the new size is smaller than it. */
7969 if (TREE_CODE (type_size) != INTEGER_CST
7970 || TREE_OVERFLOW (type_size)
7971 || tree_int_cst_lt (size, type_size))
7975 ("component size for& too small{, minimum allowed is ^}",
7976 gnat_error_node, gnat_object, type_size);
7979 ("size for& too small{, minimum allowed is ^}",
7980 gnat_error_node, gnat_object, type_size);
7987 /* Similarly, but both validate and process a value of RM size. This routine
7988 is only called for types. */
7991 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7993 Node_Id gnat_attr_node;
7994 tree old_size, size;
7996 /* Do nothing if no size was specified. */
7997 if (uint_size == No_Uint)
8000 /* Ignore a negative size since that corresponds to our back-annotation. */
8001 if (UI_Lt (uint_size, Uint_0))
8004 /* Only issue an error if a Value_Size clause was explicitly given.
8005 Otherwise, we'd be duplicating an error on the Size clause. */
8007 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
8009 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8010 but cannot be represented in bitsizetype. */
8011 size = UI_To_gnu (uint_size, bitsizetype);
8012 if (TREE_OVERFLOW (size))
8014 if (Present (gnat_attr_node))
8015 post_error_ne ("Value_Size for& is too large", gnat_attr_node,
8020 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8021 exists, or this is an integer type, in which case the front-end will
8022 have always set it. */
8023 if (No (gnat_attr_node)
8024 && integer_zerop (size)
8025 && !Has_Size_Clause (gnat_entity)
8026 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8029 old_size = rm_size (gnu_type);
8031 /* If the old size is self-referential, get the maximum size. */
8032 if (CONTAINS_PLACEHOLDER_P (old_size))
8033 old_size = max_size (old_size, true);
8035 /* Issue an error either if the old size of the object isn't a constant or
8036 if the new size is smaller than it. The front-end has already verified
8037 this for scalar and packed array types. */
8038 if (TREE_CODE (old_size) != INTEGER_CST
8039 || TREE_OVERFLOW (old_size)
8040 || (AGGREGATE_TYPE_P (gnu_type)
8041 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
8042 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
8043 && !(TYPE_IS_PADDING_P (gnu_type)
8044 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
8045 && TYPE_PACKED_ARRAY_TYPE_P
8046 (TREE_TYPE (TYPE_FIELDS (gnu_type))))
8047 && tree_int_cst_lt (size, old_size)))
8049 if (Present (gnat_attr_node))
8051 ("Value_Size for& too small{, minimum allowed is ^}",
8052 gnat_attr_node, gnat_entity, old_size);
8056 /* Otherwise, set the RM size proper for integral types... */
8057 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
8058 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8059 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
8060 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
8061 SET_TYPE_RM_SIZE (gnu_type, size);
8063 /* ...or the Ada size for record and union types. */
8064 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
8065 || TREE_CODE (gnu_type) == UNION_TYPE
8066 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8067 && !TYPE_FAT_POINTER_P (gnu_type))
8068 SET_TYPE_ADA_SIZE (gnu_type, size);
8071 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
8072 If TYPE is the best type, return it. Otherwise, make a new type. We
8073 only support new integral and pointer types. FOR_BIASED is true if
8074 we are making a biased type. */
8077 make_type_from_size (tree type, tree size_tree, bool for_biased)
8079 unsigned HOST_WIDE_INT size;
8083 /* If size indicates an error, just return TYPE to avoid propagating
8084 the error. Likewise if it's too large to represent. */
8085 if (!size_tree || !host_integerp (size_tree, 1))
8088 size = tree_low_cst (size_tree, 1);
8090 switch (TREE_CODE (type))
8095 biased_p = (TREE_CODE (type) == INTEGER_TYPE
8096 && TYPE_BIASED_REPRESENTATION_P (type));
8098 /* Integer types with precision 0 are forbidden. */
8102 /* Only do something if the type is not a packed array type and
8103 doesn't already have the proper size. */
8104 if (TYPE_PACKED_ARRAY_TYPE_P (type)
8105 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
8108 biased_p |= for_biased;
8109 if (size > LONG_LONG_TYPE_SIZE)
8110 size = LONG_LONG_TYPE_SIZE;
8112 if (TYPE_UNSIGNED (type) || biased_p)
8113 new_type = make_unsigned_type (size);
8115 new_type = make_signed_type (size);
8116 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
8117 SET_TYPE_RM_MIN_VALUE (new_type,
8118 convert (TREE_TYPE (new_type),
8119 TYPE_MIN_VALUE (type)));
8120 SET_TYPE_RM_MAX_VALUE (new_type,
8121 convert (TREE_TYPE (new_type),
8122 TYPE_MAX_VALUE (type)));
8123 /* Copy the name to show that it's essentially the same type and
8124 not a subrange type. */
8125 TYPE_NAME (new_type) = TYPE_NAME (type);
8126 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
8127 SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
8131 /* Do something if this is a fat pointer, in which case we
8132 may need to return the thin pointer. */
8133 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
8135 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
8136 if (!targetm.valid_pointer_mode (p_mode))
8139 build_pointer_type_for_mode
8140 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
8146 /* Only do something if this is a thin pointer, in which case we
8147 may need to return the fat pointer. */
8148 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
8150 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
8160 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8161 a type or object whose present alignment is ALIGN. If this alignment is
8162 valid, return it. Otherwise, give an error and return ALIGN. */
8165 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
8167 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
8168 unsigned int new_align;
8169 Node_Id gnat_error_node;
8171 /* Don't worry about checking alignment if alignment was not specified
8172 by the source program and we already posted an error for this entity. */
8173 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
8176 /* Post the error on the alignment clause if any. Note, for the implicit
8177 base type of an array type, the alignment clause is on the first
8179 if (Present (Alignment_Clause (gnat_entity)))
8180 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
8182 else if (Is_Itype (gnat_entity)
8183 && Is_Array_Type (gnat_entity)
8184 && Etype (gnat_entity) == gnat_entity
8185 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
8187 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
8190 gnat_error_node = gnat_entity;
8192 /* Within GCC, an alignment is an integer, so we must make sure a value is
8193 specified that fits in that range. Also, there is an upper bound to
8194 alignments we can support/allow. */
8195 if (!UI_Is_In_Int_Range (alignment)
8196 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
8197 post_error_ne_num ("largest supported alignment for& is ^",
8198 gnat_error_node, gnat_entity, max_allowed_alignment);
8199 else if (!(Present (Alignment_Clause (gnat_entity))
8200 && From_At_Mod (Alignment_Clause (gnat_entity)))
8201 && new_align * BITS_PER_UNIT < align)
8203 unsigned int double_align;
8204 bool is_capped_double, align_clause;
8206 /* If the default alignment of "double" or larger scalar types is
8207 specifically capped and the new alignment is above the cap, do
8208 not post an error and change the alignment only if there is an
8209 alignment clause; this makes it possible to have the associated
8210 GCC type overaligned by default for performance reasons. */
8211 if ((double_align = double_float_alignment) > 0)
8214 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8216 = is_double_float_or_array (gnat_type, &align_clause);
8218 else if ((double_align = double_scalar_alignment) > 0)
8221 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8223 = is_double_scalar_or_array (gnat_type, &align_clause);
8226 is_capped_double = align_clause = false;
8228 if (is_capped_double && new_align >= double_align)
8231 align = new_align * BITS_PER_UNIT;
8235 if (is_capped_double)
8236 align = double_align * BITS_PER_UNIT;
8238 post_error_ne_num ("alignment for& must be at least ^",
8239 gnat_error_node, gnat_entity,
8240 align / BITS_PER_UNIT);
8245 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
8246 if (new_align > align)
8253 /* Return the smallest alignment not less than SIZE. */
8256 ceil_alignment (unsigned HOST_WIDE_INT size)
8258 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
8261 /* Verify that OBJECT, a type or decl, is something we can implement
8262 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
8263 if we require atomic components. */
8266 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
8268 Node_Id gnat_error_point = gnat_entity;
8270 enum machine_mode mode;
8274 /* There are three case of what OBJECT can be. It can be a type, in which
8275 case we take the size, alignment and mode from the type. It can be a
8276 declaration that was indirect, in which case the relevant values are
8277 that of the type being pointed to, or it can be a normal declaration,
8278 in which case the values are of the decl. The code below assumes that
8279 OBJECT is either a type or a decl. */
8280 if (TYPE_P (object))
8282 /* If this is an anonymous base type, nothing to check. Error will be
8283 reported on the source type. */
8284 if (!Comes_From_Source (gnat_entity))
8287 mode = TYPE_MODE (object);
8288 align = TYPE_ALIGN (object);
8289 size = TYPE_SIZE (object);
8291 else if (DECL_BY_REF_P (object))
8293 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
8294 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
8295 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
8299 mode = DECL_MODE (object);
8300 align = DECL_ALIGN (object);
8301 size = DECL_SIZE (object);
8304 /* Consider all floating-point types atomic and any types that that are
8305 represented by integers no wider than a machine word. */
8306 if (GET_MODE_CLASS (mode) == MODE_FLOAT
8307 || ((GET_MODE_CLASS (mode) == MODE_INT
8308 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
8309 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
8312 /* For the moment, also allow anything that has an alignment equal
8313 to its size and which is smaller than a word. */
8314 if (size && TREE_CODE (size) == INTEGER_CST
8315 && compare_tree_int (size, align) == 0
8316 && align <= BITS_PER_WORD)
8319 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
8320 gnat_node = Next_Rep_Item (gnat_node))
8322 if (!comp_p && Nkind (gnat_node) == N_Pragma
8323 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8325 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8326 else if (comp_p && Nkind (gnat_node) == N_Pragma
8327 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8328 == Pragma_Atomic_Components))
8329 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8333 post_error_ne ("atomic access to component of & cannot be guaranteed",
8334 gnat_error_point, gnat_entity);
8336 post_error_ne ("atomic access to & cannot be guaranteed",
8337 gnat_error_point, gnat_entity);
8341 /* Helper for the intrin compatibility checks family. Evaluate whether
8342 two types are definitely incompatible. */
8345 intrin_types_incompatible_p (tree t1, tree t2)
8347 enum tree_code code;
8349 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
8352 if (TYPE_MODE (t1) != TYPE_MODE (t2))
8355 if (TREE_CODE (t1) != TREE_CODE (t2))
8358 code = TREE_CODE (t1);
8364 return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
8367 case REFERENCE_TYPE:
8368 /* Assume designated types are ok. We'd need to account for char * and
8369 void * variants to do better, which could rapidly get messy and isn't
8370 clearly worth the effort. */
8380 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8381 on the Ada/builtin argument lists for the INB binding. */
8384 intrin_arglists_compatible_p (intrin_binding_t * inb)
8386 function_args_iterator ada_iter, btin_iter;
8388 function_args_iter_init (&ada_iter, inb->ada_fntype);
8389 function_args_iter_init (&btin_iter, inb->btin_fntype);
8391 /* Sequence position of the last argument we checked. */
8396 tree ada_type = function_args_iter_cond (&ada_iter);
8397 tree btin_type = function_args_iter_cond (&btin_iter);
8399 /* If we've exhausted both lists simultaneously, we're done. */
8400 if (ada_type == NULL_TREE && btin_type == NULL_TREE)
8403 /* If one list is shorter than the other, they fail to match. */
8404 if (ada_type == NULL_TREE || btin_type == NULL_TREE)
8407 /* If we're done with the Ada args and not with the internal builtin
8408 args, or the other way around, complain. */
8409 if (ada_type == void_type_node
8410 && btin_type != void_type_node)
8412 post_error ("?Ada arguments list too short!", inb->gnat_entity);
8416 if (btin_type == void_type_node
8417 && ada_type != void_type_node)
8419 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8420 inb->gnat_entity, inb->gnat_entity, argpos);
8424 /* Otherwise, check that types match for the current argument. */
8426 if (intrin_types_incompatible_p (ada_type, btin_type))
8428 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8429 inb->gnat_entity, inb->gnat_entity, argpos);
8434 function_args_iter_next (&ada_iter);
8435 function_args_iter_next (&btin_iter);
8441 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8442 on the Ada/builtin return values for the INB binding. */
8445 intrin_return_compatible_p (intrin_binding_t * inb)
8447 tree ada_return_type = TREE_TYPE (inb->ada_fntype);
8448 tree btin_return_type = TREE_TYPE (inb->btin_fntype);
8450 /* Accept function imported as procedure, common and convenient. */
8451 if (VOID_TYPE_P (ada_return_type)
8452 && !VOID_TYPE_P (btin_return_type))
8455 /* Check return types compatibility otherwise. Note that this
8456 handles void/void as well. */
8457 if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
8459 post_error ("?intrinsic binding type mismatch on return value!",
8467 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8468 compatible. Issue relevant warnings when they are not.
8470 This is intended as a light check to diagnose the most obvious cases, not
8471 as a full fledged type compatibility predicate. It is the programmer's
8472 responsibility to ensure correctness of the Ada declarations in Imports,
8473 especially when binding straight to a compiler internal. */
8476 intrin_profiles_compatible_p (intrin_binding_t * inb)
8478 /* Check compatibility on return values and argument lists, each responsible
8479 for posting warnings as appropriate. Ensure use of the proper sloc for
8482 bool arglists_compatible_p, return_compatible_p;
8483 location_t saved_location = input_location;
8485 Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
8487 return_compatible_p = intrin_return_compatible_p (inb);
8488 arglists_compatible_p = intrin_arglists_compatible_p (inb);
8490 input_location = saved_location;
8492 return return_compatible_p && arglists_compatible_p;
8495 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
8496 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
8497 specified size for this field. POS_LIST is a position list describing
8498 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
8502 create_field_decl_from (tree old_field, tree field_type, tree record_type,
8503 tree size, tree pos_list,
8504 VEC(subst_pair,heap) *subst_list)
8506 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
8507 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
8508 unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
8509 tree new_pos, new_field;
8513 if (CONTAINS_PLACEHOLDER_P (pos))
8514 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8515 pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
8517 /* If the position is now a constant, we can set it as the position of the
8518 field when we make it. Otherwise, we need to deal with it specially. */
8519 if (TREE_CONSTANT (pos))
8520 new_pos = bit_from_pos (pos, bitpos);
8522 new_pos = NULL_TREE;
8525 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
8526 size, new_pos, DECL_PACKED (old_field),
8527 !DECL_NONADDRESSABLE_P (old_field));
8531 normalize_offset (&pos, &bitpos, offset_align);
8532 DECL_FIELD_OFFSET (new_field) = pos;
8533 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
8534 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
8535 DECL_SIZE (new_field) = size;
8536 DECL_SIZE_UNIT (new_field)
8537 = convert (sizetype,
8538 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
8539 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
8542 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
8543 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
8544 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
8545 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8550 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8553 get_rep_part (tree record_type)
8555 tree field = TYPE_FIELDS (record_type);
8557 /* The REP part is the first field, internal, another record, and its name
8558 doesn't start with an underscore (i.e. is not generated by the FE). */
8559 if (DECL_INTERNAL_P (field)
8560 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8561 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
8567 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8570 get_variant_part (tree record_type)
8574 /* The variant part is the only internal field that is a qualified union. */
8575 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
8576 if (DECL_INTERNAL_P (field)
8577 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8583 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8584 the list of variants to be used and RECORD_TYPE is the type of the parent.
8585 POS_LIST is a position list describing the layout of fields present in
8586 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8590 create_variant_part_from (tree old_variant_part,
8591 VEC(variant_desc,heap) *variant_list,
8592 tree record_type, tree pos_list,
8593 VEC(subst_pair,heap) *subst_list)
8595 tree offset = DECL_FIELD_OFFSET (old_variant_part);
8596 tree old_union_type = TREE_TYPE (old_variant_part);
8597 tree new_union_type, new_variant_part;
8598 tree union_field_list = NULL_TREE;
8602 /* First create the type of the variant part from that of the old one. */
8603 new_union_type = make_node (QUAL_UNION_TYPE);
8604 TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
8606 /* If the position of the variant part is constant, subtract it from the
8607 size of the type of the parent to get the new size. This manual CSE
8608 reduces the code size when not optimizing. */
8609 if (TREE_CODE (offset) == INTEGER_CST)
8611 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8612 tree first_bit = bit_from_pos (offset, bitpos);
8613 TYPE_SIZE (new_union_type)
8614 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8615 TYPE_SIZE_UNIT (new_union_type)
8616 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8617 byte_from_pos (offset, bitpos));
8618 SET_TYPE_ADA_SIZE (new_union_type,
8619 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8621 TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
8622 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8625 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8627 /* Now finish up the new variants and populate the union type. */
8628 FOR_EACH_VEC_ELT_REVERSE (variant_desc, variant_list, ix, v)
8630 tree old_field = v->field, new_field;
8631 tree old_variant, old_variant_subpart, new_variant, field_list;
8633 /* Skip variants that don't belong to this nesting level. */
8634 if (DECL_CONTEXT (old_field) != old_union_type)
8637 /* Retrieve the list of fields already added to the new variant. */
8638 new_variant = v->record;
8639 field_list = TYPE_FIELDS (new_variant);
8641 /* If the old variant had a variant subpart, we need to create a new
8642 variant subpart and add it to the field list. */
8643 old_variant = v->type;
8644 old_variant_subpart = get_variant_part (old_variant);
8645 if (old_variant_subpart)
8647 tree new_variant_subpart
8648 = create_variant_part_from (old_variant_subpart, variant_list,
8649 new_variant, pos_list, subst_list);
8650 DECL_CHAIN (new_variant_subpart) = field_list;
8651 field_list = new_variant_subpart;
8654 /* Finish up the new variant and create the field. No need for debug
8655 info thanks to the XVS type. */
8656 finish_record_type (new_variant, nreverse (field_list), 2, false);
8657 compute_record_mode (new_variant);
8658 create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
8659 true, false, Empty);
8662 = create_field_decl_from (old_field, new_variant, new_union_type,
8663 TYPE_SIZE (new_variant),
8664 pos_list, subst_list);
8665 DECL_QUALIFIER (new_field) = v->qual;
8666 DECL_INTERNAL_P (new_field) = 1;
8667 DECL_CHAIN (new_field) = union_field_list;
8668 union_field_list = new_field;
8671 /* Finish up the union type and create the variant part. No need for debug
8672 info thanks to the XVS type. */
8673 finish_record_type (new_union_type, union_field_list, 2, false);
8674 compute_record_mode (new_union_type);
8675 create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
8676 true, false, Empty);
8679 = create_field_decl_from (old_variant_part, new_union_type, record_type,
8680 TYPE_SIZE (new_union_type),
8681 pos_list, subst_list);
8682 DECL_INTERNAL_P (new_variant_part) = 1;
8684 /* With multiple discriminants it is possible for an inner variant to be
8685 statically selected while outer ones are not; in this case, the list
8686 of fields of the inner variant is not flattened and we end up with a
8687 qualified union with a single member. Drop the useless container. */
8688 if (!DECL_CHAIN (union_field_list))
8690 DECL_CONTEXT (union_field_list) = record_type;
8691 DECL_FIELD_OFFSET (union_field_list)
8692 = DECL_FIELD_OFFSET (new_variant_part);
8693 DECL_FIELD_BIT_OFFSET (union_field_list)
8694 = DECL_FIELD_BIT_OFFSET (new_variant_part);
8695 SET_DECL_OFFSET_ALIGN (union_field_list,
8696 DECL_OFFSET_ALIGN (new_variant_part));
8697 new_variant_part = union_field_list;
8700 return new_variant_part;
8703 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8704 which are both RECORD_TYPE, after applying the substitutions described
8708 copy_and_substitute_in_size (tree new_type, tree old_type,
8709 VEC(subst_pair,heap) *subst_list)
8714 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
8715 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
8716 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
8717 TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
8718 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
8720 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
8721 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8722 TYPE_SIZE (new_type)
8723 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
8724 s->discriminant, s->replacement);
8726 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
8727 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8728 TYPE_SIZE_UNIT (new_type)
8729 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
8730 s->discriminant, s->replacement);
8732 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
8733 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8735 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
8736 s->discriminant, s->replacement));
8738 /* Finalize the size. */
8739 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
8740 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
8743 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8744 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8745 updated by replacing F with R.
8747 The function doesn't update the layout of the type, i.e. it assumes
8748 that the substitution is purely formal. That's why the replacement
8749 value R must itself contain a PLACEHOLDER_EXPR. */
8752 substitute_in_type (tree t, tree f, tree r)
8756 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
8758 switch (TREE_CODE (t))
8765 /* First the domain types of arrays. */
8766 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
8767 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
8769 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
8770 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
8772 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
8776 TYPE_GCC_MIN_VALUE (nt) = low;
8777 TYPE_GCC_MAX_VALUE (nt) = high;
8779 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
8781 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
8786 /* Then the subtypes. */
8787 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
8788 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
8790 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
8791 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
8793 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
8797 SET_TYPE_RM_MIN_VALUE (nt, low);
8798 SET_TYPE_RM_MAX_VALUE (nt, high);
8806 nt = substitute_in_type (TREE_TYPE (t), f, r);
8807 if (nt == TREE_TYPE (t))
8810 return build_complex_type (nt);
8813 /* These should never show up here. */
8818 tree component = substitute_in_type (TREE_TYPE (t), f, r);
8819 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
8821 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
8824 nt = build_nonshared_array_type (component, domain);
8825 TYPE_ALIGN (nt) = TYPE_ALIGN (t);
8826 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
8827 SET_TYPE_MODE (nt, TYPE_MODE (t));
8828 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8829 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8830 TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
8831 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
8832 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
8838 case QUAL_UNION_TYPE:
8840 bool changed_field = false;
8843 /* Start out with no fields, make new fields, and chain them
8844 in. If we haven't actually changed the type of any field,
8845 discard everything we've done and return the old type. */
8847 TYPE_FIELDS (nt) = NULL_TREE;
8849 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
8851 tree new_field = copy_node (field), new_n;
8853 new_n = substitute_in_type (TREE_TYPE (field), f, r);
8854 if (new_n != TREE_TYPE (field))
8856 TREE_TYPE (new_field) = new_n;
8857 changed_field = true;
8860 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
8861 if (new_n != DECL_FIELD_OFFSET (field))
8863 DECL_FIELD_OFFSET (new_field) = new_n;
8864 changed_field = true;
8867 /* Do the substitution inside the qualifier, if any. */
8868 if (TREE_CODE (t) == QUAL_UNION_TYPE)
8870 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
8871 if (new_n != DECL_QUALIFIER (field))
8873 DECL_QUALIFIER (new_field) = new_n;
8874 changed_field = true;
8878 DECL_CONTEXT (new_field) = nt;
8879 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
8881 DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
8882 TYPE_FIELDS (nt) = new_field;
8888 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
8889 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8890 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8891 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
8900 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8901 needed to represent the object. */
8904 rm_size (tree gnu_type)
8906 /* For integral types, we store the RM size explicitly. */
8907 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
8908 return TYPE_RM_SIZE (gnu_type);
8910 /* Return the RM size of the actual data plus the size of the template. */
8911 if (TREE_CODE (gnu_type) == RECORD_TYPE
8912 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8914 size_binop (PLUS_EXPR,
8915 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))),
8916 DECL_SIZE (TYPE_FIELDS (gnu_type)));
8918 /* For record types, we store the size explicitly. */
8919 if ((TREE_CODE (gnu_type) == RECORD_TYPE
8920 || TREE_CODE (gnu_type) == UNION_TYPE
8921 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8922 && !TYPE_FAT_POINTER_P (gnu_type)
8923 && TYPE_ADA_SIZE (gnu_type))
8924 return TYPE_ADA_SIZE (gnu_type);
8926 /* For other types, this is just the size. */
8927 return TYPE_SIZE (gnu_type);
8930 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8931 fully-qualified name, possibly with type information encoding.
8932 Otherwise, return the name. */
8935 get_entity_name (Entity_Id gnat_entity)
8937 Get_Encoded_Name (gnat_entity);
8938 return get_identifier_with_length (Name_Buffer, Name_Len);
8941 /* Return an identifier representing the external name to be used for
8942 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8943 and the specified suffix. */
8946 create_concat_name (Entity_Id gnat_entity, const char *suffix)
8948 Entity_Kind kind = Ekind (gnat_entity);
8952 String_Template temp = {1, strlen (suffix)};
8953 Fat_Pointer fp = {suffix, &temp};
8954 Get_External_Name_With_Suffix (gnat_entity, fp);
8957 Get_External_Name (gnat_entity, 0);
8959 /* A variable using the Stdcall convention lives in a DLL. We adjust
8960 its name to use the jump table, the _imp__NAME contains the address
8961 for the NAME variable. */
8962 if ((kind == E_Variable || kind == E_Constant)
8963 && Has_Stdcall_Convention (gnat_entity))
8965 const int len = 6 + Name_Len;
8966 char *new_name = (char *) alloca (len + 1);
8967 strcpy (new_name, "_imp__");
8968 strcat (new_name, Name_Buffer);
8969 return get_identifier_with_length (new_name, len);
8972 return get_identifier_with_length (Name_Buffer, Name_Len);
8975 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8976 string, return a new IDENTIFIER_NODE that is the concatenation of
8977 the name followed by "___" and the specified suffix. */
8980 concat_name (tree gnu_name, const char *suffix)
8982 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
8983 char *new_name = (char *) alloca (len + 1);
8984 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
8985 strcat (new_name, "___");
8986 strcat (new_name, suffix);
8987 return get_identifier_with_length (new_name, len);
8990 #include "gt-ada-decl.h"
OSDN Git Service
