1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2017, 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"
31 #include "stringpool.h"
32 #include "diagnostic-core.h"
34 #include "fold-const.h"
35 #include "stor-layout.h"
36 #include "tree-inline.h"
55 /* "stdcall" and "thiscall" conventions should be processed in a specific way
56 on 32-bit x86/Windows only. The macros below are helpers to avoid having
57 to check for a Windows specific attribute throughout this unit. */
59 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
61 #define Has_Stdcall_Convention(E) \
62 (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
63 #define Has_Thiscall_Convention(E) \
64 (!TARGET_64BIT && is_cplusplus_method (E))
66 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
67 #define Has_Thiscall_Convention(E) (is_cplusplus_method (E))
70 #define Has_Stdcall_Convention(E) 0
71 #define Has_Thiscall_Convention(E) 0
74 #define STDCALL_PREFIX "_imp__"
76 /* Stack realignment is necessary for functions with foreign conventions when
77 the ABI doesn't mandate as much as what the compiler assumes - that is, up
78 to PREFERRED_STACK_BOUNDARY.
80 Such realignment can be requested with a dedicated function type attribute
81 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
82 characterize the situations where the attribute should be set. We rely on
83 compiler configuration settings for 'main' to decide. */
85 #ifdef MAIN_STACK_BOUNDARY
86 #define FOREIGN_FORCE_REALIGN_STACK \
87 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
89 #define FOREIGN_FORCE_REALIGN_STACK 0
94 struct incomplete
*next
;
99 /* These variables are used to defer recursively expanding incomplete types
100 while we are processing a record, an array or a subprogram type. */
101 static int defer_incomplete_level
= 0;
102 static struct incomplete
*defer_incomplete_list
;
104 /* This variable is used to delay expanding types coming from a limited with
105 clause and completed Taft Amendment types until the end of the spec. */
106 static struct incomplete
*defer_limited_with_list
;
108 typedef struct subst_pair_d
{
114 typedef struct variant_desc_d
{
115 /* The type of the variant. */
118 /* The associated field. */
121 /* The value of the qualifier. */
124 /* The type of the variant after transformation. */
129 /* A map used to cache the result of annotate_value. */
130 struct value_annotation_hasher
: ggc_cache_ptr_hash
<tree_int_map
>
132 static inline hashval_t
133 hash (tree_int_map
*m
)
135 return htab_hash_pointer (m
->base
.from
);
139 equal (tree_int_map
*a
, tree_int_map
*b
)
141 return a
->base
.from
== b
->base
.from
;
145 keep_cache_entry (tree_int_map
*&m
)
147 return ggc_marked_p (m
->base
.from
);
151 static GTY ((cache
)) hash_table
<value_annotation_hasher
> *annotate_value_cache
;
153 /* A map used to associate a dummy type with a list of subprogram entities. */
154 struct GTY((for_user
)) tree_entity_vec_map
156 struct tree_map_base base
;
157 vec
<Entity_Id
, va_gc_atomic
> *to
;
161 gt_pch_nx (Entity_Id
&)
166 gt_pch_nx (Entity_Id
*x
, gt_pointer_operator op
, void *cookie
)
171 struct dummy_type_hasher
: ggc_cache_ptr_hash
<tree_entity_vec_map
>
173 static inline hashval_t
174 hash (tree_entity_vec_map
*m
)
176 return htab_hash_pointer (m
->base
.from
);
180 equal (tree_entity_vec_map
*a
, tree_entity_vec_map
*b
)
182 return a
->base
.from
== b
->base
.from
;
186 keep_cache_entry (tree_entity_vec_map
*&m
)
188 return ggc_marked_p (m
->base
.from
);
192 static GTY ((cache
)) hash_table
<dummy_type_hasher
> *dummy_to_subprog_map
;
194 static void prepend_one_attribute (struct attrib
**,
195 enum attrib_type
, tree
, tree
, Node_Id
);
196 static void prepend_one_attribute_pragma (struct attrib
**, Node_Id
);
197 static void prepend_attributes (struct attrib
**, Entity_Id
);
198 static tree
elaborate_expression (Node_Id
, Entity_Id
, const char *, bool, bool,
200 static bool type_has_variable_size (tree
);
201 static tree
elaborate_expression_1 (tree
, Entity_Id
, const char *, bool, bool);
202 static tree
elaborate_expression_2 (tree
, Entity_Id
, const char *, bool, bool,
204 static tree
elaborate_reference (tree
, Entity_Id
, bool, tree
*);
205 static tree
gnat_to_gnu_component_type (Entity_Id
, bool, bool);
206 static tree
gnat_to_gnu_subprog_type (Entity_Id
, bool, bool, tree
*);
207 static int adjust_packed (tree
, tree
, int);
208 static tree
gnat_to_gnu_field (Entity_Id
, tree
, int, bool, bool);
209 static tree
gnu_ext_name_for_subprog (Entity_Id
, tree
);
210 static tree
change_qualified_type (tree
, int);
211 static void set_nonaliased_component_on_array_type (tree
);
212 static void set_reverse_storage_order_on_array_type (tree
);
213 static bool same_discriminant_p (Entity_Id
, Entity_Id
);
214 static bool array_type_has_nonaliased_component (tree
, Entity_Id
);
215 static bool compile_time_known_address_p (Node_Id
);
216 static bool cannot_be_superflat (Node_Id
);
217 static bool constructor_address_p (tree
);
218 static bool allocatable_size_p (tree
, bool);
219 static bool initial_value_needs_conversion (tree
, tree
);
220 static int compare_field_bitpos (const PTR
, const PTR
);
221 static bool components_to_record (Node_Id
, Entity_Id
, tree
, tree
, int, bool,
222 bool, bool, bool, bool, bool, bool, tree
,
224 static Uint
annotate_value (tree
);
225 static void annotate_rep (Entity_Id
, tree
);
226 static tree
build_position_list (tree
, bool, tree
, tree
, unsigned int, tree
);
227 static vec
<subst_pair
> build_subst_list (Entity_Id
, Entity_Id
, bool);
228 static vec
<variant_desc
> build_variant_list (tree
, vec
<subst_pair
>,
230 static tree
validate_size (Uint
, tree
, Entity_Id
, enum tree_code
, bool, bool);
231 static void set_rm_size (Uint
, tree
, Entity_Id
);
232 static unsigned int validate_alignment (Uint
, Entity_Id
, unsigned int);
233 static void check_ok_for_atomic_type (tree
, Entity_Id
, bool);
234 static tree
create_field_decl_from (tree
, tree
, tree
, tree
, tree
,
236 static tree
create_rep_part (tree
, tree
, tree
);
237 static tree
get_rep_part (tree
);
238 static tree
create_variant_part_from (tree
, vec
<variant_desc
>, tree
,
239 tree
, vec
<subst_pair
>, bool);
240 static void copy_and_substitute_in_size (tree
, tree
, vec
<subst_pair
>);
241 static void copy_and_substitute_in_layout (Entity_Id
, Entity_Id
, tree
, tree
,
242 vec
<subst_pair
>, bool);
243 static void associate_original_type_to_packed_array (tree
, Entity_Id
);
244 static const char *get_entity_char (Entity_Id
);
246 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
247 to pass around calls performing profile compatibility checks. */
250 Entity_Id gnat_entity
; /* The Ada subprogram entity. */
251 tree ada_fntype
; /* The corresponding GCC type node. */
252 tree btin_fntype
; /* The GCC builtin function type node. */
255 static bool intrin_profiles_compatible_p (intrin_binding_t
*);
257 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
258 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
259 and associate the ..._DECL node with the input GNAT defining identifier.
261 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
262 initial value (in GCC tree form). This is optional for a variable. For
263 a renamed entity, GNU_EXPR gives the object being renamed.
265 DEFINITION is true if this call is intended for a definition. This is used
266 for separate compilation where it is necessary to know whether an external
267 declaration or a definition must be created if the GCC equivalent was not
268 created previously. */
271 gnat_to_gnu_entity (Entity_Id gnat_entity
, tree gnu_expr
, bool definition
)
273 /* Contains the kind of the input GNAT node. */
274 const Entity_Kind kind
= Ekind (gnat_entity
);
275 /* True if this is a type. */
276 const bool is_type
= IN (kind
, Type_Kind
);
277 /* True if this is an artificial entity. */
278 const bool artificial_p
= !Comes_From_Source (gnat_entity
);
279 /* True if debug info is requested for this entity. */
280 const bool debug_info_p
= Needs_Debug_Info (gnat_entity
);
281 /* True if this entity is to be considered as imported. */
282 const bool imported_p
283 = (Is_Imported (gnat_entity
) && No (Address_Clause (gnat_entity
)));
284 /* For a type, contains the equivalent GNAT node to be used in gigi. */
285 Entity_Id gnat_equiv_type
= Empty
;
286 /* Temporary used to walk the GNAT tree. */
288 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
289 This node will be associated with the GNAT node by calling at the end
290 of the `switch' statement. */
291 tree gnu_decl
= NULL_TREE
;
292 /* Contains the GCC type to be used for the GCC node. */
293 tree gnu_type
= NULL_TREE
;
294 /* Contains the GCC size tree to be used for the GCC node. */
295 tree gnu_size
= NULL_TREE
;
296 /* Contains the GCC name to be used for the GCC node. */
297 tree gnu_entity_name
;
298 /* True if we have already saved gnu_decl as a GNAT association. */
300 /* True if we incremented defer_incomplete_level. */
301 bool this_deferred
= false;
302 /* True if we incremented force_global. */
303 bool this_global
= false;
304 /* True if we should check to see if elaborated during processing. */
305 bool maybe_present
= false;
306 /* True if we made GNU_DECL and its type here. */
307 bool this_made_decl
= false;
308 /* Size and alignment of the GCC node, if meaningful. */
309 unsigned int esize
= 0, align
= 0;
310 /* Contains the list of attributes directly attached to the entity. */
311 struct attrib
*attr_list
= NULL
;
313 /* Since a use of an Itype is a definition, process it as such if it is in
314 the main unit, except for E_Access_Subtype because it's actually a use
315 of its base type, see below. */
318 && Is_Itype (gnat_entity
)
319 && Ekind (gnat_entity
) != E_Access_Subtype
320 && !present_gnu_tree (gnat_entity
)
321 && In_Extended_Main_Code_Unit (gnat_entity
))
323 /* Ensure that we are in a subprogram mentioned in the Scope chain of
324 this entity, our current scope is global, or we encountered a task
325 or entry (where we can't currently accurately check scoping). */
326 if (!current_function_decl
327 || DECL_ELABORATION_PROC_P (current_function_decl
))
329 process_type (gnat_entity
);
330 return get_gnu_tree (gnat_entity
);
333 for (gnat_temp
= Scope (gnat_entity
);
335 gnat_temp
= Scope (gnat_temp
))
337 if (Is_Type (gnat_temp
))
338 gnat_temp
= Underlying_Type (gnat_temp
);
340 if (Ekind (gnat_temp
) == E_Subprogram_Body
)
342 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp
)));
344 if (Is_Subprogram (gnat_temp
)
345 && Present (Protected_Body_Subprogram (gnat_temp
)))
346 gnat_temp
= Protected_Body_Subprogram (gnat_temp
);
348 if (Ekind (gnat_temp
) == E_Entry
349 || Ekind (gnat_temp
) == E_Entry_Family
350 || Ekind (gnat_temp
) == E_Task_Type
351 || (Is_Subprogram (gnat_temp
)
352 && present_gnu_tree (gnat_temp
)
353 && (current_function_decl
354 == gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, false))))
356 process_type (gnat_entity
);
357 return get_gnu_tree (gnat_entity
);
361 /* This abort means the Itype has an incorrect scope, i.e. that its
362 scope does not correspond to the subprogram it is declared in. */
366 /* If we've already processed this entity, return what we got last time.
367 If we are defining the node, we should not have already processed it.
368 In that case, we will abort below when we try to save a new GCC tree
369 for this object. We also need to handle the case of getting a dummy
370 type when a Full_View exists but be careful so as not to trigger its
371 premature elaboration. */
372 if ((!definition
|| (is_type
&& imported_p
))
373 && present_gnu_tree (gnat_entity
))
375 gnu_decl
= get_gnu_tree (gnat_entity
);
377 if (TREE_CODE (gnu_decl
) == TYPE_DECL
378 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
))
379 && IN (kind
, Incomplete_Or_Private_Kind
)
380 && Present (Full_View (gnat_entity
))
381 && (present_gnu_tree (Full_View (gnat_entity
))
382 || No (Freeze_Node (Full_View (gnat_entity
)))))
385 = gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, false);
386 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
387 save_gnu_tree (gnat_entity
, gnu_decl
, false);
393 /* If this is a numeric or enumeral type, or an access type, a nonzero Esize
394 must be specified unless it was specified by the programmer. Exceptions
395 are for access-to-protected-subprogram types and all access subtypes, as
396 another GNAT type is used to lay out the GCC type for them. */
398 || Known_Esize (gnat_entity
)
399 || Has_Size_Clause (gnat_entity
)
400 || (!IN (kind
, Numeric_Kind
)
401 && !IN (kind
, Enumeration_Kind
)
402 && (!IN (kind
, Access_Kind
)
403 || kind
== E_Access_Protected_Subprogram_Type
404 || kind
== E_Anonymous_Access_Protected_Subprogram_Type
405 || kind
== E_Access_Subtype
406 || type_annotate_only
)));
408 /* The RM size must be specified for all discrete and fixed-point types. */
409 gcc_assert (!(IN (kind
, Discrete_Or_Fixed_Point_Kind
)
410 && Unknown_RM_Size (gnat_entity
)));
412 /* If we get here, it means we have not yet done anything with this entity.
413 If we are not defining it, it must be a type or an entity that is defined
414 elsewhere or externally, otherwise we should have defined it already. */
415 gcc_assert (definition
416 || type_annotate_only
418 || kind
== E_Discriminant
419 || kind
== E_Component
421 || (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
422 || Is_Public (gnat_entity
));
424 /* Get the name of the entity and set up the line number and filename of
425 the original definition for use in any decl we make. Make sure we do not
426 inherit another source location. */
427 gnu_entity_name
= get_entity_name (gnat_entity
);
428 if (Sloc (gnat_entity
) != No_Location
429 && !renaming_from_instantiation_p (gnat_entity
))
430 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
432 /* For cases when we are not defining (i.e., we are referencing from
433 another compilation unit) public entities, show we are at global level
434 for the purpose of computing scopes. Don't do this for components or
435 discriminants since the relevant test is whether or not the record is
438 && kind
!= E_Component
439 && kind
!= E_Discriminant
440 && Is_Public (gnat_entity
)
441 && !Is_Statically_Allocated (gnat_entity
))
442 force_global
++, this_global
= true;
444 /* Handle any attributes directly attached to the entity. */
445 if (Has_Gigi_Rep_Item (gnat_entity
))
446 prepend_attributes (&attr_list
, gnat_entity
);
448 /* Do some common processing for types. */
451 /* Compute the equivalent type to be used in gigi. */
452 gnat_equiv_type
= Gigi_Equivalent_Type (gnat_entity
);
454 /* Machine_Attributes on types are expected to be propagated to
455 subtypes. The corresponding Gigi_Rep_Items are only attached
456 to the first subtype though, so we handle the propagation here. */
457 if (Base_Type (gnat_entity
) != gnat_entity
458 && !Is_First_Subtype (gnat_entity
)
459 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity
))))
460 prepend_attributes (&attr_list
,
461 First_Subtype (Base_Type (gnat_entity
)));
463 /* Compute a default value for the size of an elementary type. */
464 if (Known_Esize (gnat_entity
) && Is_Elementary_Type (gnat_entity
))
466 unsigned int max_esize
;
468 gcc_assert (UI_Is_In_Int_Range (Esize (gnat_entity
)));
469 esize
= UI_To_Int (Esize (gnat_entity
));
471 if (IN (kind
, Float_Kind
))
472 max_esize
= fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE
);
473 else if (IN (kind
, Access_Kind
))
474 max_esize
= POINTER_SIZE
* 2;
476 max_esize
= LONG_LONG_TYPE_SIZE
;
478 if (esize
> max_esize
)
488 /* The GNAT record where the component was defined. */
489 Entity_Id gnat_record
= Underlying_Type (Scope (gnat_entity
));
491 /* If the entity is a discriminant of an extended tagged type used to
492 rename a discriminant of the parent type, return the latter. */
493 if (kind
== E_Discriminant
494 && Present (Corresponding_Discriminant (gnat_entity
))
495 && Is_Tagged_Type (gnat_record
))
498 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity
),
499 gnu_expr
, definition
);
504 /* If the entity is an inherited component (in the case of extended
505 tagged record types), just return the original entity, which must
506 be a FIELD_DECL. Likewise for discriminants. If the entity is a
507 non-girder discriminant (in the case of derived untagged record
508 types), return the stored discriminant it renames. */
509 if (Present (Original_Record_Component (gnat_entity
))
510 && Original_Record_Component (gnat_entity
) != gnat_entity
)
513 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity
),
514 gnu_expr
, definition
);
515 /* GNU_DECL contains a PLACEHOLDER_EXPR for discriminants. */
516 if (kind
== E_Discriminant
)
521 /* Otherwise, if we are not defining this and we have no GCC type
522 for the containing record, make one for it. Then we should
523 have made our own equivalent. */
524 if (!definition
&& !present_gnu_tree (gnat_record
))
526 /* ??? If this is in a record whose scope is a protected
527 type and we have an Original_Record_Component, use it.
528 This is a workaround for major problems in protected type
530 Entity_Id Scop
= Scope (Scope (gnat_entity
));
531 if (Is_Protected_Type (Underlying_Type (Scop
))
532 && Present (Original_Record_Component (gnat_entity
)))
535 = gnat_to_gnu_entity (Original_Record_Component
541 gnat_to_gnu_entity (Scope (gnat_entity
), NULL_TREE
, false);
542 gnu_decl
= get_gnu_tree (gnat_entity
);
549 /* Here we have no GCC type and this is a reference rather than a
550 definition. This should never happen. Most likely the cause is
551 reference before declaration in the GNAT tree for gnat_entity. */
556 /* Ignore constant definitions already marked with the error node. See
557 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
559 && present_gnu_tree (gnat_entity
)
560 && get_gnu_tree (gnat_entity
) == error_mark_node
)
562 maybe_present
= true;
566 /* Ignore deferred constant definitions without address clause since
567 they are processed fully in the front-end. If No_Initialization
568 is set, this is not a deferred constant but a constant whose value
569 is built manually. And constants that are renamings are handled
573 && No (Address_Clause (gnat_entity
))
574 && !No_Initialization (Declaration_Node (gnat_entity
))
575 && No (Renamed_Object (gnat_entity
)))
577 gnu_decl
= error_mark_node
;
582 /* If this is a use of a deferred constant without address clause,
583 get its full definition. */
585 && No (Address_Clause (gnat_entity
))
586 && Present (Full_View (gnat_entity
)))
589 = gnat_to_gnu_entity (Full_View (gnat_entity
), gnu_expr
, false);
594 /* If we have a constant that we are not defining, get the expression it
595 was defined to represent. This is necessary to avoid generating dumb
596 elaboration code in simple cases, but we may throw it away later if it
597 is not a constant. But do not retrieve it if it is an allocator since
598 the designated type might still be dummy at this point. */
600 && !No_Initialization (Declaration_Node (gnat_entity
))
601 && Present (Expression (Declaration_Node (gnat_entity
)))
602 && Nkind (Expression (Declaration_Node (gnat_entity
)))
604 /* The expression may contain N_Expression_With_Actions nodes and
605 thus object declarations from other units. Discard them. */
607 = gnat_to_gnu_external (Expression (Declaration_Node (gnat_entity
)));
609 /* ... fall through ... */
612 case E_Loop_Parameter
:
613 case E_Out_Parameter
:
616 const Entity_Id gnat_type
= Etype (gnat_entity
);
617 /* Always create a variable for volatile objects and variables seen
618 constant but with a Linker_Section pragma. */
620 = ((kind
== E_Constant
|| kind
== E_Variable
)
621 && Is_True_Constant (gnat_entity
)
622 && !(kind
== E_Variable
623 && Present (Linker_Section_Pragma (gnat_entity
)))
624 && !Treat_As_Volatile (gnat_entity
)
625 && (((Nkind (Declaration_Node (gnat_entity
))
626 == N_Object_Declaration
)
627 && Present (Expression (Declaration_Node (gnat_entity
))))
628 || Present (Renamed_Object (gnat_entity
))
630 bool inner_const_flag
= const_flag
;
631 bool static_flag
= Is_Statically_Allocated (gnat_entity
);
632 /* We implement RM 13.3(19) for exported and imported (non-constant)
633 objects by making them volatile. */
635 = (Treat_As_Volatile (gnat_entity
)
636 || (!const_flag
&& (Is_Exported (gnat_entity
) || imported_p
)));
637 bool mutable_p
= false;
638 bool used_by_ref
= false;
639 tree gnu_ext_name
= NULL_TREE
;
640 tree renamed_obj
= NULL_TREE
;
641 tree gnu_object_size
;
643 /* We need to translate the renamed object even though we are only
644 referencing the renaming. But it may contain a call for which
645 we'll generate a temporary to hold the return value and which
646 is part of the definition of the renaming, so discard it. */
647 if (Present (Renamed_Object (gnat_entity
)) && !definition
)
649 if (kind
== E_Exception
)
650 gnu_expr
= gnat_to_gnu_entity (Renamed_Entity (gnat_entity
),
653 gnu_expr
= gnat_to_gnu_external (Renamed_Object (gnat_entity
));
656 /* Get the type after elaborating the renamed object. */
657 if (Has_Foreign_Convention (gnat_entity
)
658 && Is_Descendant_Of_Address (gnat_type
))
659 gnu_type
= ptr_type_node
;
662 gnu_type
= gnat_to_gnu_type (gnat_type
);
664 /* If this is a standard exception definition, use the standard
665 exception type. This is necessary to make sure that imported
666 and exported views of exceptions are merged in LTO mode. */
667 if (TREE_CODE (TYPE_NAME (gnu_type
)) == TYPE_DECL
668 && DECL_NAME (TYPE_NAME (gnu_type
)) == exception_data_name_id
)
669 gnu_type
= except_type_node
;
672 /* For a debug renaming declaration, build a debug-only entity. */
673 if (Present (Debug_Renaming_Link (gnat_entity
)))
675 /* Force a non-null value to make sure the symbol is retained. */
676 tree value
= build1 (INDIRECT_REF
, gnu_type
,
678 build_pointer_type (gnu_type
),
679 integer_minus_one_node
));
680 gnu_decl
= build_decl (input_location
,
681 VAR_DECL
, gnu_entity_name
, gnu_type
);
682 SET_DECL_VALUE_EXPR (gnu_decl
, value
);
683 DECL_HAS_VALUE_EXPR_P (gnu_decl
) = 1;
684 TREE_STATIC (gnu_decl
) = global_bindings_p ();
685 gnat_pushdecl (gnu_decl
, gnat_entity
);
689 /* If this is a loop variable, its type should be the base type.
690 This is because the code for processing a loop determines whether
691 a normal loop end test can be done by comparing the bounds of the
692 loop against those of the base type, which is presumed to be the
693 size used for computation. But this is not correct when the size
694 of the subtype is smaller than the type. */
695 if (kind
== E_Loop_Parameter
)
696 gnu_type
= get_base_type (gnu_type
);
698 /* Reject non-renamed objects whose type is an unconstrained array or
699 any object whose type is a dummy type or void. */
700 if ((TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
701 && No (Renamed_Object (gnat_entity
)))
702 || TYPE_IS_DUMMY_P (gnu_type
)
703 || TREE_CODE (gnu_type
) == VOID_TYPE
)
705 gcc_assert (type_annotate_only
);
708 return error_mark_node
;
711 /* If an alignment is specified, use it if valid. Note that exceptions
712 are objects but don't have an alignment. We must do this before we
713 validate the size, since the alignment can affect the size. */
714 if (kind
!= E_Exception
&& Known_Alignment (gnat_entity
))
716 gcc_assert (Present (Alignment (gnat_entity
)));
718 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
719 TYPE_ALIGN (gnu_type
));
721 /* No point in changing the type if there is an address clause
722 as the final type of the object will be a reference type. */
723 if (Present (Address_Clause (gnat_entity
)))
727 tree orig_type
= gnu_type
;
730 = maybe_pad_type (gnu_type
, NULL_TREE
, align
, gnat_entity
,
731 false, false, definition
, true);
733 /* If a padding record was made, declare it now since it will
734 never be declared otherwise. This is necessary to ensure
735 that its subtrees are properly marked. */
736 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
737 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, true,
738 debug_info_p
, gnat_entity
);
742 /* If we are defining the object, see if it has a Size and validate it
743 if so. If we are not defining the object and a Size clause applies,
744 simply retrieve the value. We don't want to ignore the clause and
745 it is expected to have been validated already. Then get the new
748 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
,
749 gnat_entity
, VAR_DECL
, false,
750 Has_Size_Clause (gnat_entity
));
751 else if (Has_Size_Clause (gnat_entity
))
752 gnu_size
= UI_To_gnu (Esize (gnat_entity
), bitsizetype
);
757 = make_type_from_size (gnu_type
, gnu_size
,
758 Has_Biased_Representation (gnat_entity
));
760 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0))
761 gnu_size
= NULL_TREE
;
764 /* If this object has self-referential size, it must be a record with
765 a default discriminant. We are supposed to allocate an object of
766 the maximum size in this case, unless it is a constant with an
767 initializing expression, in which case we can get the size from
768 that. Note that the resulting size may still be a variable, so
769 this may end up with an indirect allocation. */
770 if (No (Renamed_Object (gnat_entity
))
771 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
773 if (gnu_expr
&& kind
== E_Constant
)
775 tree size
= TYPE_SIZE (TREE_TYPE (gnu_expr
));
776 if (CONTAINS_PLACEHOLDER_P (size
))
778 /* If the initializing expression is itself a constant,
779 despite having a nominal type with self-referential
780 size, we can get the size directly from it. */
781 if (TREE_CODE (gnu_expr
) == COMPONENT_REF
783 (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
784 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == VAR_DECL
785 && (TREE_READONLY (TREE_OPERAND (gnu_expr
, 0))
786 || DECL_READONLY_ONCE_ELAB
787 (TREE_OPERAND (gnu_expr
, 0))))
788 gnu_size
= DECL_SIZE (TREE_OPERAND (gnu_expr
, 0));
791 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_expr
);
796 /* We may have no GNU_EXPR because No_Initialization is
797 set even though there's an Expression. */
798 else if (kind
== E_Constant
799 && (Nkind (Declaration_Node (gnat_entity
))
800 == N_Object_Declaration
)
801 && Present (Expression (Declaration_Node (gnat_entity
))))
803 = TYPE_SIZE (gnat_to_gnu_type
805 (Expression (Declaration_Node (gnat_entity
)))));
808 gnu_size
= max_size (TYPE_SIZE (gnu_type
), true);
812 /* If the size isn't constant and we are at global level, call
813 elaborate_expression_1 to make a variable for it rather than
814 calculating it each time. */
815 if (!TREE_CONSTANT (gnu_size
) && global_bindings_p ())
816 gnu_size
= elaborate_expression_1 (gnu_size
, gnat_entity
,
817 "SIZE", definition
, false);
820 /* If the size is zero byte, make it one byte since some linkers have
821 troubles with zero-sized objects. If the object will have a
822 template, that will make it nonzero so don't bother. Also avoid
823 doing that for an object renaming or an object with an address
824 clause, as we would lose useful information on the view size
825 (e.g. for null array slices) and we are not allocating the object
828 && integer_zerop (gnu_size
)
829 && !TREE_OVERFLOW (gnu_size
))
830 || (TYPE_SIZE (gnu_type
)
831 && integer_zerop (TYPE_SIZE (gnu_type
))
832 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type
))))
833 && !Is_Constr_Subt_For_UN_Aliased (gnat_type
)
834 && No (Renamed_Object (gnat_entity
))
835 && No (Address_Clause (gnat_entity
)))
836 gnu_size
= bitsize_unit_node
;
838 /* If this is an object with no specified size and alignment, and
839 if either it is atomic or we are not optimizing alignment for
840 space and it is composite and not an exception, an Out parameter
841 or a reference to another object, and the size of its type is a
842 constant, set the alignment to the smallest one which is not
843 smaller than the size, with an appropriate cap. */
844 if (!gnu_size
&& align
== 0
845 && (Is_Atomic_Or_VFA (gnat_entity
)
846 || (!Optimize_Alignment_Space (gnat_entity
)
847 && kind
!= E_Exception
848 && kind
!= E_Out_Parameter
849 && Is_Composite_Type (gnat_type
)
850 && !Is_Constr_Subt_For_UN_Aliased (gnat_type
)
851 && !Is_Exported (gnat_entity
)
853 && No (Renamed_Object (gnat_entity
))
854 && No (Address_Clause (gnat_entity
))))
855 && TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
)
857 unsigned int size_cap
, align_cap
;
859 /* No point in promoting the alignment if this doesn't prevent
860 BLKmode access to the object, in particular block copy, as
861 this will for example disable the NRV optimization for it.
862 No point in jumping through all the hoops needed in order
863 to support BIGGEST_ALIGNMENT if we don't really have to.
864 So we cap to the smallest alignment that corresponds to
865 a known efficient memory access pattern of the target. */
866 if (Is_Atomic_Or_VFA (gnat_entity
))
869 align_cap
= BIGGEST_ALIGNMENT
;
873 size_cap
= MAX_FIXED_MODE_SIZE
;
874 align_cap
= get_mode_alignment (ptr_mode
);
877 if (!tree_fits_uhwi_p (TYPE_SIZE (gnu_type
))
878 || compare_tree_int (TYPE_SIZE (gnu_type
), size_cap
) > 0)
880 else if (compare_tree_int (TYPE_SIZE (gnu_type
), align_cap
) > 0)
883 align
= ceil_pow2 (tree_to_uhwi (TYPE_SIZE (gnu_type
)));
885 /* But make sure not to under-align the object. */
886 if (align
<= TYPE_ALIGN (gnu_type
))
889 /* And honor the minimum valid atomic alignment, if any. */
890 #ifdef MINIMUM_ATOMIC_ALIGNMENT
891 else if (align
< MINIMUM_ATOMIC_ALIGNMENT
)
892 align
= MINIMUM_ATOMIC_ALIGNMENT
;
896 /* If the object is set to have atomic components, find the component
897 type and validate it.
899 ??? Note that we ignore Has_Volatile_Components on objects; it's
900 not at all clear what to do in that case. */
901 if (Has_Atomic_Components (gnat_entity
))
903 tree gnu_inner
= (TREE_CODE (gnu_type
) == ARRAY_TYPE
904 ? TREE_TYPE (gnu_type
) : gnu_type
);
906 while (TREE_CODE (gnu_inner
) == ARRAY_TYPE
907 && TYPE_MULTI_ARRAY_P (gnu_inner
))
908 gnu_inner
= TREE_TYPE (gnu_inner
);
910 check_ok_for_atomic_type (gnu_inner
, gnat_entity
, true);
913 /* If this is an aliased object with an unconstrained array nominal
914 subtype, make a type that includes the template. We will either
915 allocate or create a variable of that type, see below. */
916 if (Is_Constr_Subt_For_UN_Aliased (gnat_type
)
917 && Is_Array_Type (Underlying_Type (gnat_type
))
918 && !type_annotate_only
)
920 tree gnu_array
= gnat_to_gnu_type (Base_Type (gnat_type
));
922 = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array
),
924 concat_name (gnu_entity_name
,
929 /* ??? If this is an object of CW type initialized to a value, try to
930 ensure that the object is sufficient aligned for this value, but
931 without pessimizing the allocation. This is a kludge necessary
932 because we don't support dynamic alignment. */
934 && Ekind (gnat_type
) == E_Class_Wide_Subtype
935 && No (Renamed_Object (gnat_entity
))
936 && No (Address_Clause (gnat_entity
)))
937 align
= get_target_system_allocator_alignment () * BITS_PER_UNIT
;
939 #ifdef MINIMUM_ATOMIC_ALIGNMENT
940 /* If the size is a constant and no alignment is specified, force
941 the alignment to be the minimum valid atomic alignment. The
942 restriction on constant size avoids problems with variable-size
943 temporaries; if the size is variable, there's no issue with
944 atomic access. Also don't do this for a constant, since it isn't
945 necessary and can interfere with constant replacement. Finally,
946 do not do it for Out parameters since that creates an
947 size inconsistency with In parameters. */
949 && MINIMUM_ATOMIC_ALIGNMENT
> TYPE_ALIGN (gnu_type
)
950 && !FLOAT_TYPE_P (gnu_type
)
951 && !const_flag
&& No (Renamed_Object (gnat_entity
))
952 && !imported_p
&& No (Address_Clause (gnat_entity
))
953 && kind
!= E_Out_Parameter
954 && (gnu_size
? TREE_CODE (gnu_size
) == INTEGER_CST
955 : TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
))
956 align
= MINIMUM_ATOMIC_ALIGNMENT
;
959 /* Make a new type with the desired size and alignment, if needed.
960 But do not take into account alignment promotions to compute the
961 size of the object. */
962 gnu_object_size
= gnu_size
? gnu_size
: TYPE_SIZE (gnu_type
);
963 if (gnu_size
|| align
> 0)
965 tree orig_type
= gnu_type
;
967 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
968 false, false, definition
, true);
970 /* If a padding record was made, declare it now since it will
971 never be declared otherwise. This is necessary to ensure
972 that its subtrees are properly marked. */
973 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
974 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, true,
975 debug_info_p
, gnat_entity
);
978 /* Now check if the type of the object allows atomic access. */
979 if (Is_Atomic_Or_VFA (gnat_entity
))
980 check_ok_for_atomic_type (gnu_type
, gnat_entity
, false);
982 /* If this is a renaming, avoid as much as possible to create a new
983 object. However, in some cases, creating it is required because
984 renaming can be applied to objects that are not names in Ada.
985 This processing needs to be applied to the raw expression so as
986 to make it more likely to rename the underlying object. */
987 if (Present (Renamed_Object (gnat_entity
)))
989 /* If the renamed object had padding, strip off the reference to
990 the inner object and reset our type. */
991 if ((TREE_CODE (gnu_expr
) == COMPONENT_REF
992 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
993 /* Strip useless conversions around the object. */
994 || gnat_useless_type_conversion (gnu_expr
))
996 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
997 gnu_type
= TREE_TYPE (gnu_expr
);
1000 /* Or else, if the renamed object has an unconstrained type with
1001 default discriminant, use the padded type. */
1002 else if (type_is_padding_self_referential (TREE_TYPE (gnu_expr
)))
1003 gnu_type
= TREE_TYPE (gnu_expr
);
1005 /* Case 1: if this is a constant renaming stemming from a function
1006 call, treat it as a normal object whose initial value is what
1007 is being renamed. RM 3.3 says that the result of evaluating a
1008 function call is a constant object. Therefore, it can be the
1009 inner object of a constant renaming and the renaming must be
1010 fully instantiated, i.e. it cannot be a reference to (part of)
1011 an existing object. And treat other rvalues (addresses, null
1012 expressions, constructors and literals) the same way. */
1013 tree inner
= gnu_expr
;
1014 while (handled_component_p (inner
) || CONVERT_EXPR_P (inner
))
1015 inner
= TREE_OPERAND (inner
, 0);
1016 /* Expand_Dispatching_Call can prepend a comparison of the tags
1017 before the call to "=". */
1018 if (TREE_CODE (inner
) == TRUTH_ANDIF_EXPR
1019 || TREE_CODE (inner
) == COMPOUND_EXPR
)
1020 inner
= TREE_OPERAND (inner
, 1);
1021 if ((TREE_CODE (inner
) == CALL_EXPR
1022 && !call_is_atomic_load (inner
))
1023 || TREE_CODE (inner
) == ADDR_EXPR
1024 || TREE_CODE (inner
) == NULL_EXPR
1025 || TREE_CODE (inner
) == PLUS_EXPR
1026 || TREE_CODE (inner
) == CONSTRUCTOR
1027 || CONSTANT_CLASS_P (inner
)
1028 /* We need to detect the case where a temporary is created to
1029 hold the return value, since we cannot safely rename it at
1030 top level as it lives only in the elaboration routine. */
1031 || (TREE_CODE (inner
) == VAR_DECL
1032 && DECL_RETURN_VALUE_P (inner
))
1033 /* We also need to detect the case where the front-end creates
1034 a dangling 'reference to a function call at top level and
1035 substitutes it in the renaming, for example:
1037 q__b : boolean renames r__f.e (1);
1039 can be rewritten into:
1041 q__R1s : constant q__A2s := r__f'reference;
1043 q__b : boolean renames q__R1s.all.e (1);
1045 We cannot safely rename the rewritten expression since the
1046 underlying object lives only in the elaboration routine. */
1047 || (TREE_CODE (inner
) == INDIRECT_REF
1049 = remove_conversions (TREE_OPERAND (inner
, 0), true))
1050 && TREE_CODE (inner
) == VAR_DECL
1051 && DECL_RETURN_VALUE_P (inner
)))
1054 /* Case 2: if the renaming entity need not be materialized, use
1055 the elaborated renamed expression for the renaming. But this
1056 means that the caller is responsible for evaluating the address
1057 of the renaming in the correct place for the definition case to
1058 instantiate the SAVE_EXPRs. */
1059 else if (!Materialize_Entity (gnat_entity
))
1061 tree init
= NULL_TREE
;
1064 = elaborate_reference (gnu_expr
, gnat_entity
, definition
,
1067 /* We cannot evaluate the first arm of a COMPOUND_EXPR in the
1068 correct place for this case. */
1071 /* No DECL_EXPR will be created so the expression needs to be
1072 marked manually because it will likely be shared. */
1073 if (global_bindings_p ())
1074 MARK_VISITED (gnu_decl
);
1076 /* This assertion will fail if the renamed object isn't aligned
1077 enough as to make it possible to honor the alignment set on
1081 unsigned int ralign
= DECL_P (gnu_decl
)
1082 ? DECL_ALIGN (gnu_decl
)
1083 : TYPE_ALIGN (TREE_TYPE (gnu_decl
));
1084 gcc_assert (ralign
>= align
);
1087 /* The expression might not be a DECL so save it manually. */
1088 save_gnu_tree (gnat_entity
, gnu_decl
, true);
1090 annotate_object (gnat_entity
, gnu_type
, NULL_TREE
, false);
1094 /* Case 3: otherwise, make a constant pointer to the object we
1095 are renaming and attach the object to the pointer after it is
1096 elaborated. The object will be referenced directly instead
1097 of indirectly via the pointer to avoid aliasing problems with
1098 non-addressable entities. The pointer is called a "renaming"
1099 pointer in this case. Note that we also need to preserve the
1100 volatility of the renamed object through the indirection. */
1103 tree init
= NULL_TREE
;
1105 if (TREE_THIS_VOLATILE (gnu_expr
) && !TYPE_VOLATILE (gnu_type
))
1107 = change_qualified_type (gnu_type
, TYPE_QUAL_VOLATILE
);
1108 gnu_type
= build_reference_type (gnu_type
);
1111 volatile_flag
= false;
1112 inner_const_flag
= TREE_READONLY (gnu_expr
);
1113 gnu_size
= NULL_TREE
;
1116 = elaborate_reference (gnu_expr
, gnat_entity
, definition
,
1119 /* The expression needs to be marked manually because it will
1120 likely be shared, even for a definition since the ADDR_EXPR
1121 built below can cause the first few nodes to be folded. */
1122 if (global_bindings_p ())
1123 MARK_VISITED (renamed_obj
);
1125 if (type_annotate_only
1126 && TREE_CODE (renamed_obj
) == ERROR_MARK
)
1127 gnu_expr
= NULL_TREE
;
1131 = build_unary_op (ADDR_EXPR
, gnu_type
, renamed_obj
);
1134 = build_compound_expr (TREE_TYPE (gnu_expr
), init
,
1140 /* If we are defining an aliased object whose nominal subtype is
1141 unconstrained, the object is a record that contains both the
1142 template and the object. If there is an initializer, it will
1143 have already been converted to the right type, but we need to
1144 create the template if there is no initializer. */
1147 && TREE_CODE (gnu_type
) == RECORD_TYPE
1148 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
1149 /* Beware that padding might have been introduced above. */
1150 || (TYPE_PADDING_P (gnu_type
)
1151 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
1153 && TYPE_CONTAINS_TEMPLATE_P
1154 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))))
1157 = TYPE_PADDING_P (gnu_type
)
1158 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
1159 : TYPE_FIELDS (gnu_type
);
1160 vec
<constructor_elt
, va_gc
> *v
;
1162 tree t
= build_template (TREE_TYPE (template_field
),
1163 TREE_TYPE (DECL_CHAIN (template_field
)),
1165 CONSTRUCTOR_APPEND_ELT (v
, template_field
, t
);
1166 gnu_expr
= gnat_build_constructor (gnu_type
, v
);
1169 /* Convert the expression to the type of the object if need be. */
1170 if (gnu_expr
&& initial_value_needs_conversion (gnu_type
, gnu_expr
))
1171 gnu_expr
= convert (gnu_type
, gnu_expr
);
1173 /* If this is a pointer that doesn't have an initializing expression,
1174 initialize it to NULL, unless the object is declared imported as
1177 && (POINTER_TYPE_P (gnu_type
) || TYPE_IS_FAT_POINTER_P (gnu_type
))
1179 && !Is_Imported (gnat_entity
))
1180 gnu_expr
= integer_zero_node
;
1182 /* If we are defining the object and it has an Address clause, we must
1183 either get the address expression from the saved GCC tree for the
1184 object if it has a Freeze node, or elaborate the address expression
1185 here since the front-end has guaranteed that the elaboration has no
1186 effects in this case. */
1187 if (definition
&& Present (Address_Clause (gnat_entity
)))
1189 const Node_Id gnat_clause
= Address_Clause (gnat_entity
);
1190 Node_Id gnat_address
= Expression (gnat_clause
);
1192 = present_gnu_tree (gnat_entity
)
1193 ? get_gnu_tree (gnat_entity
) : gnat_to_gnu (gnat_address
);
1195 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
1197 /* Convert the type of the object to a reference type that can
1198 alias everything as per RM 13.3(19). */
1199 if (volatile_flag
&& !TYPE_VOLATILE (gnu_type
))
1200 gnu_type
= change_qualified_type (gnu_type
, TYPE_QUAL_VOLATILE
);
1202 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1203 gnu_address
= convert (gnu_type
, gnu_address
);
1206 = (!Is_Public (gnat_entity
)
1207 || compile_time_known_address_p (gnat_address
));
1208 volatile_flag
= false;
1209 gnu_size
= NULL_TREE
;
1211 /* If this is an aliased object with an unconstrained array nominal
1212 subtype, then it can overlay only another aliased object with an
1213 unconstrained array nominal subtype and compatible template. */
1214 if (Is_Constr_Subt_For_UN_Aliased (gnat_type
)
1215 && Is_Array_Type (Underlying_Type (gnat_type
))
1216 && !type_annotate_only
)
1218 tree rec_type
= TREE_TYPE (gnu_type
);
1219 tree off
= byte_position (DECL_CHAIN (TYPE_FIELDS (rec_type
)));
1221 /* This is the pattern built for a regular object. */
1222 if (TREE_CODE (gnu_address
) == POINTER_PLUS_EXPR
1223 && TREE_OPERAND (gnu_address
, 1) == off
)
1224 gnu_address
= TREE_OPERAND (gnu_address
, 0);
1225 /* This is the pattern built for an overaligned object. */
1226 else if (TREE_CODE (gnu_address
) == POINTER_PLUS_EXPR
1227 && TREE_CODE (TREE_OPERAND (gnu_address
, 1))
1229 && TREE_OPERAND (TREE_OPERAND (gnu_address
, 1), 1)
1232 = build2 (POINTER_PLUS_EXPR
, gnu_type
,
1233 TREE_OPERAND (gnu_address
, 0),
1234 TREE_OPERAND (TREE_OPERAND (gnu_address
, 1), 0));
1237 post_error_ne ("aliased object& with unconstrained array "
1238 "nominal subtype", gnat_clause
,
1240 post_error ("\\can overlay only aliased object with "
1241 "compatible subtype", gnat_clause
);
1245 /* If we don't have an initializing expression for the underlying
1246 variable, the initializing expression for the pointer is the
1247 specified address. Otherwise, we have to make a COMPOUND_EXPR
1248 to assign both the address and the initial value. */
1250 gnu_expr
= gnu_address
;
1253 = build2 (COMPOUND_EXPR
, gnu_type
,
1254 build_binary_op (INIT_EXPR
, NULL_TREE
,
1255 build_unary_op (INDIRECT_REF
,
1262 /* If it has an address clause and we are not defining it, mark it
1263 as an indirect object. Likewise for Stdcall objects that are
1265 if ((!definition
&& Present (Address_Clause (gnat_entity
)))
1266 || (imported_p
&& Has_Stdcall_Convention (gnat_entity
)))
1268 /* Convert the type of the object to a reference type that can
1269 alias everything as per RM 13.3(19). */
1270 if (volatile_flag
&& !TYPE_VOLATILE (gnu_type
))
1271 gnu_type
= change_qualified_type (gnu_type
, TYPE_QUAL_VOLATILE
);
1273 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1276 volatile_flag
= false;
1277 gnu_size
= NULL_TREE
;
1279 /* No point in taking the address of an initializing expression
1280 that isn't going to be used. */
1281 gnu_expr
= NULL_TREE
;
1283 /* If it has an address clause whose value is known at compile
1284 time, make the object a CONST_DECL. This will avoid a
1285 useless dereference. */
1286 if (Present (Address_Clause (gnat_entity
)))
1288 Node_Id gnat_address
1289 = Expression (Address_Clause (gnat_entity
));
1291 if (compile_time_known_address_p (gnat_address
))
1293 gnu_expr
= gnat_to_gnu (gnat_address
);
1299 /* If we are at top level and this object is of variable size,
1300 make the actual type a hidden pointer to the real type and
1301 make the initializer be a memory allocation and initialization.
1302 Likewise for objects we aren't defining (presumed to be
1303 external references from other packages), but there we do
1304 not set up an initialization.
1306 If the object's size overflows, make an allocator too, so that
1307 Storage_Error gets raised. Note that we will never free
1308 such memory, so we presume it never will get allocated. */
1309 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type
),
1310 global_bindings_p ()
1314 && !allocatable_size_p (convert (sizetype
,
1316 (CEIL_DIV_EXPR
, gnu_size
,
1317 bitsize_unit_node
)),
1318 global_bindings_p ()
1322 if (volatile_flag
&& !TYPE_VOLATILE (gnu_type
))
1323 gnu_type
= change_qualified_type (gnu_type
, TYPE_QUAL_VOLATILE
);
1324 gnu_type
= build_reference_type (gnu_type
);
1327 volatile_flag
= false;
1328 gnu_size
= NULL_TREE
;
1330 /* In case this was a aliased object whose nominal subtype is
1331 unconstrained, the pointer above will be a thin pointer and
1332 build_allocator will automatically make the template.
1334 If we have a template initializer only (that we made above),
1335 pretend there is none and rely on what build_allocator creates
1336 again anyway. Otherwise (if we have a full initializer), get
1337 the data part and feed that to build_allocator.
1339 If we are elaborating a mutable object, tell build_allocator to
1340 ignore a possibly simpler size from the initializer, if any, as
1341 we must allocate the maximum possible size in this case. */
1342 if (definition
&& !imported_p
)
1344 tree gnu_alloc_type
= TREE_TYPE (gnu_type
);
1346 if (TREE_CODE (gnu_alloc_type
) == RECORD_TYPE
1347 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type
))
1350 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type
)));
1352 if (TREE_CODE (gnu_expr
) == CONSTRUCTOR
1353 && CONSTRUCTOR_NELTS (gnu_expr
) == 1)
1354 gnu_expr
= NULL_TREE
;
1357 = build_component_ref
1359 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr
))),
1363 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type
)) == INTEGER_CST
1364 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_alloc_type
)))
1365 post_error ("?`Storage_Error` will be raised at run time!",
1369 = build_allocator (gnu_alloc_type
, gnu_expr
, gnu_type
,
1370 Empty
, Empty
, gnat_entity
, mutable_p
);
1373 gnu_expr
= NULL_TREE
;
1376 /* If this object would go into the stack and has an alignment larger
1377 than the largest stack alignment the back-end can honor, resort to
1378 a variable of "aligning type". */
1380 && TYPE_ALIGN (gnu_type
) > BIGGEST_ALIGNMENT
1383 && !global_bindings_p ())
1385 /* Create the new variable. No need for extra room before the
1386 aligned field as this is in automatic storage. */
1388 = make_aligning_type (gnu_type
, TYPE_ALIGN (gnu_type
),
1389 TYPE_SIZE_UNIT (gnu_type
),
1390 BIGGEST_ALIGNMENT
, 0, gnat_entity
);
1392 = create_var_decl (create_concat_name (gnat_entity
, "ALIGN"),
1393 NULL_TREE
, gnu_new_type
, NULL_TREE
,
1394 false, false, false, false, false,
1395 true, debug_info_p
&& definition
, NULL
,
1398 /* Initialize the aligned field if we have an initializer. */
1401 (build_binary_op (INIT_EXPR
, NULL_TREE
,
1403 (gnu_new_var
, TYPE_FIELDS (gnu_new_type
),
1408 /* And setup this entity as a reference to the aligned field. */
1409 gnu_type
= build_reference_type (gnu_type
);
1412 (ADDR_EXPR
, NULL_TREE
,
1413 build_component_ref (gnu_new_var
, TYPE_FIELDS (gnu_new_type
),
1415 TREE_CONSTANT (gnu_expr
) = 1;
1419 volatile_flag
= false;
1420 gnu_size
= NULL_TREE
;
1423 /* If this is an aliased object with an unconstrained array nominal
1424 subtype, we make its type a thin reference, i.e. the reference
1425 counterpart of a thin pointer, so it points to the array part.
1426 This is aimed to make it easier for the debugger to decode the
1427 object. Note that we have to do it this late because of the
1428 couple of allocation adjustments that might be made above. */
1429 if (Is_Constr_Subt_For_UN_Aliased (gnat_type
)
1430 && Is_Array_Type (Underlying_Type (gnat_type
))
1431 && !type_annotate_only
)
1433 /* In case the object with the template has already been allocated
1434 just above, we have nothing to do here. */
1435 if (!TYPE_IS_THIN_POINTER_P (gnu_type
))
1437 /* This variable is a GNAT encoding used by Workbench: let it
1438 go through the debugging information but mark it as
1439 artificial: users are not interested in it. */
1441 = create_var_decl (concat_name (gnu_entity_name
, "UNC"),
1442 NULL_TREE
, gnu_type
, gnu_expr
,
1443 const_flag
, Is_Public (gnat_entity
),
1444 imported_p
|| !definition
, static_flag
,
1445 volatile_flag
, true,
1446 debug_info_p
&& definition
,
1448 gnu_expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_unc_var
);
1449 TREE_CONSTANT (gnu_expr
) = 1;
1453 volatile_flag
= false;
1454 inner_const_flag
= TREE_READONLY (gnu_unc_var
);
1455 gnu_size
= NULL_TREE
;
1458 tree gnu_array
= gnat_to_gnu_type (Base_Type (gnat_type
));
1460 = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array
));
1463 /* Convert the expression to the type of the object if need be. */
1464 if (gnu_expr
&& initial_value_needs_conversion (gnu_type
, gnu_expr
))
1465 gnu_expr
= convert (gnu_type
, gnu_expr
);
1467 /* If this name is external or a name was specified, use it, but don't
1468 use the Interface_Name with an address clause (see cd30005). */
1469 if ((Is_Public (gnat_entity
) && !Is_Imported (gnat_entity
))
1470 || (Present (Interface_Name (gnat_entity
))
1471 && No (Address_Clause (gnat_entity
))))
1472 gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
1474 /* If this is an aggregate constant initialized to a constant, force it
1475 to be statically allocated. This saves an initialization copy. */
1478 && gnu_expr
&& TREE_CONSTANT (gnu_expr
)
1479 && AGGREGATE_TYPE_P (gnu_type
)
1480 && tree_fits_uhwi_p (TYPE_SIZE_UNIT (gnu_type
))
1481 && !(TYPE_IS_PADDING_P (gnu_type
)
1482 && !tree_fits_uhwi_p (TYPE_SIZE_UNIT
1483 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))))
1486 /* Deal with a pragma Linker_Section on a constant or variable. */
1487 if ((kind
== E_Constant
|| kind
== E_Variable
)
1488 && Present (Linker_Section_Pragma (gnat_entity
)))
1489 prepend_one_attribute_pragma (&attr_list
,
1490 Linker_Section_Pragma (gnat_entity
));
1492 /* Now create the variable or the constant and set various flags. */
1494 = create_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
1495 gnu_expr
, const_flag
, Is_Public (gnat_entity
),
1496 imported_p
|| !definition
, static_flag
,
1497 volatile_flag
, artificial_p
,
1498 debug_info_p
&& definition
, attr_list
,
1499 gnat_entity
, !renamed_obj
);
1500 DECL_BY_REF_P (gnu_decl
) = used_by_ref
;
1501 DECL_POINTS_TO_READONLY_P (gnu_decl
) = used_by_ref
&& inner_const_flag
;
1502 DECL_CAN_NEVER_BE_NULL_P (gnu_decl
) = Can_Never_Be_Null (gnat_entity
);
1504 /* If we are defining an Out parameter and optimization isn't enabled,
1505 create a fake PARM_DECL for debugging purposes and make it point to
1506 the VAR_DECL. Suppress debug info for the latter but make sure it
1507 will live in memory so that it can be accessed from within the
1508 debugger through the PARM_DECL. */
1509 if (kind
== E_Out_Parameter
1513 && !flag_generate_lto
)
1515 tree param
= create_param_decl (gnu_entity_name
, gnu_type
);
1516 gnat_pushdecl (param
, gnat_entity
);
1517 SET_DECL_VALUE_EXPR (param
, gnu_decl
);
1518 DECL_HAS_VALUE_EXPR_P (param
) = 1;
1519 DECL_IGNORED_P (gnu_decl
) = 1;
1520 TREE_ADDRESSABLE (gnu_decl
) = 1;
1523 /* If this is a loop parameter, set the corresponding flag. */
1524 else if (kind
== E_Loop_Parameter
)
1525 DECL_LOOP_PARM_P (gnu_decl
) = 1;
1527 /* If this is a renaming pointer, attach the renamed object to it. */
1529 SET_DECL_RENAMED_OBJECT (gnu_decl
, renamed_obj
);
1531 /* If this is a constant and we are defining it or it generates a real
1532 symbol at the object level and we are referencing it, we may want
1533 or need to have a true variable to represent it:
1534 - if optimization isn't enabled, for debugging purposes,
1535 - if the constant is public and not overlaid on something else,
1536 - if its address is taken,
1537 - if either itself or its type is aliased. */
1538 if (TREE_CODE (gnu_decl
) == CONST_DECL
1539 && (definition
|| Sloc (gnat_entity
) > Standard_Location
)
1540 && ((!optimize
&& debug_info_p
)
1541 || (Is_Public (gnat_entity
)
1542 && No (Address_Clause (gnat_entity
)))
1543 || Address_Taken (gnat_entity
)
1544 || Is_Aliased (gnat_entity
)
1545 || Is_Aliased (gnat_type
)))
1548 = create_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
1549 gnu_expr
, true, Is_Public (gnat_entity
),
1550 !definition
, static_flag
, volatile_flag
,
1551 artificial_p
, debug_info_p
&& definition
,
1552 attr_list
, gnat_entity
, false);
1554 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl
, gnu_corr_var
);
1557 /* If this is a constant, even if we don't need a true variable, we
1558 may need to avoid returning the initializer in every case. That
1559 can happen for the address of a (constant) constructor because,
1560 upon dereferencing it, the constructor will be reinjected in the
1561 tree, which may not be valid in every case; see lvalue_required_p
1562 for more details. */
1563 if (TREE_CODE (gnu_decl
) == CONST_DECL
)
1564 DECL_CONST_ADDRESS_P (gnu_decl
) = constructor_address_p (gnu_expr
);
1566 /* If this object is declared in a block that contains a block with an
1567 exception handler, and we aren't using the GCC exception mechanism,
1568 we must force this variable in memory in order to avoid an invalid
1570 if (Front_End_Exceptions ()
1571 && Has_Nested_Block_With_Handler (Scope (gnat_entity
)))
1572 TREE_ADDRESSABLE (gnu_decl
) = 1;
1574 /* If this is a local variable with non-BLKmode and aggregate type,
1575 and optimization isn't enabled, then force it in memory so that
1576 a register won't be allocated to it with possible subparts left
1577 uninitialized and reaching the register allocator. */
1578 else if (TREE_CODE (gnu_decl
) == VAR_DECL
1579 && !DECL_EXTERNAL (gnu_decl
)
1580 && !TREE_STATIC (gnu_decl
)
1581 && DECL_MODE (gnu_decl
) != BLKmode
1582 && AGGREGATE_TYPE_P (TREE_TYPE (gnu_decl
))
1583 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_decl
))
1585 TREE_ADDRESSABLE (gnu_decl
) = 1;
1587 /* If we are defining an object with variable size or an object with
1588 fixed size that will be dynamically allocated, and we are using the
1589 front-end setjmp/longjmp exception mechanism, update the setjmp
1592 && Exception_Mechanism
== Front_End_SJLJ
1593 && get_block_jmpbuf_decl ()
1594 && DECL_SIZE_UNIT (gnu_decl
)
1595 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl
)) != INTEGER_CST
1596 || (flag_stack_check
== GENERIC_STACK_CHECK
1597 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl
),
1598 STACK_CHECK_MAX_VAR_SIZE
) > 0)))
1599 add_stmt_with_node (build_call_n_expr
1600 (update_setjmp_buf_decl
, 1,
1601 build_unary_op (ADDR_EXPR
, NULL_TREE
,
1602 get_block_jmpbuf_decl ())),
1605 /* Back-annotate Esize and Alignment of the object if not already
1606 known. Note that we pick the values of the type, not those of
1607 the object, to shield ourselves from low-level platform-dependent
1608 adjustments like alignment promotion. This is both consistent with
1609 all the treatment above, where alignment and size are set on the
1610 type of the object and not on the object directly, and makes it
1611 possible to support all confirming representation clauses. */
1612 annotate_object (gnat_entity
, TREE_TYPE (gnu_decl
), gnu_object_size
,
1618 /* Return a TYPE_DECL for "void" that we previously made. */
1619 gnu_decl
= TYPE_NAME (void_type_node
);
1622 case E_Enumeration_Type
:
1623 /* A special case: for the types Character and Wide_Character in
1624 Standard, we do not list all the literals. So if the literals
1625 are not specified, make this an integer type. */
1626 if (No (First_Literal (gnat_entity
)))
1628 if (esize
== CHAR_TYPE_SIZE
&& flag_signed_char
)
1629 gnu_type
= make_signed_type (CHAR_TYPE_SIZE
);
1631 gnu_type
= make_unsigned_type (esize
);
1632 TYPE_NAME (gnu_type
) = gnu_entity_name
;
1634 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1635 This is needed by the DWARF-2 back-end to distinguish between
1636 unsigned integer types and character types. */
1637 TYPE_STRING_FLAG (gnu_type
) = 1;
1639 /* This flag is needed by the call just below. */
1640 TYPE_ARTIFICIAL (gnu_type
) = artificial_p
;
1642 finish_character_type (gnu_type
);
1646 /* We have a list of enumeral constants in First_Literal. We make a
1647 CONST_DECL for each one and build into GNU_LITERAL_LIST the list
1648 to be placed into TYPE_FIELDS. Each node is itself a TREE_LIST
1649 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1650 value of the literal. But when we have a regular boolean type, we
1651 simplify this a little by using a BOOLEAN_TYPE. */
1652 const bool is_boolean
= Is_Boolean_Type (gnat_entity
)
1653 && !Has_Non_Standard_Rep (gnat_entity
);
1654 const bool is_unsigned
= Is_Unsigned_Type (gnat_entity
);
1655 tree gnu_list
= NULL_TREE
;
1656 Entity_Id gnat_literal
;
1658 gnu_type
= make_node (is_boolean
? BOOLEAN_TYPE
: ENUMERAL_TYPE
);
1659 TYPE_PRECISION (gnu_type
) = esize
;
1660 TYPE_UNSIGNED (gnu_type
) = is_unsigned
;
1661 set_min_and_max_values_for_integral_type (gnu_type
, esize
,
1662 TYPE_SIGN (gnu_type
));
1663 process_attributes (&gnu_type
, &attr_list
, true, gnat_entity
);
1664 layout_type (gnu_type
);
1666 for (gnat_literal
= First_Literal (gnat_entity
);
1667 Present (gnat_literal
);
1668 gnat_literal
= Next_Literal (gnat_literal
))
1671 = UI_To_gnu (Enumeration_Rep (gnat_literal
), gnu_type
);
1672 /* Do not generate debug info for individual enumerators. */
1674 = create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
1675 gnu_type
, gnu_value
, true, false, false,
1676 false, false, artificial_p
, false,
1677 NULL
, gnat_literal
);
1678 save_gnu_tree (gnat_literal
, gnu_literal
, false);
1680 = tree_cons (DECL_NAME (gnu_literal
), gnu_value
, gnu_list
);
1684 TYPE_VALUES (gnu_type
) = nreverse (gnu_list
);
1686 /* Note that the bounds are updated at the end of this function
1687 to avoid an infinite recursion since they refer to the type. */
1692 case E_Signed_Integer_Type
:
1693 /* For integer types, just make a signed type the appropriate number
1695 gnu_type
= make_signed_type (esize
);
1698 case E_Ordinary_Fixed_Point_Type
:
1699 case E_Decimal_Fixed_Point_Type
:
1701 /* Small_Value is the scale factor. */
1702 const Ureal gnat_small_value
= Small_Value (gnat_entity
);
1703 tree scale_factor
= NULL_TREE
;
1705 gnu_type
= make_signed_type (esize
);
1707 /* Try to decode the scale factor and to save it for the fixed-point
1708 types debug hook. */
1710 /* There are various ways to describe the scale factor, however there
1711 are cases where back-end internals cannot hold it. In such cases,
1712 we output invalid scale factor for such cases (i.e. the 0/0
1713 rational constant) but we expect GNAT to output GNAT encodings,
1714 then. Thus, keep this in sync with
1715 Exp_Dbug.Is_Handled_Scale_Factor. */
1717 /* When encoded as 1/2**N or 1/10**N, describe the scale factor as a
1718 binary or decimal scale: it is easier to read for humans. */
1719 if (UI_Eq (Numerator (gnat_small_value
), Uint_1
)
1720 && (Rbase (gnat_small_value
) == 2
1721 || Rbase (gnat_small_value
) == 10))
1723 /* Given RM restrictions on 'Small values, we assume here that
1724 the denominator fits in an int. */
1725 const tree base
= build_int_cst (integer_type_node
,
1726 Rbase (gnat_small_value
));
1728 = build_int_cst (integer_type_node
,
1729 UI_To_Int (Denominator (gnat_small_value
)));
1731 = build2 (RDIV_EXPR
, integer_type_node
,
1733 build2 (POWER_EXPR
, integer_type_node
,
1737 /* Default to arbitrary scale factors descriptions. */
1740 const Uint num
= Norm_Num (gnat_small_value
);
1741 const Uint den
= Norm_Den (gnat_small_value
);
1743 if (UI_Is_In_Int_Range (num
) && UI_Is_In_Int_Range (den
))
1746 = build_int_cst (integer_type_node
,
1747 UI_To_Int (Norm_Num (gnat_small_value
)));
1749 = build_int_cst (integer_type_node
,
1750 UI_To_Int (Norm_Den (gnat_small_value
)));
1751 scale_factor
= build2 (RDIV_EXPR
, integer_type_node
,
1755 /* If compiler internals cannot represent arbitrary scale
1756 factors, output an invalid scale factor so that debugger
1757 don't try to handle them but so that we still have a type
1758 in the output. Note that GNAT */
1759 scale_factor
= integer_zero_node
;
1762 TYPE_FIXED_POINT_P (gnu_type
) = 1;
1763 SET_TYPE_SCALE_FACTOR (gnu_type
, scale_factor
);
1767 case E_Modular_Integer_Type
:
1769 /* For modular types, make the unsigned type of the proper number
1770 of bits and then set up the modulus, if required. */
1771 tree gnu_modulus
, gnu_high
= NULL_TREE
;
1773 /* Packed Array Impl. Types are supposed to be subtypes only. */
1774 gcc_assert (!Is_Packed_Array_Impl_Type (gnat_entity
));
1776 gnu_type
= make_unsigned_type (esize
);
1778 /* Get the modulus in this type. If it overflows, assume it is because
1779 it is equal to 2**Esize. Note that there is no overflow checking
1780 done on unsigned type, so we detect the overflow by looking for
1781 a modulus of zero, which is otherwise invalid. */
1782 gnu_modulus
= UI_To_gnu (Modulus (gnat_entity
), gnu_type
);
1784 if (!integer_zerop (gnu_modulus
))
1786 TYPE_MODULAR_P (gnu_type
) = 1;
1787 SET_TYPE_MODULUS (gnu_type
, gnu_modulus
);
1788 gnu_high
= fold_build2 (MINUS_EXPR
, gnu_type
, gnu_modulus
,
1789 build_int_cst (gnu_type
, 1));
1792 /* If the upper bound is not maximal, make an extra subtype. */
1794 && !tree_int_cst_equal (gnu_high
, TYPE_MAX_VALUE (gnu_type
)))
1796 tree gnu_subtype
= make_unsigned_type (esize
);
1797 SET_TYPE_RM_MAX_VALUE (gnu_subtype
, gnu_high
);
1798 TREE_TYPE (gnu_subtype
) = gnu_type
;
1799 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
1800 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "UMT");
1801 gnu_type
= gnu_subtype
;
1806 case E_Signed_Integer_Subtype
:
1807 case E_Enumeration_Subtype
:
1808 case E_Modular_Integer_Subtype
:
1809 case E_Ordinary_Fixed_Point_Subtype
:
1810 case E_Decimal_Fixed_Point_Subtype
:
1812 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1813 not want to call create_range_type since we would like each subtype
1814 node to be distinct. ??? Historically this was in preparation for
1815 when memory aliasing is implemented, but that's obsolete now given
1816 the call to relate_alias_sets below.
1818 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1819 this fact is used by the arithmetic conversion functions.
1821 We elaborate the Ancestor_Subtype if it is not in the current unit
1822 and one of our bounds is non-static. We do this to ensure consistent
1823 naming in the case where several subtypes share the same bounds, by
1824 elaborating the first such subtype first, thus using its name. */
1827 && Present (Ancestor_Subtype (gnat_entity
))
1828 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1829 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1830 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1831 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
), gnu_expr
, false);
1833 /* Set the precision to the Esize except for bit-packed arrays. */
1834 if (Is_Packed_Array_Impl_Type (gnat_entity
)
1835 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1836 esize
= UI_To_Int (RM_Size (gnat_entity
));
1838 /* First subtypes of Character are treated as Character; otherwise
1839 this should be an unsigned type if the base type is unsigned or
1840 if the lower bound is constant and non-negative or if the type
1841 is biased. However, even if the lower bound is constant and
1842 non-negative, we use a signed type for a subtype with the same
1843 size as its signed base type, because this eliminates useless
1844 conversions to it and gives more leeway to the optimizer; but
1845 this means that we will need to explicitly test for this case
1846 when we change the representation based on the RM size. */
1847 if (kind
== E_Enumeration_Subtype
1848 && No (First_Literal (Etype (gnat_entity
)))
1849 && Esize (gnat_entity
) == RM_Size (gnat_entity
)
1850 && esize
== CHAR_TYPE_SIZE
1851 && flag_signed_char
)
1852 gnu_type
= make_signed_type (CHAR_TYPE_SIZE
);
1853 else if (Is_Unsigned_Type (Underlying_Type (Etype (gnat_entity
)))
1854 || (Esize (Etype (gnat_entity
)) != Esize (gnat_entity
)
1855 && Is_Unsigned_Type (gnat_entity
))
1856 || Has_Biased_Representation (gnat_entity
))
1857 gnu_type
= make_unsigned_type (esize
);
1859 gnu_type
= make_signed_type (esize
);
1860 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1862 SET_TYPE_RM_MIN_VALUE
1863 (gnu_type
, elaborate_expression (Type_Low_Bound (gnat_entity
),
1864 gnat_entity
, "L", definition
, true,
1867 SET_TYPE_RM_MAX_VALUE
1868 (gnu_type
, elaborate_expression (Type_High_Bound (gnat_entity
),
1869 gnat_entity
, "U", definition
, true,
1872 TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1873 = Has_Biased_Representation (gnat_entity
);
1875 /* Do the same processing for Character subtypes as for types. */
1876 if (TYPE_STRING_FLAG (TREE_TYPE (gnu_type
)))
1878 TYPE_NAME (gnu_type
) = gnu_entity_name
;
1879 TYPE_STRING_FLAG (gnu_type
) = 1;
1880 TYPE_ARTIFICIAL (gnu_type
) = artificial_p
;
1881 finish_character_type (gnu_type
);
1884 /* Inherit our alias set from what we're a subtype of. Subtypes
1885 are not different types and a pointer can designate any instance
1886 within a subtype hierarchy. */
1887 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
1889 /* One of the above calls might have caused us to be elaborated,
1890 so don't blow up if so. */
1891 if (present_gnu_tree (gnat_entity
))
1893 maybe_present
= true;
1897 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1898 TYPE_STUB_DECL (gnu_type
)
1899 = create_type_stub_decl (gnu_entity_name
, gnu_type
);
1901 /* For a packed array, make the original array type a parallel/debug
1903 if (debug_info_p
&& Is_Packed_Array_Impl_Type (gnat_entity
))
1904 associate_original_type_to_packed_array (gnu_type
, gnat_entity
);
1908 /* We have to handle clauses that under-align the type specially. */
1909 if ((Present (Alignment_Clause (gnat_entity
))
1910 || (Is_Packed_Array_Impl_Type (gnat_entity
)
1912 (Alignment_Clause (Original_Array_Type (gnat_entity
)))))
1913 && UI_Is_In_Int_Range (Alignment (gnat_entity
)))
1915 align
= UI_To_Int (Alignment (gnat_entity
)) * BITS_PER_UNIT
;
1916 if (align
>= TYPE_ALIGN (gnu_type
))
1920 /* If the type we are dealing with represents a bit-packed array,
1921 we need to have the bits left justified on big-endian targets
1922 and right justified on little-endian targets. We also need to
1923 ensure that when the value is read (e.g. for comparison of two
1924 such values), we only get the good bits, since the unused bits
1925 are uninitialized. Both goals are accomplished by wrapping up
1926 the modular type in an enclosing record type. */
1927 if (Is_Packed_Array_Impl_Type (gnat_entity
)
1928 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1930 tree gnu_field_type
, gnu_field
;
1932 /* Set the RM size before wrapping up the original type. */
1933 SET_TYPE_RM_SIZE (gnu_type
,
1934 UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
));
1935 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
) = 1;
1937 /* Strip the ___XP suffix for standard DWARF. */
1938 if (gnat_encodings
== DWARF_GNAT_ENCODINGS_MINIMAL
)
1939 gnu_entity_name
= TYPE_NAME (gnu_type
);
1941 /* Create a stripped-down declaration, mainly for debugging. */
1942 create_type_decl (gnu_entity_name
, gnu_type
, true, debug_info_p
,
1945 /* Now save it and build the enclosing record type. */
1946 gnu_field_type
= gnu_type
;
1948 gnu_type
= make_node (RECORD_TYPE
);
1949 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "JM");
1950 TYPE_PACKED (gnu_type
) = 1;
1951 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_field_type
);
1952 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_field_type
);
1953 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_RM_SIZE (gnu_field_type
));
1955 /* Propagate the alignment of the modular type to the record type,
1956 unless there is an alignment clause that under-aligns the type.
1957 This means that bit-packed arrays are given "ceil" alignment for
1958 their size by default, which may seem counter-intuitive but makes
1959 it possible to overlay them on modular types easily. */
1960 SET_TYPE_ALIGN (gnu_type
,
1961 align
> 0 ? align
: TYPE_ALIGN (gnu_field_type
));
1963 /* Propagate the reverse storage order flag to the record type so
1964 that the required byte swapping is performed when retrieving the
1965 enclosed modular value. */
1966 TYPE_REVERSE_STORAGE_ORDER (gnu_type
)
1967 = Reverse_Storage_Order (Original_Array_Type (gnat_entity
));
1969 relate_alias_sets (gnu_type
, gnu_field_type
, ALIAS_SET_COPY
);
1971 /* Don't declare the field as addressable since we won't be taking
1972 its address and this would prevent create_field_decl from making
1975 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type
,
1976 gnu_type
, NULL_TREE
, bitsize_zero_node
, 1, 0);
1978 /* We will output additional debug info manually below. */
1979 finish_record_type (gnu_type
, gnu_field
, 2, false);
1980 compute_record_mode (gnu_type
);
1981 TYPE_JUSTIFIED_MODULAR_P (gnu_type
) = 1;
1985 /* Make the original array type a parallel/debug type. */
1986 associate_original_type_to_packed_array (gnu_type
, gnat_entity
);
1988 /* Since GNU_TYPE is a padding type around the packed array
1989 implementation type, the padded type is its debug type. */
1990 if (gnat_encodings
== DWARF_GNAT_ENCODINGS_MINIMAL
)
1991 SET_TYPE_DEBUG_TYPE (gnu_type
, gnu_field_type
);
1995 /* If the type we are dealing with has got a smaller alignment than the
1996 natural one, we need to wrap it up in a record type and misalign the
1997 latter; we reuse the padding machinery for this purpose. */
2000 tree gnu_size
= UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
);
2002 /* Set the RM size before wrapping the type. */
2003 SET_TYPE_RM_SIZE (gnu_type
, gnu_size
);
2006 = maybe_pad_type (gnu_type
, TYPE_SIZE (gnu_type
), align
,
2007 gnat_entity
, false, true, definition
, false);
2009 TYPE_PACKED (gnu_type
) = 1;
2010 SET_TYPE_ADA_SIZE (gnu_type
, gnu_size
);
2015 case E_Floating_Point_Type
:
2016 /* The type of the Low and High bounds can be our type if this is
2017 a type from Standard, so set them at the end of the function. */
2018 gnu_type
= make_node (REAL_TYPE
);
2019 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
2020 layout_type (gnu_type
);
2023 case E_Floating_Point_Subtype
:
2024 /* See the E_Signed_Integer_Subtype case for the rationale. */
2026 && Present (Ancestor_Subtype (gnat_entity
))
2027 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
2028 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
2029 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
2030 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
), gnu_expr
, false);
2032 gnu_type
= make_node (REAL_TYPE
);
2033 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
2034 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
2035 TYPE_GCC_MIN_VALUE (gnu_type
)
2036 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type
));
2037 TYPE_GCC_MAX_VALUE (gnu_type
)
2038 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type
));
2039 layout_type (gnu_type
);
2041 SET_TYPE_RM_MIN_VALUE
2042 (gnu_type
, elaborate_expression (Type_Low_Bound (gnat_entity
),
2043 gnat_entity
, "L", definition
, true,
2046 SET_TYPE_RM_MAX_VALUE
2047 (gnu_type
, elaborate_expression (Type_High_Bound (gnat_entity
),
2048 gnat_entity
, "U", definition
, true,
2051 /* Inherit our alias set from what we're a subtype of, as for
2052 integer subtypes. */
2053 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
2055 /* One of the above calls might have caused us to be elaborated,
2056 so don't blow up if so. */
2057 maybe_present
= true;
2060 /* Array Types and Subtypes
2062 Unconstrained array types are represented by E_Array_Type and
2063 constrained array types are represented by E_Array_Subtype. There
2064 are no actual objects of an unconstrained array type; all we have
2065 are pointers to that type.
2067 The following fields are defined on array types and subtypes:
2069 Component_Type Component type of the array.
2070 Number_Dimensions Number of dimensions (an int).
2071 First_Index Type of first index. */
2075 const bool convention_fortran_p
2076 = (Convention (gnat_entity
) == Convention_Fortran
);
2077 const int ndim
= Number_Dimensions (gnat_entity
);
2078 tree gnu_template_type
;
2079 tree gnu_ptr_template
;
2080 tree gnu_template_reference
, gnu_template_fields
, gnu_fat_type
;
2081 tree
*gnu_index_types
= XALLOCAVEC (tree
, ndim
);
2082 tree
*gnu_temp_fields
= XALLOCAVEC (tree
, ndim
);
2083 tree gnu_max_size
= size_one_node
, gnu_max_size_unit
, tem
, t
;
2084 Entity_Id gnat_index
, gnat_name
;
2088 /* Create the type for the component now, as it simplifies breaking
2089 type reference loops. */
2091 = gnat_to_gnu_component_type (gnat_entity
, definition
, debug_info_p
);
2092 if (present_gnu_tree (gnat_entity
))
2094 /* As a side effect, the type may have been translated. */
2095 maybe_present
= true;
2099 /* We complete an existing dummy fat pointer type in place. This both
2100 avoids further complex adjustments in update_pointer_to and yields
2101 better debugging information in DWARF by leveraging the support for
2102 incomplete declarations of "tagged" types in the DWARF back-end. */
2103 gnu_type
= get_dummy_type (gnat_entity
);
2104 if (gnu_type
&& TYPE_POINTER_TO (gnu_type
))
2106 gnu_fat_type
= TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type
));
2107 TYPE_NAME (gnu_fat_type
) = NULL_TREE
;
2108 /* Save the contents of the dummy type for update_pointer_to. */
2109 TYPE_POINTER_TO (gnu_type
) = copy_type (gnu_fat_type
);
2111 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type
)));
2112 gnu_template_type
= TREE_TYPE (gnu_ptr_template
);
2116 gnu_fat_type
= make_node (RECORD_TYPE
);
2117 gnu_template_type
= make_node (RECORD_TYPE
);
2118 gnu_ptr_template
= build_pointer_type (gnu_template_type
);
2121 /* Make a node for the array. If we are not defining the array
2122 suppress expanding incomplete types. */
2123 gnu_type
= make_node (UNCONSTRAINED_ARRAY_TYPE
);
2127 defer_incomplete_level
++;
2128 this_deferred
= true;
2131 /* Build the fat pointer type. Use a "void *" object instead of
2132 a pointer to the array type since we don't have the array type
2133 yet (it will reference the fat pointer via the bounds). */
2135 = create_field_decl (get_identifier ("P_ARRAY"), ptr_type_node
,
2136 gnu_fat_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2138 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template
,
2139 gnu_fat_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2141 if (COMPLETE_TYPE_P (gnu_fat_type
))
2143 /* We are going to lay it out again so reset the alias set. */
2144 alias_set_type alias_set
= TYPE_ALIAS_SET (gnu_fat_type
);
2145 TYPE_ALIAS_SET (gnu_fat_type
) = -1;
2146 finish_fat_pointer_type (gnu_fat_type
, tem
);
2147 TYPE_ALIAS_SET (gnu_fat_type
) = alias_set
;
2148 for (t
= gnu_fat_type
; t
; t
= TYPE_NEXT_VARIANT (t
))
2150 TYPE_FIELDS (t
) = tem
;
2151 SET_TYPE_UNCONSTRAINED_ARRAY (t
, gnu_type
);
2156 finish_fat_pointer_type (gnu_fat_type
, tem
);
2157 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type
, gnu_type
);
2160 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2161 is the fat pointer. This will be used to access the individual
2162 fields once we build them. */
2163 tem
= build3 (COMPONENT_REF
, gnu_ptr_template
,
2164 build0 (PLACEHOLDER_EXPR
, gnu_fat_type
),
2165 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type
)), NULL_TREE
);
2166 gnu_template_reference
2167 = build_unary_op (INDIRECT_REF
, gnu_template_type
, tem
);
2168 TREE_READONLY (gnu_template_reference
) = 1;
2169 TREE_THIS_NOTRAP (gnu_template_reference
) = 1;
2171 /* Now create the GCC type for each index and add the fields for that
2172 index to the template. */
2173 for (index
= (convention_fortran_p
? ndim
- 1 : 0),
2174 gnat_index
= First_Index (gnat_entity
);
2175 0 <= index
&& index
< ndim
;
2176 index
+= (convention_fortran_p
? - 1 : 1),
2177 gnat_index
= Next_Index (gnat_index
))
2179 char field_name
[16];
2180 tree gnu_index_type
= get_unpadded_type (Etype (gnat_index
));
2181 tree gnu_index_base_type
2182 = maybe_character_type (get_base_type (gnu_index_type
));
2183 tree gnu_lb_field
, gnu_hb_field
, gnu_orig_min
, gnu_orig_max
;
2184 tree gnu_min
, gnu_max
, gnu_high
;
2186 /* Make the FIELD_DECLs for the low and high bounds of this
2187 type and then make extractions of these fields from the
2189 sprintf (field_name
, "LB%d", index
);
2190 gnu_lb_field
= create_field_decl (get_identifier (field_name
),
2191 gnu_index_base_type
,
2192 gnu_template_type
, NULL_TREE
,
2194 Sloc_to_locus (Sloc (gnat_entity
),
2195 &DECL_SOURCE_LOCATION (gnu_lb_field
));
2197 field_name
[0] = 'U';
2198 gnu_hb_field
= create_field_decl (get_identifier (field_name
),
2199 gnu_index_base_type
,
2200 gnu_template_type
, NULL_TREE
,
2202 Sloc_to_locus (Sloc (gnat_entity
),
2203 &DECL_SOURCE_LOCATION (gnu_hb_field
));
2205 gnu_temp_fields
[index
] = chainon (gnu_lb_field
, gnu_hb_field
);
2207 /* We can't use build_component_ref here since the template type
2208 isn't complete yet. */
2209 gnu_orig_min
= build3 (COMPONENT_REF
, gnu_index_base_type
,
2210 gnu_template_reference
, gnu_lb_field
,
2212 gnu_orig_max
= build3 (COMPONENT_REF
, gnu_index_base_type
,
2213 gnu_template_reference
, gnu_hb_field
,
2215 TREE_READONLY (gnu_orig_min
) = TREE_READONLY (gnu_orig_max
) = 1;
2217 gnu_min
= convert (sizetype
, gnu_orig_min
);
2218 gnu_max
= convert (sizetype
, gnu_orig_max
);
2220 /* Compute the size of this dimension. See the E_Array_Subtype
2221 case below for the rationale. */
2223 = build3 (COND_EXPR
, sizetype
,
2224 build2 (GE_EXPR
, boolean_type_node
,
2225 gnu_orig_max
, gnu_orig_min
),
2227 size_binop (MINUS_EXPR
, gnu_min
, size_one_node
));
2229 /* Make a range type with the new range in the Ada base type.
2230 Then make an index type with the size range in sizetype. */
2231 gnu_index_types
[index
]
2232 = create_index_type (gnu_min
, gnu_high
,
2233 create_range_type (gnu_index_base_type
,
2238 /* Update the maximum size of the array in elements. */
2242 = convert (sizetype
, TYPE_MIN_VALUE (gnu_index_type
));
2244 = convert (sizetype
, TYPE_MAX_VALUE (gnu_index_type
));
2246 = size_binop (PLUS_EXPR
, size_one_node
,
2247 size_binop (MINUS_EXPR
, gnu_max
, gnu_min
));
2249 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2250 && TREE_OVERFLOW (gnu_this_max
))
2251 gnu_max_size
= NULL_TREE
;
2254 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2257 TYPE_NAME (gnu_index_types
[index
])
2258 = create_concat_name (gnat_entity
, field_name
);
2261 /* Install all the fields into the template. */
2262 TYPE_NAME (gnu_template_type
)
2263 = create_concat_name (gnat_entity
, "XUB");
2264 gnu_template_fields
= NULL_TREE
;
2265 for (index
= 0; index
< ndim
; index
++)
2267 = chainon (gnu_template_fields
, gnu_temp_fields
[index
]);
2268 finish_record_type (gnu_template_type
, gnu_template_fields
, 0,
2270 TYPE_READONLY (gnu_template_type
) = 1;
2272 /* If Component_Size is not already specified, annotate it with the
2273 size of the component. */
2274 if (Unknown_Component_Size (gnat_entity
))
2275 Set_Component_Size (gnat_entity
,
2276 annotate_value (TYPE_SIZE (comp_type
)));
2278 /* Compute the maximum size of the array in units and bits. */
2281 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2282 TYPE_SIZE_UNIT (comp_type
));
2283 gnu_max_size
= size_binop (MULT_EXPR
,
2284 convert (bitsizetype
, gnu_max_size
),
2285 TYPE_SIZE (comp_type
));
2288 gnu_max_size_unit
= NULL_TREE
;
2290 /* Now build the array type. */
2292 for (index
= ndim
- 1; index
>= 0; index
--)
2294 tem
= build_nonshared_array_type (tem
, gnu_index_types
[index
]);
2295 TYPE_MULTI_ARRAY_P (tem
) = (index
> 0);
2296 TYPE_CONVENTION_FORTRAN_P (tem
) = convention_fortran_p
;
2297 if (index
== ndim
- 1 && Reverse_Storage_Order (gnat_entity
))
2298 set_reverse_storage_order_on_array_type (tem
);
2299 if (array_type_has_nonaliased_component (tem
, gnat_entity
))
2300 set_nonaliased_component_on_array_type (tem
);
2303 /* If an alignment is specified, use it if valid. But ignore it
2304 for the original type of packed array types. If the alignment
2305 was requested with an explicit alignment clause, state so. */
2306 if (No (Packed_Array_Impl_Type (gnat_entity
))
2307 && Known_Alignment (gnat_entity
))
2309 SET_TYPE_ALIGN (tem
,
2310 validate_alignment (Alignment (gnat_entity
),
2313 if (Present (Alignment_Clause (gnat_entity
)))
2314 TYPE_USER_ALIGN (tem
) = 1;
2317 /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
2318 implementation types as such so that the debug information back-end
2319 can output the appropriate description for them. */
2321 = (Is_Packed (gnat_entity
)
2322 || Is_Packed_Array_Impl_Type (gnat_entity
));
2324 if (Treat_As_Volatile (gnat_entity
))
2325 tem
= change_qualified_type (tem
, TYPE_QUAL_VOLATILE
);
2327 /* Adjust the type of the pointer-to-array field of the fat pointer
2328 and record the aliasing relationships if necessary. */
2329 TREE_TYPE (TYPE_FIELDS (gnu_fat_type
)) = build_pointer_type (tem
);
2330 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type
))
2331 record_component_aliases (gnu_fat_type
);
2333 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2334 corresponding fat pointer. */
2335 TREE_TYPE (gnu_type
) = gnu_fat_type
;
2336 TYPE_POINTER_TO (gnu_type
) = gnu_fat_type
;
2337 TYPE_REFERENCE_TO (gnu_type
) = gnu_fat_type
;
2338 SET_TYPE_MODE (gnu_type
, BLKmode
);
2339 SET_TYPE_ALIGN (gnu_type
, TYPE_ALIGN (tem
));
2341 /* If the maximum size doesn't overflow, use it. */
2343 && TREE_CODE (gnu_max_size
) == INTEGER_CST
2344 && !TREE_OVERFLOW (gnu_max_size
)
2345 && TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2346 && !TREE_OVERFLOW (gnu_max_size_unit
))
2348 TYPE_SIZE (tem
) = size_binop (MIN_EXPR
, gnu_max_size
,
2350 TYPE_SIZE_UNIT (tem
) = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2351 TYPE_SIZE_UNIT (tem
));
2354 create_type_decl (create_concat_name (gnat_entity
, "XUA"), tem
,
2355 artificial_p
, debug_info_p
, gnat_entity
);
2357 /* If told to generate GNAT encodings for them (GDB rely on them at the
2358 moment): give the fat pointer type a name. If this is a packed
2359 array, tell the debugger how to interpret the underlying bits. */
2360 if (Present (Packed_Array_Impl_Type (gnat_entity
)))
2361 gnat_name
= Packed_Array_Impl_Type (gnat_entity
);
2363 gnat_name
= gnat_entity
;
2365 = (gnat_encodings
== DWARF_GNAT_ENCODINGS_MINIMAL
)
2366 ? get_entity_name (gnat_name
)
2367 : create_concat_name (gnat_name
, "XUP");
2368 create_type_decl (xup_name
, gnu_fat_type
, artificial_p
, debug_info_p
,
2371 /* Create the type to be designated by thin pointers: a record type for
2372 the array and its template. We used to shift the fields to have the
2373 template at a negative offset, but this was somewhat of a kludge; we
2374 now shift thin pointer values explicitly but only those which have a
2375 TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE.
2376 Note that GDB can handle standard DWARF information for them, so we
2377 don't have to name them as a GNAT encoding, except if specifically
2380 = (gnat_encodings
== DWARF_GNAT_ENCODINGS_MINIMAL
)
2381 ? get_entity_name (gnat_name
)
2382 : create_concat_name (gnat_name
, "XUT");
2383 tem
= build_unc_object_type (gnu_template_type
, tem
, xut_name
,
2386 SET_TYPE_UNCONSTRAINED_ARRAY (tem
, gnu_type
);
2387 TYPE_OBJECT_RECORD_TYPE (gnu_type
) = tem
;
2391 case E_Array_Subtype
:
2393 /* This is the actual data type for array variables. Multidimensional
2394 arrays are implemented as arrays of arrays. Note that arrays which
2395 have sparse enumeration subtypes as index components create sparse
2396 arrays, which is obviously space inefficient but so much easier to
2399 Also note that the subtype never refers to the unconstrained array
2400 type, which is somewhat at variance with Ada semantics.
2402 First check to see if this is simply a renaming of the array type.
2403 If so, the result is the array type. */
2405 gnu_type
= TYPE_MAIN_VARIANT (gnat_to_gnu_type (Etype (gnat_entity
)));
2406 if (!Is_Constrained (gnat_entity
))
2410 Entity_Id gnat_index
, gnat_base_index
;
2411 const bool convention_fortran_p
2412 = (Convention (gnat_entity
) == Convention_Fortran
);
2413 const int ndim
= Number_Dimensions (gnat_entity
);
2414 tree gnu_base_type
= gnu_type
;
2415 tree
*gnu_index_types
= XALLOCAVEC (tree
, ndim
);
2416 tree gnu_max_size
= size_one_node
, gnu_max_size_unit
;
2417 bool need_index_type_struct
= false;
2420 /* First create the GCC type for each index and find out whether
2421 special types are needed for debugging information. */
2422 for (index
= (convention_fortran_p
? ndim
- 1 : 0),
2423 gnat_index
= First_Index (gnat_entity
),
2425 = First_Index (Implementation_Base_Type (gnat_entity
));
2426 0 <= index
&& index
< ndim
;
2427 index
+= (convention_fortran_p
? - 1 : 1),
2428 gnat_index
= Next_Index (gnat_index
),
2429 gnat_base_index
= Next_Index (gnat_base_index
))
2431 tree gnu_index_type
= get_unpadded_type (Etype (gnat_index
));
2432 tree gnu_index_base_type
2433 = maybe_character_type (get_base_type (gnu_index_type
));
2435 = convert (gnu_index_base_type
,
2436 TYPE_MIN_VALUE (gnu_index_type
));
2438 = convert (gnu_index_base_type
,
2439 TYPE_MAX_VALUE (gnu_index_type
));
2440 tree gnu_min
= convert (sizetype
, gnu_orig_min
);
2441 tree gnu_max
= convert (sizetype
, gnu_orig_max
);
2442 tree gnu_base_index_type
2443 = get_unpadded_type (Etype (gnat_base_index
));
2444 tree gnu_base_index_base_type
2445 = maybe_character_type (get_base_type (gnu_base_index_type
));
2446 tree gnu_base_orig_min
2447 = convert (gnu_base_index_base_type
,
2448 TYPE_MIN_VALUE (gnu_base_index_type
));
2449 tree gnu_base_orig_max
2450 = convert (gnu_base_index_base_type
,
2451 TYPE_MAX_VALUE (gnu_base_index_type
));
2454 /* See if the base array type is already flat. If it is, we
2455 are probably compiling an ACATS test but it will cause the
2456 code below to malfunction if we don't handle it specially. */
2457 if (TREE_CODE (gnu_base_orig_min
) == INTEGER_CST
2458 && TREE_CODE (gnu_base_orig_max
) == INTEGER_CST
2459 && tree_int_cst_lt (gnu_base_orig_max
, gnu_base_orig_min
))
2461 gnu_min
= size_one_node
;
2462 gnu_max
= size_zero_node
;
2466 /* Similarly, if one of the values overflows in sizetype and the
2467 range is null, use 1..0 for the sizetype bounds. */
2468 else if (TREE_CODE (gnu_min
) == INTEGER_CST
2469 && TREE_CODE (gnu_max
) == INTEGER_CST
2470 && (TREE_OVERFLOW (gnu_min
) || TREE_OVERFLOW (gnu_max
))
2471 && tree_int_cst_lt (gnu_orig_max
, gnu_orig_min
))
2473 gnu_min
= size_one_node
;
2474 gnu_max
= size_zero_node
;
2478 /* If the minimum and maximum values both overflow in sizetype,
2479 but the difference in the original type does not overflow in
2480 sizetype, ignore the overflow indication. */
2481 else if (TREE_CODE (gnu_min
) == INTEGER_CST
2482 && TREE_CODE (gnu_max
) == INTEGER_CST
2483 && TREE_OVERFLOW (gnu_min
) && TREE_OVERFLOW (gnu_max
)
2486 fold_build2 (MINUS_EXPR
, gnu_index_type
,
2490 TREE_OVERFLOW (gnu_min
) = 0;
2491 TREE_OVERFLOW (gnu_max
) = 0;
2495 /* Compute the size of this dimension in the general case. We
2496 need to provide GCC with an upper bound to use but have to
2497 deal with the "superflat" case. There are three ways to do
2498 this. If we can prove that the array can never be superflat,
2499 we can just use the high bound of the index type. */
2500 else if ((Nkind (gnat_index
) == N_Range
2501 && cannot_be_superflat (gnat_index
))
2502 /* Bit-Packed Array Impl. Types are never superflat. */
2503 || (Is_Packed_Array_Impl_Type (gnat_entity
)
2504 && Is_Bit_Packed_Array
2505 (Original_Array_Type (gnat_entity
))))
2508 /* Otherwise, if the high bound is constant but the low bound is
2509 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2510 lower bound. Note that the comparison must be done in the
2511 original type to avoid any overflow during the conversion. */
2512 else if (TREE_CODE (gnu_max
) == INTEGER_CST
2513 && TREE_CODE (gnu_min
) != INTEGER_CST
)
2517 = build_cond_expr (sizetype
,
2518 build_binary_op (GE_EXPR
,
2523 int_const_binop (PLUS_EXPR
, gnu_max
,
2527 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2528 in all the other cases. Note that, here as well as above,
2529 the condition used in the comparison must be equivalent to
2530 the condition (length != 0). This is relied upon in order
2531 to optimize array comparisons in compare_arrays. Moreover
2532 we use int_const_binop for the shift by 1 if the bound is
2533 constant to avoid any unwanted overflow. */
2536 = build_cond_expr (sizetype
,
2537 build_binary_op (GE_EXPR
,
2542 TREE_CODE (gnu_min
) == INTEGER_CST
2543 ? int_const_binop (MINUS_EXPR
, gnu_min
,
2545 : size_binop (MINUS_EXPR
, gnu_min
,
2548 /* Reuse the index type for the range type. Then make an index
2549 type with the size range in sizetype. */
2550 gnu_index_types
[index
]
2551 = create_index_type (gnu_min
, gnu_high
, gnu_index_type
,
2554 /* Update the maximum size of the array in elements. Here we
2555 see if any constraint on the index type of the base type
2556 can be used in the case of self-referential bound on the
2557 index type of the subtype. We look for a non-"infinite"
2558 and non-self-referential bound from any type involved and
2559 handle each bound separately. */
2562 tree gnu_base_min
= convert (sizetype
, gnu_base_orig_min
);
2563 tree gnu_base_max
= convert (sizetype
, gnu_base_orig_max
);
2564 tree gnu_base_base_min
2565 = convert (sizetype
,
2566 TYPE_MIN_VALUE (gnu_base_index_base_type
));
2567 tree gnu_base_base_max
2568 = convert (sizetype
,
2569 TYPE_MAX_VALUE (gnu_base_index_base_type
));
2571 if (!CONTAINS_PLACEHOLDER_P (gnu_min
)
2572 || !(TREE_CODE (gnu_base_min
) == INTEGER_CST
2573 && !TREE_OVERFLOW (gnu_base_min
)))
2574 gnu_base_min
= gnu_min
;
2576 if (!CONTAINS_PLACEHOLDER_P (gnu_max
)
2577 || !(TREE_CODE (gnu_base_max
) == INTEGER_CST
2578 && !TREE_OVERFLOW (gnu_base_max
)))
2579 gnu_base_max
= gnu_max
;
2581 if ((TREE_CODE (gnu_base_min
) == INTEGER_CST
2582 && TREE_OVERFLOW (gnu_base_min
))
2583 || operand_equal_p (gnu_base_min
, gnu_base_base_min
, 0)
2584 || (TREE_CODE (gnu_base_max
) == INTEGER_CST
2585 && TREE_OVERFLOW (gnu_base_max
))
2586 || operand_equal_p (gnu_base_max
, gnu_base_base_max
, 0))
2587 gnu_max_size
= NULL_TREE
;
2592 /* Use int_const_binop if the bounds are constant to
2593 avoid any unwanted overflow. */
2594 if (TREE_CODE (gnu_base_min
) == INTEGER_CST
2595 && TREE_CODE (gnu_base_max
) == INTEGER_CST
)
2597 = int_const_binop (PLUS_EXPR
, size_one_node
,
2598 int_const_binop (MINUS_EXPR
,
2603 = size_binop (PLUS_EXPR
, size_one_node
,
2604 size_binop (MINUS_EXPR
,
2609 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2613 /* We need special types for debugging information to point to
2614 the index types if they have variable bounds, are not integer
2615 types, are biased or are wider than sizetype. These are GNAT
2616 encodings, so we have to include them only when all encodings
2618 if ((TREE_CODE (gnu_orig_min
) != INTEGER_CST
2619 || TREE_CODE (gnu_orig_max
) != INTEGER_CST
2620 || TREE_CODE (gnu_index_type
) != INTEGER_TYPE
2621 || (TREE_TYPE (gnu_index_type
)
2622 && TREE_CODE (TREE_TYPE (gnu_index_type
))
2624 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type
))
2625 && gnat_encodings
!= DWARF_GNAT_ENCODINGS_MINIMAL
)
2626 need_index_type_struct
= true;
2629 /* Then flatten: create the array of arrays. For an array type
2630 used to implement a packed array, get the component type from
2631 the original array type since the representation clauses that
2632 can affect it are on the latter. */
2633 if (Is_Packed_Array_Impl_Type (gnat_entity
)
2634 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
2636 gnu_type
= gnat_to_gnu_type (Original_Array_Type (gnat_entity
));
2637 for (index
= ndim
- 1; index
>= 0; index
--)
2638 gnu_type
= TREE_TYPE (gnu_type
);
2640 /* One of the above calls might have caused us to be elaborated,
2641 so don't blow up if so. */
2642 if (present_gnu_tree (gnat_entity
))
2644 maybe_present
= true;
2650 gnu_type
= gnat_to_gnu_component_type (gnat_entity
, definition
,
2653 /* One of the above calls might have caused us to be elaborated,
2654 so don't blow up if so. */
2655 if (present_gnu_tree (gnat_entity
))
2657 maybe_present
= true;
2662 /* Compute the maximum size of the array in units and bits. */
2665 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2666 TYPE_SIZE_UNIT (gnu_type
));
2667 gnu_max_size
= size_binop (MULT_EXPR
,
2668 convert (bitsizetype
, gnu_max_size
),
2669 TYPE_SIZE (gnu_type
));
2672 gnu_max_size_unit
= NULL_TREE
;
2674 /* Now build the array type. */
2675 for (index
= ndim
- 1; index
>= 0; index
--)
2677 gnu_type
= build_nonshared_array_type (gnu_type
,
2678 gnu_index_types
[index
]);
2679 TYPE_MULTI_ARRAY_P (gnu_type
) = (index
> 0);
2680 TYPE_CONVENTION_FORTRAN_P (gnu_type
) = convention_fortran_p
;
2681 if (index
== ndim
- 1 && Reverse_Storage_Order (gnat_entity
))
2682 set_reverse_storage_order_on_array_type (gnu_type
);
2683 if (array_type_has_nonaliased_component (gnu_type
, gnat_entity
))
2684 set_nonaliased_component_on_array_type (gnu_type
);
2687 /* Strip the ___XP suffix for standard DWARF. */
2688 if (Is_Packed_Array_Impl_Type (gnat_entity
)
2689 && gnat_encodings
== DWARF_GNAT_ENCODINGS_MINIMAL
)
2691 Entity_Id gnat_original_array_type
2692 = Underlying_Type (Original_Array_Type (gnat_entity
));
2695 = get_entity_name (gnat_original_array_type
);
2698 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2699 TYPE_STUB_DECL (gnu_type
)
2700 = create_type_stub_decl (gnu_entity_name
, gnu_type
);
2702 /* If this is a multi-dimensional array and we are at global level,
2703 we need to make a variable corresponding to the stride of the
2704 inner dimensions. */
2705 if (ndim
> 1 && global_bindings_p ())
2709 for (gnu_arr_type
= TREE_TYPE (gnu_type
), index
= 1;
2710 TREE_CODE (gnu_arr_type
) == ARRAY_TYPE
;
2711 gnu_arr_type
= TREE_TYPE (gnu_arr_type
), index
++)
2713 tree eltype
= TREE_TYPE (gnu_arr_type
);
2714 char stride_name
[32];
2716 sprintf (stride_name
, "ST%d", index
);
2717 TYPE_SIZE (gnu_arr_type
)
2718 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type
),
2719 gnat_entity
, stride_name
,
2722 /* ??? For now, store the size as a multiple of the
2723 alignment of the element type in bytes so that we
2724 can see the alignment from the tree. */
2725 sprintf (stride_name
, "ST%d_A_UNIT", index
);
2726 TYPE_SIZE_UNIT (gnu_arr_type
)
2727 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type
),
2728 gnat_entity
, stride_name
,
2730 TYPE_ALIGN (eltype
));
2732 /* ??? create_type_decl is not invoked on the inner types so
2733 the MULT_EXPR node built above will never be marked. */
2734 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type
));
2738 /* If we need to write out a record type giving the names of the
2739 bounds for debugging purposes, do it now and make the record
2740 type a parallel type. This is not needed for a packed array
2741 since the bounds are conveyed by the original array type. */
2742 if (need_index_type_struct
2744 && !Is_Packed_Array_Impl_Type (gnat_entity
))
2746 tree gnu_bound_rec
= make_node (RECORD_TYPE
);
2747 tree gnu_field_list
= NULL_TREE
;
2750 TYPE_NAME (gnu_bound_rec
)
2751 = create_concat_name (gnat_entity
, "XA");
2753 for (index
= ndim
- 1; index
>= 0; index
--)
2755 tree gnu_index
= TYPE_INDEX_TYPE (gnu_index_types
[index
]);
2756 tree gnu_index_name
= TYPE_IDENTIFIER (gnu_index
);
2758 /* Make sure to reference the types themselves, and not just
2759 their names, as the debugger may fall back on them. */
2760 gnu_field
= create_field_decl (gnu_index_name
, gnu_index
,
2761 gnu_bound_rec
, NULL_TREE
,
2763 DECL_CHAIN (gnu_field
) = gnu_field_list
;
2764 gnu_field_list
= gnu_field
;
2767 finish_record_type (gnu_bound_rec
, gnu_field_list
, 0, true);
2768 add_parallel_type (gnu_type
, gnu_bound_rec
);
2771 /* If this is a packed array type, make the original array type a
2772 parallel/debug type. Otherwise, if such GNAT encodings are
2773 required, do it for the base array type if it isn't artificial to
2774 make sure it is kept in the debug info. */
2777 if (Is_Packed_Array_Impl_Type (gnat_entity
))
2778 associate_original_type_to_packed_array (gnu_type
,
2783 = gnat_to_gnu_entity (Etype (gnat_entity
), NULL_TREE
,
2785 if (!DECL_ARTIFICIAL (gnu_base_decl
)
2786 && gnat_encodings
!= DWARF_GNAT_ENCODINGS_MINIMAL
)
2787 add_parallel_type (gnu_type
,
2788 TREE_TYPE (TREE_TYPE (gnu_base_decl
)));
2792 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
2793 = (Is_Packed_Array_Impl_Type (gnat_entity
)
2794 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
2796 /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
2797 implementation types as such so that the debug information back-end
2798 can output the appropriate description for them. */
2799 TYPE_PACKED (gnu_type
)
2800 = (Is_Packed (gnat_entity
)
2801 || Is_Packed_Array_Impl_Type (gnat_entity
));
2803 /* If the size is self-referential and the maximum size doesn't
2804 overflow, use it. */
2805 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
2807 && !(TREE_CODE (gnu_max_size
) == INTEGER_CST
2808 && TREE_OVERFLOW (gnu_max_size
))
2809 && !(TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2810 && TREE_OVERFLOW (gnu_max_size_unit
)))
2812 TYPE_SIZE (gnu_type
) = size_binop (MIN_EXPR
, gnu_max_size
,
2813 TYPE_SIZE (gnu_type
));
2814 TYPE_SIZE_UNIT (gnu_type
)
2815 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2816 TYPE_SIZE_UNIT (gnu_type
));
2819 /* Set our alias set to that of our base type. This gives all
2820 array subtypes the same alias set. */
2821 relate_alias_sets (gnu_type
, gnu_base_type
, ALIAS_SET_COPY
);
2823 /* If this is a packed type, make this type the same as the packed
2824 array type, but do some adjusting in the type first. */
2825 if (Present (Packed_Array_Impl_Type (gnat_entity
)))
2827 Entity_Id gnat_index
;
2830 /* First finish the type we had been making so that we output
2831 debugging information for it. */
2832 process_attributes (&gnu_type
, &attr_list
, false, gnat_entity
);
2833 if (Treat_As_Volatile (gnat_entity
))
2836 = TYPE_QUAL_VOLATILE
2837 | (Is_Atomic_Or_VFA (gnat_entity
) ? TYPE_QUAL_ATOMIC
: 0);
2838 gnu_type
= change_qualified_type (gnu_type
, quals
);
2840 /* Make it artificial only if the base type was artificial too.
2841 That's sort of "morally" true and will make it possible for
2842 the debugger to look it up by name in DWARF, which is needed
2843 in order to decode the packed array type. */
2845 = create_type_decl (gnu_entity_name
, gnu_type
,
2846 !Comes_From_Source (Etype (gnat_entity
))
2847 && artificial_p
, debug_info_p
,
2850 /* Save it as our equivalent in case the call below elaborates
2852 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2855 = gnat_to_gnu_entity (Packed_Array_Impl_Type (gnat_entity
),
2857 this_made_decl
= true;
2858 gnu_type
= TREE_TYPE (gnu_decl
);
2859 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
2860 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2863 gnu_inner
= gnu_type
;
2864 while (TREE_CODE (gnu_inner
) == RECORD_TYPE
2865 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner
)
2866 || TYPE_PADDING_P (gnu_inner
)))
2867 gnu_inner
= TREE_TYPE (TYPE_FIELDS (gnu_inner
));
2869 /* We need to attach the index type to the type we just made so
2870 that the actual bounds can later be put into a template. */
2871 if ((TREE_CODE (gnu_inner
) == ARRAY_TYPE
2872 && !TYPE_ACTUAL_BOUNDS (gnu_inner
))
2873 || (TREE_CODE (gnu_inner
) == INTEGER_TYPE
2874 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner
)))
2876 if (TREE_CODE (gnu_inner
) == INTEGER_TYPE
)
2878 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2879 TYPE_MODULUS for modular types so we make an extra
2880 subtype if necessary. */
2881 if (TYPE_MODULAR_P (gnu_inner
))
2884 = make_unsigned_type (TYPE_PRECISION (gnu_inner
));
2885 TREE_TYPE (gnu_subtype
) = gnu_inner
;
2886 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
2887 SET_TYPE_RM_MIN_VALUE (gnu_subtype
,
2888 TYPE_MIN_VALUE (gnu_inner
));
2889 SET_TYPE_RM_MAX_VALUE (gnu_subtype
,
2890 TYPE_MAX_VALUE (gnu_inner
));
2891 gnu_inner
= gnu_subtype
;
2894 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner
) = 1;
2896 /* Check for other cases of overloading. */
2897 gcc_checking_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner
));
2900 for (gnat_index
= First_Index (gnat_entity
);
2901 Present (gnat_index
);
2902 gnat_index
= Next_Index (gnat_index
))
2903 SET_TYPE_ACTUAL_BOUNDS
2905 tree_cons (NULL_TREE
,
2906 get_unpadded_type (Etype (gnat_index
)),
2907 TYPE_ACTUAL_BOUNDS (gnu_inner
)));
2909 if (Convention (gnat_entity
) != Convention_Fortran
)
2910 SET_TYPE_ACTUAL_BOUNDS
2911 (gnu_inner
, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner
)));
2913 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2914 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
2915 TREE_TYPE (TYPE_FIELDS (gnu_type
)) = gnu_inner
;
2921 case E_String_Literal_Subtype
:
2922 /* Create the type for a string literal. */
2924 Entity_Id gnat_full_type
2925 = (Is_Private_Type (Etype (gnat_entity
))
2926 && Present (Full_View (Etype (gnat_entity
)))
2927 ? Full_View (Etype (gnat_entity
)) : Etype (gnat_entity
));
2928 tree gnu_string_type
= get_unpadded_type (gnat_full_type
);
2929 tree gnu_string_array_type
2930 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type
))));
2931 tree gnu_string_index_type
2932 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2933 (TYPE_DOMAIN (gnu_string_array_type
))));
2934 tree gnu_lower_bound
2935 = convert (gnu_string_index_type
,
2936 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity
)));
2938 = UI_To_gnu (String_Literal_Length (gnat_entity
),
2939 gnu_string_index_type
);
2940 tree gnu_upper_bound
2941 = build_binary_op (PLUS_EXPR
, gnu_string_index_type
,
2943 int_const_binop (MINUS_EXPR
, gnu_length
,
2944 convert (gnu_string_index_type
,
2945 integer_one_node
)));
2947 = create_index_type (convert (sizetype
, gnu_lower_bound
),
2948 convert (sizetype
, gnu_upper_bound
),
2949 create_range_type (gnu_string_index_type
,
2955 = build_nonshared_array_type (gnat_to_gnu_type
2956 (Component_Type (gnat_entity
)),
2958 if (array_type_has_nonaliased_component (gnu_type
, gnat_entity
))
2959 set_nonaliased_component_on_array_type (gnu_type
);
2960 relate_alias_sets (gnu_type
, gnu_string_type
, ALIAS_SET_COPY
);
2964 /* Record Types and Subtypes
2966 The following fields are defined on record types:
2968 Has_Discriminants True if the record has discriminants
2969 First_Discriminant Points to head of list of discriminants
2970 First_Entity Points to head of list of fields
2971 Is_Tagged_Type True if the record is tagged
2973 Implementation of Ada records and discriminated records:
2975 A record type definition is transformed into the equivalent of a C
2976 struct definition. The fields that are the discriminants which are
2977 found in the Full_Type_Declaration node and the elements of the
2978 Component_List found in the Record_Type_Definition node. The
2979 Component_List can be a recursive structure since each Variant of
2980 the Variant_Part of the Component_List has a Component_List.
2982 Processing of a record type definition comprises starting the list of
2983 field declarations here from the discriminants and the calling the
2984 function components_to_record to add the rest of the fields from the
2985 component list and return the gnu type node. The function
2986 components_to_record will call itself recursively as it traverses
2990 if (Has_Complex_Representation (gnat_entity
))
2993 = build_complex_type
2995 (Etype (Defining_Entity
2996 (First (Component_Items
2999 (Declaration_Node (gnat_entity
)))))))));
3005 Node_Id full_definition
= Declaration_Node (gnat_entity
);
3006 Node_Id record_definition
= Type_Definition (full_definition
);
3007 Node_Id gnat_constr
;
3008 Entity_Id gnat_field
, gnat_parent_type
;
3009 tree gnu_field
, gnu_field_list
= NULL_TREE
;
3010 tree gnu_get_parent
;
3011 /* Set PACKED in keeping with gnat_to_gnu_field. */
3013 = Is_Packed (gnat_entity
)
3015 : Component_Alignment (gnat_entity
) == Calign_Storage_Unit
3018 const bool has_align
= Known_Alignment (gnat_entity
);
3019 const bool has_discr
= Has_Discriminants (gnat_entity
);
3020 const bool has_rep
= Has_Specified_Layout (gnat_entity
);
3021 const bool is_extension
3022 = (Is_Tagged_Type (gnat_entity
)
3023 && Nkind (record_definition
) == N_Derived_Type_Definition
);
3024 const bool is_unchecked_union
= Is_Unchecked_Union (gnat_entity
);
3025 bool all_rep
= has_rep
;
3027 /* See if all fields have a rep clause. Stop when we find one
3030 for (gnat_field
= First_Entity (gnat_entity
);
3031 Present (gnat_field
);
3032 gnat_field
= Next_Entity (gnat_field
))
3033 if ((Ekind (gnat_field
) == E_Component
3034 || Ekind (gnat_field
) == E_Discriminant
)
3035 && No (Component_Clause (gnat_field
)))
3041 /* If this is a record extension, go a level further to find the
3042 record definition. Also, verify we have a Parent_Subtype. */
3045 if (!type_annotate_only
3046 || Present (Record_Extension_Part (record_definition
)))
3047 record_definition
= Record_Extension_Part (record_definition
);
3049 gcc_assert (type_annotate_only
3050 || Present (Parent_Subtype (gnat_entity
)));
3053 /* Make a node for the record. If we are not defining the record,
3054 suppress expanding incomplete types. */
3055 gnu_type
= make_node (tree_code_for_record_type (gnat_entity
));
3056 TYPE_NAME (gnu_type
) = gnu_entity_name
;
3057 TYPE_PACKED (gnu_type
) = (packed
!= 0) || has_align
|| has_rep
;
3058 TYPE_REVERSE_STORAGE_ORDER (gnu_type
)
3059 = Reverse_Storage_Order (gnat_entity
);
3060 process_attributes (&gnu_type
, &attr_list
, true, gnat_entity
);
3064 defer_incomplete_level
++;
3065 this_deferred
= true;
3068 /* If both a size and rep clause were specified, put the size on
3069 the record type now so that it can get the proper layout. */
3070 if (has_rep
&& Known_RM_Size (gnat_entity
))
3071 TYPE_SIZE (gnu_type
)
3072 = UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
);
3074 /* Always set the alignment on the record type here so that it can
3075 get the proper layout. */
3077 SET_TYPE_ALIGN (gnu_type
,
3078 validate_alignment (Alignment (gnat_entity
),
3082 SET_TYPE_ALIGN (gnu_type
, 0);
3084 /* If a type needs strict alignment, the minimum size will be the
3085 type size instead of the RM size (see validate_size). Cap the
3086 alignment lest it causes this type size to become too large. */
3087 if (Strict_Alignment (gnat_entity
) && Known_RM_Size (gnat_entity
))
3089 unsigned int max_size
= UI_To_Int (RM_Size (gnat_entity
));
3090 unsigned int max_align
= max_size
& -max_size
;
3091 if (max_align
< BIGGEST_ALIGNMENT
)
3092 TYPE_MAX_ALIGN (gnu_type
) = max_align
;
3096 /* If we have a Parent_Subtype, make a field for the parent. If
3097 this record has rep clauses, force the position to zero. */
3098 if (Present (Parent_Subtype (gnat_entity
)))
3100 Entity_Id gnat_parent
= Parent_Subtype (gnat_entity
);
3101 tree gnu_dummy_parent_type
= make_node (RECORD_TYPE
);
3103 int parent_packed
= 0;
3105 /* A major complexity here is that the parent subtype will
3106 reference our discriminants in its Stored_Constraint list.
3107 But those must reference the parent component of this record
3108 which is precisely of the parent subtype we have not built yet!
3109 To break the circle we first build a dummy COMPONENT_REF which
3110 represents the "get to the parent" operation and initialize
3111 each of those discriminants to a COMPONENT_REF of the above
3112 dummy parent referencing the corresponding discriminant of the
3113 base type of the parent subtype. */
3114 gnu_get_parent
= build3 (COMPONENT_REF
, gnu_dummy_parent_type
,
3115 build0 (PLACEHOLDER_EXPR
, gnu_type
),
3116 build_decl (input_location
,
3117 FIELD_DECL
, NULL_TREE
,
3118 gnu_dummy_parent_type
),
3122 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3123 Present (gnat_field
);
3124 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3125 if (Present (Corresponding_Discriminant (gnat_field
)))
3128 = gnat_to_gnu_field_decl (Corresponding_Discriminant
3132 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3133 gnu_get_parent
, gnu_field
, NULL_TREE
),
3137 /* Then we build the parent subtype. If it has discriminants but
3138 the type itself has unknown discriminants, this means that it
3139 doesn't contain information about how the discriminants are
3140 derived from those of the ancestor type, so it cannot be used
3141 directly. Instead it is built by cloning the parent subtype
3142 of the underlying record view of the type, for which the above
3143 derivation of discriminants has been made explicit. */
3144 if (Has_Discriminants (gnat_parent
)
3145 && Has_Unknown_Discriminants (gnat_entity
))
3147 Entity_Id gnat_uview
= Underlying_Record_View (gnat_entity
);
3149 /* If we are defining the type, the underlying record
3150 view must already have been elaborated at this point.
3151 Otherwise do it now as its parent subtype cannot be
3152 technically elaborated on its own. */
3154 gcc_assert (present_gnu_tree (gnat_uview
));
3156 gnat_to_gnu_entity (gnat_uview
, NULL_TREE
, false);
3158 gnu_parent
= gnat_to_gnu_type (Parent_Subtype (gnat_uview
));
3160 /* Substitute the "get to the parent" of the type for that
3161 of its underlying record view in the cloned type. */
3162 for (gnat_field
= First_Stored_Discriminant (gnat_uview
);
3163 Present (gnat_field
);
3164 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3165 if (Present (Corresponding_Discriminant (gnat_field
)))
3167 tree gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
3169 = build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3170 gnu_get_parent
, gnu_field
, NULL_TREE
);
3172 = substitute_in_type (gnu_parent
, gnu_field
, gnu_ref
);
3176 gnu_parent
= gnat_to_gnu_type (gnat_parent
);
3178 /* The parent field needs strict alignment so, if it is to
3179 be created with a component clause below, then we need
3180 to apply the same adjustment as in gnat_to_gnu_field. */
3181 if (has_rep
&& TYPE_ALIGN (gnu_type
) < TYPE_ALIGN (gnu_parent
))
3183 /* ??? For historical reasons, we do it on strict-alignment
3184 platforms only, where it is really required. This means
3185 that a confirming representation clause will change the
3186 behavior of the compiler on the other platforms. */
3187 if (STRICT_ALIGNMENT
)
3188 SET_TYPE_ALIGN (gnu_type
, TYPE_ALIGN (gnu_parent
));
3191 = adjust_packed (gnu_parent
, gnu_type
, parent_packed
);
3194 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
3195 initially built. The discriminants must reference the fields
3196 of the parent subtype and not those of its base type for the
3197 placeholder machinery to properly work. */
3200 /* The actual parent subtype is the full view. */
3201 if (Is_Private_Type (gnat_parent
))
3203 if (Present (Full_View (gnat_parent
)))
3204 gnat_parent
= Full_View (gnat_parent
);
3206 gnat_parent
= Underlying_Full_View (gnat_parent
);
3209 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3210 Present (gnat_field
);
3211 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3212 if (Present (Corresponding_Discriminant (gnat_field
)))
3215 for (field
= First_Stored_Discriminant (gnat_parent
);
3217 field
= Next_Stored_Discriminant (field
))
3218 if (same_discriminant_p (gnat_field
, field
))
3220 gcc_assert (Present (field
));
3221 TREE_OPERAND (get_gnu_tree (gnat_field
), 1)
3222 = gnat_to_gnu_field_decl (field
);
3226 /* The "get to the parent" COMPONENT_REF must be given its
3228 TREE_TYPE (gnu_get_parent
) = gnu_parent
;
3230 /* ...and reference the _Parent field of this record. */
3232 = create_field_decl (parent_name_id
,
3233 gnu_parent
, gnu_type
,
3235 ? TYPE_SIZE (gnu_parent
) : NULL_TREE
,
3237 ? bitsize_zero_node
: NULL_TREE
,
3239 DECL_INTERNAL_P (gnu_field
) = 1;
3240 TREE_OPERAND (gnu_get_parent
, 1) = gnu_field
;
3241 TYPE_FIELDS (gnu_type
) = gnu_field
;
3244 /* Make the fields for the discriminants and put them into the record
3245 unless it's an Unchecked_Union. */
3247 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3248 Present (gnat_field
);
3249 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3251 /* If this is a record extension and this discriminant is the
3252 renaming of another discriminant, we've handled it above. */
3254 && Present (Corresponding_Discriminant (gnat_field
)))
3258 = gnat_to_gnu_field (gnat_field
, gnu_type
, packed
, definition
,
3261 /* Make an expression using a PLACEHOLDER_EXPR from the
3262 FIELD_DECL node just created and link that with the
3263 corresponding GNAT defining identifier. */
3264 save_gnu_tree (gnat_field
,
3265 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3266 build0 (PLACEHOLDER_EXPR
, gnu_type
),
3267 gnu_field
, NULL_TREE
),
3270 if (!is_unchecked_union
)
3272 DECL_CHAIN (gnu_field
) = gnu_field_list
;
3273 gnu_field_list
= gnu_field
;
3277 /* If we have a derived untagged type that renames discriminants in
3278 the parent type, the (stored) discriminants are just a copy of the
3279 discriminants of the parent type. This means that any constraints
3280 added by the renaming in the derivation are disregarded as far as
3281 the layout of the derived type is concerned. To rescue them, we
3282 change the type of the (stored) discriminants to a subtype with
3283 the bounds of the type of the visible discriminants. */
3286 && Stored_Constraint (gnat_entity
) != No_Elist
)
3287 for (gnat_constr
= First_Elmt (Stored_Constraint (gnat_entity
));
3288 gnat_constr
!= No_Elmt
;
3289 gnat_constr
= Next_Elmt (gnat_constr
))
3290 if (Nkind (Node (gnat_constr
)) == N_Identifier
3291 /* Ignore access discriminants. */
3292 && !Is_Access_Type (Etype (Node (gnat_constr
)))
3293 && Ekind (Entity (Node (gnat_constr
))) == E_Discriminant
)
3295 Entity_Id gnat_discr
= Entity (Node (gnat_constr
));
3296 tree gnu_discr_type
= gnat_to_gnu_type (Etype (gnat_discr
));
3298 = gnat_to_gnu_entity (Original_Record_Component (gnat_discr
),
3301 /* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
3302 just above for one of the stored discriminants. */
3303 gcc_assert (TREE_TYPE (TREE_OPERAND (gnu_ref
, 0)) == gnu_type
);
3305 if (gnu_discr_type
!= TREE_TYPE (gnu_ref
))
3307 const unsigned prec
= TYPE_PRECISION (TREE_TYPE (gnu_ref
));
3309 = TYPE_UNSIGNED (TREE_TYPE (gnu_ref
))
3310 ? make_unsigned_type (prec
) : make_signed_type (prec
);
3311 TREE_TYPE (gnu_subtype
) = TREE_TYPE (gnu_ref
);
3312 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
3313 SET_TYPE_RM_MIN_VALUE (gnu_subtype
,
3314 TYPE_MIN_VALUE (gnu_discr_type
));
3315 SET_TYPE_RM_MAX_VALUE (gnu_subtype
,
3316 TYPE_MAX_VALUE (gnu_discr_type
));
3318 = TREE_TYPE (TREE_OPERAND (gnu_ref
, 1)) = gnu_subtype
;
3322 /* If this is a derived type with discriminants and these discriminants
3323 affect the initial shape it has inherited, factor them in. But for
3324 an Unchecked_Union (it must be an Itype), just process the type. */
3327 && !Has_Record_Rep_Clause (gnat_entity
)
3328 && Stored_Constraint (gnat_entity
) != No_Elist
3329 && (gnat_parent_type
= Underlying_Type (Etype (gnat_entity
)))
3330 && Is_Record_Type (gnat_parent_type
)
3331 && !Is_Unchecked_Union (gnat_parent_type
))
3333 tree gnu_parent_type
3334 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_parent_type
));
3336 if (TYPE_IS_PADDING_P (gnu_parent_type
))
3337 gnu_parent_type
= TREE_TYPE (TYPE_FIELDS (gnu_parent_type
));
3339 vec
<subst_pair
> gnu_subst_list
3340 = build_subst_list (gnat_entity
, gnat_parent_type
, definition
);
3342 /* Set the layout of the type to match that of the parent type,
3343 doing required substitutions. */
3344 copy_and_substitute_in_layout (gnat_entity
, gnat_parent_type
,
3345 gnu_type
, gnu_parent_type
,
3346 gnu_subst_list
, debug_info_p
);
3350 /* Add the fields into the record type and finish it up. */
3351 components_to_record (Component_List (record_definition
),
3352 gnat_entity
, gnu_field_list
, gnu_type
,
3353 packed
, definition
, false, all_rep
,
3354 is_unchecked_union
, artificial_p
,
3355 debug_info_p
, false,
3356 all_rep
? NULL_TREE
: bitsize_zero_node
,
3359 /* If there are entities in the chain corresponding to components
3360 that we did not elaborate, ensure we elaborate their types if
3362 for (gnat_temp
= First_Entity (gnat_entity
);
3363 Present (gnat_temp
);
3364 gnat_temp
= Next_Entity (gnat_temp
))
3365 if ((Ekind (gnat_temp
) == E_Component
3366 || Ekind (gnat_temp
) == E_Discriminant
)
3367 && Is_Itype (Etype (gnat_temp
))
3368 && !present_gnu_tree (gnat_temp
))
3369 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, false);
3372 /* Fill in locations of fields. */
3373 annotate_rep (gnat_entity
, gnu_type
);
3375 /* If this is a record type associated with an exception definition,
3376 equate its fields to those of the standard exception type. This
3377 will make it possible to convert between them. */
3378 if (gnu_entity_name
== exception_data_name_id
)
3381 for (gnu_field
= TYPE_FIELDS (gnu_type
),
3382 gnu_std_field
= TYPE_FIELDS (except_type_node
);
3384 gnu_field
= DECL_CHAIN (gnu_field
),
3385 gnu_std_field
= DECL_CHAIN (gnu_std_field
))
3386 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field
, gnu_std_field
);
3387 gcc_assert (!gnu_std_field
);
3392 case E_Class_Wide_Subtype
:
3393 /* If an equivalent type is present, that is what we should use.
3394 Otherwise, fall through to handle this like a record subtype
3395 since it may have constraints. */
3396 if (gnat_equiv_type
!= gnat_entity
)
3398 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, false);
3399 maybe_present
= true;
3403 /* ... fall through ... */
3405 case E_Record_Subtype
:
3406 /* If Cloned_Subtype is Present it means this record subtype has
3407 identical layout to that type or subtype and we should use
3408 that GCC type for this one. The front end guarantees that
3409 the component list is shared. */
3410 if (Present (Cloned_Subtype (gnat_entity
)))
3412 gnu_decl
= gnat_to_gnu_entity (Cloned_Subtype (gnat_entity
),
3414 maybe_present
= true;
3418 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3419 changing the type, make a new type with each field having the type of
3420 the field in the new subtype but the position computed by transforming
3421 every discriminant reference according to the constraints. We don't
3422 see any difference between private and non-private type here since
3423 derivations from types should have been deferred until the completion
3424 of the private type. */
3427 Entity_Id gnat_base_type
= Implementation_Base_Type (gnat_entity
);
3431 defer_incomplete_level
++;
3432 this_deferred
= true;
3436 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_base_type
));
3438 if (present_gnu_tree (gnat_entity
))
3440 maybe_present
= true;
3444 /* If this is a record subtype associated with a dispatch table,
3445 strip the suffix. This is necessary to make sure 2 different
3446 subtypes associated with the imported and exported views of a
3447 dispatch table are properly merged in LTO mode. */
3448 if (Is_Dispatch_Table_Entity (gnat_entity
))
3451 Get_Encoded_Name (gnat_entity
);
3452 p
= strchr (Name_Buffer
, '_');
3454 strcpy (p
+2, "dtS");
3455 gnu_entity_name
= get_identifier (Name_Buffer
);
3458 /* When the subtype has discriminants and these discriminants affect
3459 the initial shape it has inherited, factor them in. But for an
3460 Unchecked_Union (it must be an Itype), just return the type. */
3461 if (Has_Discriminants (gnat_entity
)
3462 && Stored_Constraint (gnat_entity
) != No_Elist
3463 && !Is_For_Access_Subtype (gnat_entity
)
3464 && Is_Record_Type (gnat_base_type
)
3465 && !Is_Unchecked_Union (gnat_base_type
))
3467 vec
<subst_pair
> gnu_subst_list
3468 = build_subst_list (gnat_entity
, gnat_base_type
, definition
);
3469 tree gnu_unpad_base_type
;
3471 gnu_type
= make_node (RECORD_TYPE
);
3472 TYPE_NAME (gnu_type
) = gnu_entity_name
;
3473 if (gnat_encodings
== DWARF_GNAT_ENCODINGS_MINIMAL
)
3474 SET_TYPE_DEBUG_TYPE (gnu_type
, gnu_base_type
);
3475 TYPE_PACKED (gnu_type
) = TYPE_PACKED (gnu_base_type
);
3476 TYPE_REVERSE_STORAGE_ORDER (gnu_type
)
3477 = Reverse_Storage_Order (gnat_entity
);
3478 process_attributes (&gnu_type
, &attr_list
, true, gnat_entity
);
3480 /* Set the size, alignment and alias set of the type to match
3481 those of the base type, doing required substitutions. */
3482 copy_and_substitute_in_size (gnu_type
, gnu_base_type
,
3485 if (TYPE_IS_PADDING_P (gnu_base_type
))
3486 gnu_unpad_base_type
= TREE_TYPE (TYPE_FIELDS (gnu_base_type
));
3488 gnu_unpad_base_type
= gnu_base_type
;
3490 /* Set the layout of the type to match that of the base type,
3491 doing required substitutions. We will output debug info
3492 manually below so pass false as last argument. */
3493 copy_and_substitute_in_layout (gnat_entity
, gnat_base_type
,
3494 gnu_type
, gnu_unpad_base_type
,
3495 gnu_subst_list
, false);
3497 /* Fill in locations of fields. */
3498 annotate_rep (gnat_entity
, gnu_type
);
3500 /* If debugging information is being written for the type and if
3501 we are asked to output such encodings, write a record that
3502 shows what we are a subtype of and also make a variable that
3503 indicates our size, if still variable. */
3504 if (gnat_encodings
!= DWARF_GNAT_ENCODINGS_MINIMAL
)
3506 tree gnu_subtype_marker
= make_node (RECORD_TYPE
);
3507 tree gnu_unpad_base_name
3508 = TYPE_IDENTIFIER (gnu_unpad_base_type
);
3509 tree gnu_size_unit
= TYPE_SIZE_UNIT (gnu_type
);
3511 TYPE_NAME (gnu_subtype_marker
)
3512 = create_concat_name (gnat_entity
, "XVS");
3513 finish_record_type (gnu_subtype_marker
,
3514 create_field_decl (gnu_unpad_base_name
,
3515 build_reference_type
3516 (gnu_unpad_base_type
),
3518 NULL_TREE
, NULL_TREE
,
3522 add_parallel_type (gnu_type
, gnu_subtype_marker
);
3525 && TREE_CODE (gnu_size_unit
) != INTEGER_CST
3526 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit
))
3527 TYPE_SIZE_UNIT (gnu_subtype_marker
)
3528 = create_var_decl (create_concat_name (gnat_entity
,
3530 NULL_TREE
, sizetype
, gnu_size_unit
,
3531 false, false, false, false, false,
3537 /* Otherwise, go down all the components in the new type and make
3538 them equivalent to those in the base type. */
3541 gnu_type
= gnu_base_type
;
3543 for (gnat_temp
= First_Entity (gnat_entity
);
3544 Present (gnat_temp
);
3545 gnat_temp
= Next_Entity (gnat_temp
))
3546 if ((Ekind (gnat_temp
) == E_Discriminant
3547 && !Is_Unchecked_Union (gnat_base_type
))
3548 || Ekind (gnat_temp
) == E_Component
)
3549 save_gnu_tree (gnat_temp
,
3550 gnat_to_gnu_field_decl
3551 (Original_Record_Component (gnat_temp
)),
3557 case E_Access_Subprogram_Type
:
3558 case E_Anonymous_Access_Subprogram_Type
:
3559 /* Use the special descriptor type for dispatch tables if needed,
3560 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3561 Note that we are only required to do so for static tables in
3562 order to be compatible with the C++ ABI, but Ada 2005 allows
3563 to extend library level tagged types at the local level so
3564 we do it in the non-static case as well. */
3565 if (TARGET_VTABLE_USES_DESCRIPTORS
3566 && Is_Dispatch_Table_Entity (gnat_entity
))
3568 gnu_type
= fdesc_type_node
;
3569 gnu_size
= TYPE_SIZE (gnu_type
);
3573 /* ... fall through ... */
3575 case E_Allocator_Type
:
3577 case E_Access_Attribute_Type
:
3578 case E_Anonymous_Access_Type
:
3579 case E_General_Access_Type
:
3581 /* The designated type and its equivalent type for gigi. */
3582 Entity_Id gnat_desig_type
= Directly_Designated_Type (gnat_entity
);
3583 Entity_Id gnat_desig_equiv
= Gigi_Equivalent_Type (gnat_desig_type
);
3584 /* Whether it comes from a limited with. */
3585 const bool is_from_limited_with
3586 = (Is_Incomplete_Type (gnat_desig_equiv
)
3587 && From_Limited_With (gnat_desig_equiv
));
3588 /* Whether it is a completed Taft Amendment type. Such a type is to
3589 be treated as coming from a limited with clause if it is not in
3590 the main unit, i.e. we break potential circularities here in case
3591 the body of an external unit is loaded for inter-unit inlining. */
3592 const bool is_completed_taft_type
3593 = (Is_Incomplete_Type (gnat_desig_equiv
)
3594 && Has_Completion_In_Body (gnat_desig_equiv
)
3595 && Present (Full_View (gnat_desig_equiv
)));
3596 /* The "full view" of the designated type. If this is an incomplete
3597 entity from a limited with, treat its non-limited view as the full
3598 view. Otherwise, if this is an incomplete or private type, use the
3599 full view. In the former case, we might point to a private type,
3600 in which case, we need its full view. Also, we want to look at the
3601 actual type used for the representation, so this takes a total of
3603 Entity_Id gnat_desig_full_direct_first
3604 = (is_from_limited_with
3605 ? Non_Limited_View (gnat_desig_equiv
)
3606 : (Is_Incomplete_Or_Private_Type (gnat_desig_equiv
)
3607 ? Full_View (gnat_desig_equiv
) : Empty
));
3608 Entity_Id gnat_desig_full_direct
3609 = ((is_from_limited_with
3610 && Present (gnat_desig_full_direct_first
)
3611 && Is_Private_Type (gnat_desig_full_direct_first
))
3612 ? Full_View (gnat_desig_full_direct_first
)
3613 : gnat_desig_full_direct_first
);
3614 Entity_Id gnat_desig_full
3615 = Gigi_Equivalent_Type (gnat_desig_full_direct
);
3616 /* The type actually used to represent the designated type, either
3617 gnat_desig_full or gnat_desig_equiv. */
3618 Entity_Id gnat_desig_rep
;
3619 /* We want to know if we'll be seeing the freeze node for any
3620 incomplete type we may be pointing to. */
3621 const bool in_main_unit
3622 = (Present (gnat_desig_full
)
3623 ? In_Extended_Main_Code_Unit (gnat_desig_full
)
3624 : In_Extended_Main_Code_Unit (gnat_desig_type
));
3625 /* True if we make a dummy type here. */
3626 bool made_dummy
= false;
3627 /* The mode to be used for the pointer type. */
3628 scalar_int_mode p_mode
;
3629 /* The GCC type used for the designated type. */
3630 tree gnu_desig_type
= NULL_TREE
;
3632 if (!int_mode_for_size (esize
, 0).exists (&p_mode
)
3633 || !targetm
.valid_pointer_mode (p_mode
))
3636 /* If either the designated type or its full view is an unconstrained
3637 array subtype, replace it with the type it's a subtype of. This
3638 avoids problems with multiple copies of unconstrained array types.
3639 Likewise, if the designated type is a subtype of an incomplete
3640 record type, use the parent type to avoid order of elaboration
3641 issues. This can lose some code efficiency, but there is no
3643 if (Ekind (gnat_desig_equiv
) == E_Array_Subtype
3644 && !Is_Constrained (gnat_desig_equiv
))
3645 gnat_desig_equiv
= Etype (gnat_desig_equiv
);
3646 if (Present (gnat_desig_full
)
3647 && ((Ekind (gnat_desig_full
) == E_Array_Subtype
3648 && !Is_Constrained (gnat_desig_full
))
3649 || (Ekind (gnat_desig_full
) == E_Record_Subtype
3650 && Ekind (Etype (gnat_desig_full
)) == E_Record_Type
)))
3651 gnat_desig_full
= Etype (gnat_desig_full
);
3653 /* Set the type that's the representation of the designated type. */
3655 = Present (gnat_desig_full
) ? gnat_desig_full
: gnat_desig_equiv
;
3657 /* If we already know what the full type is, use it. */
3658 if (Present (gnat_desig_full
) && present_gnu_tree (gnat_desig_full
))
3659 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_full
));
3661 /* Get the type of the thing we are to point to and build a pointer to
3662 it. If it is a reference to an incomplete or private type with a
3663 full view that is a record, an array or an access, make a dummy type
3664 and get the actual type later when we have verified it is safe. */
3665 else if ((!in_main_unit
3666 && !present_gnu_tree (gnat_desig_equiv
)
3667 && Present (gnat_desig_full
)
3668 && (Is_Record_Type (gnat_desig_full
)
3669 || Is_Array_Type (gnat_desig_full
)
3670 || Is_Access_Type (gnat_desig_full
)))
3671 /* Likewise if this is a reference to a record, an array or a
3672 subprogram type and we are to defer elaborating incomplete
3673 types. We do this because this access type may be the full
3674 view of a private type. */
3675 || ((!in_main_unit
|| imported_p
)
3676 && defer_incomplete_level
!= 0
3677 && !present_gnu_tree (gnat_desig_equiv
)
3678 && (Is_Record_Type (gnat_desig_rep
)
3679 || Is_Array_Type (gnat_desig_rep
)
3680 || Ekind (gnat_desig_rep
) == E_Subprogram_Type
))
3681 /* If this is a reference from a limited_with type back to our
3682 main unit and there's a freeze node for it, either we have
3683 already processed the declaration and made the dummy type,
3684 in which case we just reuse the latter, or we have not yet,
3685 in which case we make the dummy type and it will be reused
3686 when the declaration is finally processed. In both cases,
3687 the pointer eventually created below will be automatically
3688 adjusted when the freeze node is processed. */
3690 && is_from_limited_with
3691 && Present (Freeze_Node (gnat_desig_rep
))))
3693 gnu_desig_type
= make_dummy_type (gnat_desig_equiv
);
3697 /* Otherwise handle the case of a pointer to itself. */
3698 else if (gnat_desig_equiv
== gnat_entity
)
3701 = build_pointer_type_for_mode (void_type_node
, p_mode
,
3702 No_Strict_Aliasing (gnat_entity
));
3703 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
) = gnu_type
;
3706 /* If expansion is disabled, the equivalent type of a concurrent type
3707 is absent, so we use the void pointer type. */
3708 else if (type_annotate_only
&& No (gnat_desig_equiv
))
3709 gnu_type
= ptr_type_node
;
3711 /* If the ultimately designated type is an incomplete type with no full
3712 view, we use the void pointer type in LTO mode to avoid emitting a
3713 dummy type in the GIMPLE IR. We cannot do that in regular mode as
3714 the name of the dummy type in used by GDB for a global lookup. */
3715 else if (Ekind (gnat_desig_rep
) == E_Incomplete_Type
3716 && No (Full_View (gnat_desig_rep
))
3717 && flag_generate_lto
)
3718 gnu_type
= ptr_type_node
;
3720 /* Finally, handle the default case where we can just elaborate our
3723 gnu_desig_type
= gnat_to_gnu_type (gnat_desig_equiv
);
3725 /* It is possible that a call to gnat_to_gnu_type above resolved our
3726 type. If so, just return it. */
3727 if (present_gnu_tree (gnat_entity
))
3729 maybe_present
= true;
3733 /* Access-to-unconstrained-array types need a special treatment. */
3734 if (Is_Array_Type (gnat_desig_rep
) && !Is_Constrained (gnat_desig_rep
))
3736 /* If the processing above got something that has a pointer, then
3737 we are done. This could have happened either because the type
3738 was elaborated or because somebody else executed the code. */
3739 if (!TYPE_POINTER_TO (gnu_desig_type
))
3740 build_dummy_unc_pointer_types (gnat_desig_equiv
, gnu_desig_type
);
3742 gnu_type
= TYPE_POINTER_TO (gnu_desig_type
);
3745 /* If we haven't done it yet, build the pointer type the usual way. */
3748 /* Modify the designated type if we are pointing only to constant
3749 objects, but don't do it for a dummy type. */
3750 if (Is_Access_Constant (gnat_entity
)
3751 && !TYPE_IS_DUMMY_P (gnu_desig_type
))
3753 = change_qualified_type (gnu_desig_type
, TYPE_QUAL_CONST
);
3756 = build_pointer_type_for_mode (gnu_desig_type
, p_mode
,
3757 No_Strict_Aliasing (gnat_entity
));
3760 /* If the designated type is not declared in the main unit and we made
3761 a dummy node for it, save our definition, elaborate the actual type
3762 and replace the dummy type we made with the actual one. But if we
3763 are to defer actually looking up the actual type, make an entry in
3764 the deferred list instead. If this is from a limited with, we may
3765 have to defer until the end of the current unit. */
3766 if (!in_main_unit
&& made_dummy
)
3768 if (TYPE_IS_FAT_POINTER_P (gnu_type
) && esize
== POINTER_SIZE
)
3770 = build_pointer_type (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type
));
3772 process_attributes (&gnu_type
, &attr_list
, false, gnat_entity
);
3773 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
,
3774 artificial_p
, debug_info_p
,
3776 this_made_decl
= true;
3777 gnu_type
= TREE_TYPE (gnu_decl
);
3778 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3781 if (defer_incomplete_level
== 0
3782 && !is_from_limited_with
3783 && !is_completed_taft_type
)
3785 update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type
),
3786 gnat_to_gnu_type (gnat_desig_equiv
));
3790 struct incomplete
*p
= XNEW (struct incomplete
);
3791 struct incomplete
**head
3792 = (is_from_limited_with
|| is_completed_taft_type
3793 ? &defer_limited_with_list
: &defer_incomplete_list
);
3795 p
->old_type
= gnu_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 we are just annotating types and have no equivalent record type,
3807 just use the void pointer type. */
3808 if (type_annotate_only
&& gnat_equiv_type
== gnat_entity
)
3809 gnu_type
= ptr_type_node
;
3811 /* The run-time representation is the equivalent type. */
3814 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
3815 maybe_present
= true;
3818 /* The designated subtype must be elaborated as well, if it does
3819 not have its own freeze node. */
3820 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3821 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3822 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
)))
3823 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity
))))
3824 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3829 case E_Access_Subtype
:
3830 /* We treat this as identical to its base type; any constraint is
3831 meaningful only to the front-end. */
3832 gnu_decl
= gnat_to_gnu_entity (Etype (gnat_entity
), NULL_TREE
, false);
3835 /* The designated subtype must be elaborated as well, if it does
3836 not have its own freeze node. But designated subtypes created
3837 for constrained components of records with discriminants are
3838 not frozen by the front-end and not elaborated here, because
3839 their use may appear before the base type is frozen and it is
3840 not clear that they are needed in gigi. With the current model,
3841 there is no correct place where they could be elaborated. */
3842 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3843 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3844 && Is_Frozen (Directly_Designated_Type (gnat_entity
))
3845 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
))))
3847 /* If we are to defer elaborating incomplete types, make a dummy
3848 type node and elaborate it later. */
3849 if (defer_incomplete_level
!= 0)
3851 struct incomplete
*p
= XNEW (struct incomplete
);
3854 = make_dummy_type (Directly_Designated_Type (gnat_entity
));
3855 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3856 p
->next
= defer_incomplete_list
;
3857 defer_incomplete_list
= p
;
3859 else if (!Is_Incomplete_Or_Private_Type
3860 (Base_Type (Directly_Designated_Type (gnat_entity
))))
3861 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3866 /* Subprogram Entities
3868 The following access functions are defined for subprograms:
3870 Etype Return type or Standard_Void_Type.
3871 First_Formal The first formal parameter.
3872 Is_Imported Indicates that the subprogram has appeared in
3873 an INTERFACE or IMPORT pragma. For now we
3874 assume that the external language is C.
3875 Is_Exported Likewise but for an EXPORT pragma.
3876 Is_Inlined True if the subprogram is to be inlined.
3878 Each parameter is first checked by calling must_pass_by_ref on its
3879 type to determine if it is passed by reference. For parameters which
3880 are copied in, if they are Ada In Out or Out parameters, their return
3881 value becomes part of a record which becomes the return type of the
3882 function (C function - note that this applies only to Ada procedures
3883 so there is no Ada return type). Additional code to store back the
3884 parameters will be generated on the caller side. This transformation
3885 is done here, not in the front-end.
3887 The intended result of the transformation can be seen from the
3888 equivalent source rewritings that follow:
3890 struct temp {int a,b};
3891 procedure P (A,B: In Out ...) is temp P (int A,B)
3894 end P; return {A,B};
3901 For subprogram types we need to perform mainly the same conversions to
3902 GCC form that are needed for procedures and function declarations. The
3903 only difference is that at the end, we make a type declaration instead
3904 of a function declaration. */
3906 case E_Subprogram_Type
:
3911 = gnu_ext_name_for_subprog (gnat_entity
, gnu_entity_name
);
3912 enum inline_status_t inline_status
3913 = Has_Pragma_No_Inline (gnat_entity
)
3915 : Has_Pragma_Inline_Always (gnat_entity
)
3917 : (Is_Inlined (gnat_entity
) ? is_enabled
: is_disabled
);
3918 bool public_flag
= Is_Public (gnat_entity
) || imported_p
;
3919 /* Subprograms marked both Intrinsic and Always_Inline need not
3920 have a body of their own. */
3922 = ((Is_Public (gnat_entity
) && !definition
)
3924 || (Convention (gnat_entity
) == Convention_Intrinsic
3925 && Has_Pragma_Inline_Always (gnat_entity
)));
3926 tree gnu_param_list
;
3928 /* A parameter may refer to this type, so defer completion of any
3929 incomplete types. */
3930 if (kind
== E_Subprogram_Type
&& !definition
)
3932 defer_incomplete_level
++;
3933 this_deferred
= true;
3936 /* If the subprogram has an alias, it is probably inherited, so
3937 we can use the original one. If the original "subprogram"
3938 is actually an enumeration literal, it may be the first use
3939 of its type, so we must elaborate that type now. */
3940 if (Present (Alias (gnat_entity
)))
3942 const Entity_Id gnat_renamed
= Renamed_Object (gnat_entity
);
3944 if (Ekind (Alias (gnat_entity
)) == E_Enumeration_Literal
)
3945 gnat_to_gnu_entity (Etype (Alias (gnat_entity
)), NULL_TREE
,
3949 = gnat_to_gnu_entity (Alias (gnat_entity
), gnu_expr
, false);
3951 /* Elaborate any Itypes in the parameters of this entity. */
3952 for (gnat_temp
= First_Formal_With_Extras (gnat_entity
);
3953 Present (gnat_temp
);
3954 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
3955 if (Is_Itype (Etype (gnat_temp
)))
3956 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, false);
3958 /* Materialize renamed subprograms in the debugging information
3959 when the renamed object is compile time known. We can consider
3960 such renamings as imported declarations.
3962 Because the parameters in generics instantiation are generally
3963 materialized as renamings, we ofter end up having both the
3964 renamed subprogram and the renaming in the same context and with
3965 the same name: in this case, renaming is both useless debug-wise
3966 and potentially harmful as name resolution in the debugger could
3967 return twice the same entity! So avoid this case. */
3968 if (debug_info_p
&& !artificial_p
3969 && !(get_debug_scope (gnat_entity
, NULL
)
3970 == get_debug_scope (gnat_renamed
, NULL
)
3971 && Name_Equals (Chars (gnat_entity
),
3972 Chars (gnat_renamed
)))
3973 && Present (gnat_renamed
)
3974 && (Ekind (gnat_renamed
) == E_Function
3975 || Ekind (gnat_renamed
) == E_Procedure
)
3977 && TREE_CODE (gnu_decl
) == FUNCTION_DECL
)
3979 tree decl
= build_decl (input_location
, IMPORTED_DECL
,
3980 gnu_entity_name
, void_type_node
);
3981 IMPORTED_DECL_ASSOCIATED_DECL (decl
) = gnu_decl
;
3982 gnat_pushdecl (decl
, gnat_entity
);
3988 /* Get the GCC tree for the (underlying) subprogram type. If the
3989 entity is an actual subprogram, also get the parameter list. */
3991 = gnat_to_gnu_subprog_type (gnat_entity
, definition
, debug_info_p
,
3993 if (DECL_P (gnu_type
))
3995 gnu_decl
= gnu_type
;
3996 gnu_type
= TREE_TYPE (gnu_decl
);
4000 /* Deal with platform-specific calling conventions. */
4001 if (Has_Stdcall_Convention (gnat_entity
))
4002 prepend_one_attribute
4003 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4004 get_identifier ("stdcall"), NULL_TREE
,
4006 else if (Has_Thiscall_Convention (gnat_entity
))
4007 prepend_one_attribute
4008 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4009 get_identifier ("thiscall"), NULL_TREE
,
4012 /* If we should request stack realignment for a foreign convention
4013 subprogram, do so. Note that this applies to task entry points
4015 if (FOREIGN_FORCE_REALIGN_STACK
4016 && Has_Foreign_Convention (gnat_entity
))
4017 prepend_one_attribute
4018 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4019 get_identifier ("force_align_arg_pointer"), NULL_TREE
,
4022 /* Deal with a pragma Linker_Section on a subprogram. */
4023 if ((kind
== E_Function
|| kind
== E_Procedure
)
4024 && Present (Linker_Section_Pragma (gnat_entity
)))
4025 prepend_one_attribute_pragma (&attr_list
,
4026 Linker_Section_Pragma (gnat_entity
));
4028 /* If we are defining the subprogram and it has an Address clause
4029 we must get the address expression from the saved GCC tree for the
4030 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4031 the address expression here since the front-end has guaranteed
4032 in that case that the elaboration has no effects. If there is
4033 an Address clause and we are not defining the object, just
4034 make it a constant. */
4035 if (Present (Address_Clause (gnat_entity
)))
4037 tree gnu_address
= NULL_TREE
;
4041 = (present_gnu_tree (gnat_entity
)
4042 ? get_gnu_tree (gnat_entity
)
4043 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
4045 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
4047 /* Convert the type of the object to a reference type that can
4048 alias everything as per RM 13.3(19). */
4050 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
4052 gnu_address
= convert (gnu_type
, gnu_address
);
4055 = create_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
4056 gnu_address
, false, Is_Public (gnat_entity
),
4057 extern_flag
, false, false, artificial_p
,
4058 debug_info_p
, NULL
, gnat_entity
);
4059 DECL_BY_REF_P (gnu_decl
) = 1;
4062 /* If this is a mere subprogram type, just create the declaration. */
4063 else if (kind
== E_Subprogram_Type
)
4065 process_attributes (&gnu_type
, &attr_list
, false, gnat_entity
);
4068 = create_type_decl (gnu_entity_name
, gnu_type
, artificial_p
,
4069 debug_info_p
, gnat_entity
);
4072 /* Otherwise create the subprogram declaration with the external name,
4073 the type and the parameter list. However, if this a reference to
4074 the allocation routines, reuse the canonical declaration nodes as
4075 they come with special properties. */
4078 if (extern_flag
&& gnu_ext_name
== DECL_NAME (malloc_decl
))
4079 gnu_decl
= malloc_decl
;
4080 else if (extern_flag
&& gnu_ext_name
== DECL_NAME (realloc_decl
))
4081 gnu_decl
= realloc_decl
;
4085 = create_subprog_decl (gnu_entity_name
, gnu_ext_name
,
4086 gnu_type
, gnu_param_list
,
4087 inline_status
, public_flag
,
4088 extern_flag
, artificial_p
,
4090 definition
&& imported_p
, attr_list
,
4093 DECL_STUBBED_P (gnu_decl
)
4094 = (Convention (gnat_entity
) == Convention_Stubbed
);
4100 case E_Incomplete_Type
:
4101 case E_Incomplete_Subtype
:
4102 case E_Private_Type
:
4103 case E_Private_Subtype
:
4104 case E_Limited_Private_Type
:
4105 case E_Limited_Private_Subtype
:
4106 case E_Record_Type_With_Private
:
4107 case E_Record_Subtype_With_Private
:
4109 const bool is_from_limited_with
4110 = (IN (kind
, Incomplete_Kind
) && From_Limited_With (gnat_entity
));
4111 /* Get the "full view" of this entity. If this is an incomplete
4112 entity from a limited with, treat its non-limited view as the
4113 full view. Otherwise, use either the full view or the underlying
4114 full view, whichever is present. This is used in all the tests
4116 const Entity_Id full_view
4117 = is_from_limited_with
4118 ? Non_Limited_View (gnat_entity
)
4119 : Present (Full_View (gnat_entity
))
4120 ? Full_View (gnat_entity
)
4121 : IN (kind
, Private_Kind
)
4122 ? Underlying_Full_View (gnat_entity
)
4125 /* If this is an incomplete type with no full view, it must be a Taft
4126 Amendment type or an incomplete type coming from a limited context,
4127 in which cases we return a dummy type. Otherwise, we just get the
4128 type from its Etype. */
4131 if (kind
== E_Incomplete_Type
)
4133 gnu_type
= make_dummy_type (gnat_entity
);
4134 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4139 = gnat_to_gnu_entity (Etype (gnat_entity
), NULL_TREE
, false);
4140 maybe_present
= true;
4144 /* Or else, if we already made a type for the full view, reuse it. */
4145 else if (present_gnu_tree (full_view
))
4146 gnu_decl
= get_gnu_tree (full_view
);
4148 /* Or else, if we are not defining the type or there is no freeze
4149 node on it, get the type for the full view. Likewise if this is
4150 a limited_with'ed type not declared in the main unit, which can
4151 happen for incomplete formal types instantiated on a type coming
4152 from a limited_with clause. */
4153 else if (!definition
4154 || No (Freeze_Node (full_view
))
4155 || (is_from_limited_with
4156 && !In_Extended_Main_Code_Unit (full_view
)))
4158 gnu_decl
= gnat_to_gnu_entity (full_view
, NULL_TREE
, false);
4159 maybe_present
= true;
4162 /* Otherwise, make a dummy type entry which will be replaced later.
4163 Save it as the full declaration's type so we can do any needed
4164 updates when we see it. */
4167 gnu_type
= make_dummy_type (gnat_entity
);
4168 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4169 if (Has_Completion_In_Body (gnat_entity
))
4170 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
4171 save_gnu_tree (full_view
, gnu_decl
, false);
4176 case E_Class_Wide_Type
:
4177 /* Class-wide types are always transformed into their root type. */
4178 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, false);
4179 maybe_present
= true;
4182 case E_Protected_Type
:
4183 case E_Protected_Subtype
:
4185 case E_Task_Subtype
:
4186 /* If we are just annotating types and have no equivalent record type,
4187 just return void_type, except for root types that have discriminants
4188 because the discriminants will very likely be used in the declarative
4189 part of the associated body so they need to be translated. */
4190 if (type_annotate_only
&& gnat_equiv_type
== gnat_entity
)
4192 if (Has_Discriminants (gnat_entity
)
4193 && Root_Type (gnat_entity
) == gnat_entity
)
4195 tree gnu_field_list
= NULL_TREE
;
4196 Entity_Id gnat_field
;
4198 /* This is a minimal version of the E_Record_Type handling. */
4199 gnu_type
= make_node (RECORD_TYPE
);
4200 TYPE_NAME (gnu_type
) = gnu_entity_name
;
4202 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
4203 Present (gnat_field
);
4204 gnat_field
= Next_Stored_Discriminant (gnat_field
))
4207 = gnat_to_gnu_field (gnat_field
, gnu_type
, false,
4208 definition
, debug_info_p
);
4210 save_gnu_tree (gnat_field
,
4211 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
4212 build0 (PLACEHOLDER_EXPR
, gnu_type
),
4213 gnu_field
, NULL_TREE
),
4216 DECL_CHAIN (gnu_field
) = gnu_field_list
;
4217 gnu_field_list
= gnu_field
;
4220 finish_record_type (gnu_type
, nreverse (gnu_field_list
), 0,
4224 gnu_type
= void_type_node
;
4227 /* Concurrent types are always transformed into their record type. */
4229 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, false);
4230 maybe_present
= true;
4234 gnu_decl
= create_label_decl (gnu_entity_name
, gnat_entity
);
4239 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4240 we've already saved it, so we don't try to. */
4241 gnu_decl
= error_mark_node
;
4245 case E_Abstract_State
:
4246 /* This is a SPARK annotation that only reaches here when compiling in
4248 gcc_assert (type_annotate_only
);
4249 gnu_decl
= error_mark_node
;
4257 /* If we had a case where we evaluated another type and it might have
4258 defined this one, handle it here. */
4259 if (maybe_present
&& present_gnu_tree (gnat_entity
))
4261 gnu_decl
= get_gnu_tree (gnat_entity
);
4265 /* If we are processing a type and there is either no decl for it or
4266 we just made one, do some common processing for the type, such as
4267 handling alignment and possible padding. */
4268 if (is_type
&& (!gnu_decl
|| this_made_decl
))
4270 gcc_assert (!TYPE_IS_DUMMY_P (gnu_type
));
4272 /* Process the attributes, if not already done. Note that the type is
4273 already defined so we cannot pass true for IN_PLACE here. */
4274 process_attributes (&gnu_type
, &attr_list
, false, gnat_entity
);
4276 /* Tell the middle-end that objects of tagged types are guaranteed to
4277 be properly aligned. This is necessary because conversions to the
4278 class-wide type are translated into conversions to the root type,
4279 which can be less aligned than some of its derived types. */
4280 if (Is_Tagged_Type (gnat_entity
)
4281 || Is_Class_Wide_Equivalent_Type (gnat_entity
))
4282 TYPE_ALIGN_OK (gnu_type
) = 1;
4284 /* Record whether the type is passed by reference. */
4285 if (!VOID_TYPE_P (gnu_type
) && Is_By_Reference_Type (gnat_entity
))
4286 TYPE_BY_REFERENCE_P (gnu_type
) = 1;
4288 /* ??? Don't set the size for a String_Literal since it is either
4289 confirming or we don't handle it properly (if the low bound is
4291 if (!gnu_size
&& kind
!= E_String_Literal_Subtype
)
4293 Uint gnat_size
= Known_Esize (gnat_entity
)
4294 ? Esize (gnat_entity
) : RM_Size (gnat_entity
);
4296 = validate_size (gnat_size
, gnu_type
, gnat_entity
, TYPE_DECL
,
4297 false, Has_Size_Clause (gnat_entity
));
4300 /* If a size was specified, see if we can make a new type of that size
4301 by rearranging the type, for example from a fat to a thin pointer. */
4305 = make_type_from_size (gnu_type
, gnu_size
,
4306 Has_Biased_Representation (gnat_entity
));
4308 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0)
4309 && operand_equal_p (rm_size (gnu_type
), gnu_size
, 0))
4310 gnu_size
= NULL_TREE
;
4313 /* If the alignment has not already been processed and this is not
4314 an unconstrained array type, see if an alignment is specified.
4315 If not, we pick a default alignment for atomic objects. */
4316 if (align
!= 0 || TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4318 else if (Known_Alignment (gnat_entity
))
4320 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
4321 TYPE_ALIGN (gnu_type
));
4323 /* Warn on suspiciously large alignments. This should catch
4324 errors about the (alignment,byte)/(size,bit) discrepancy. */
4325 if (align
> BIGGEST_ALIGNMENT
&& Has_Alignment_Clause (gnat_entity
))
4329 /* If a size was specified, take it into account. Otherwise
4330 use the RM size for records or unions as the type size has
4331 already been adjusted to the alignment. */
4334 else if (RECORD_OR_UNION_TYPE_P (gnu_type
)
4335 && !TYPE_FAT_POINTER_P (gnu_type
))
4336 size
= rm_size (gnu_type
);
4338 size
= TYPE_SIZE (gnu_type
);
4340 /* Consider an alignment as suspicious if the alignment/size
4341 ratio is greater or equal to the byte/bit ratio. */
4342 if (tree_fits_uhwi_p (size
)
4343 && align
>= tree_to_uhwi (size
) * BITS_PER_UNIT
)
4344 post_error_ne ("?suspiciously large alignment specified for&",
4345 Expression (Alignment_Clause (gnat_entity
)),
4349 else if (Is_Atomic_Or_VFA (gnat_entity
) && !gnu_size
4350 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type
))
4351 && integer_pow2p (TYPE_SIZE (gnu_type
)))
4352 align
= MIN (BIGGEST_ALIGNMENT
,
4353 tree_to_uhwi (TYPE_SIZE (gnu_type
)));
4354 else if (Is_Atomic_Or_VFA (gnat_entity
) && gnu_size
4355 && tree_fits_uhwi_p (gnu_size
)
4356 && integer_pow2p (gnu_size
))
4357 align
= MIN (BIGGEST_ALIGNMENT
, tree_to_uhwi (gnu_size
));
4359 /* See if we need to pad the type. If we did, and made a record,
4360 the name of the new type may be changed. So get it back for
4361 us when we make the new TYPE_DECL below. */
4362 if (gnu_size
|| align
> 0)
4363 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
4364 false, !gnu_decl
, definition
, false);
4366 if (TYPE_IS_PADDING_P (gnu_type
))
4367 gnu_entity_name
= TYPE_IDENTIFIER (gnu_type
);
4369 /* Now set the RM size of the type. We cannot do it before padding
4370 because we need to accept arbitrary RM sizes on integral types. */
4371 set_rm_size (RM_Size (gnat_entity
), gnu_type
, gnat_entity
);
4373 /* If we are at global level, GCC will have applied variable_size to
4374 the type, but that won't have done anything. So, if it's not
4375 a constant or self-referential, call elaborate_expression_1 to
4376 make a variable for the size rather than calculating it each time.
4377 Handle both the RM size and the actual size. */
4378 if (TYPE_SIZE (gnu_type
)
4379 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
))
4380 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
4381 && global_bindings_p ())
4383 tree size
= TYPE_SIZE (gnu_type
);
4385 TYPE_SIZE (gnu_type
)
4386 = elaborate_expression_1 (size
, gnat_entity
, "SIZE", definition
,
4389 /* ??? For now, store the size as a multiple of the alignment in
4390 bytes so that we can see the alignment from the tree. */
4391 TYPE_SIZE_UNIT (gnu_type
)
4392 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type
), gnat_entity
,
4393 "SIZE_A_UNIT", definition
, false,
4394 TYPE_ALIGN (gnu_type
));
4396 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4397 may not be marked by the call to create_type_decl below. */
4398 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type
));
4400 if (TREE_CODE (gnu_type
) == RECORD_TYPE
)
4402 tree variant_part
= get_variant_part (gnu_type
);
4403 tree ada_size
= TYPE_ADA_SIZE (gnu_type
);
4407 tree union_type
= TREE_TYPE (variant_part
);
4408 tree offset
= DECL_FIELD_OFFSET (variant_part
);
4410 /* If the position of the variant part is constant, subtract
4411 it from the size of the type of the parent to get the new
4412 size. This manual CSE reduces the data size. */
4413 if (TREE_CODE (offset
) == INTEGER_CST
)
4415 tree bitpos
= DECL_FIELD_BIT_OFFSET (variant_part
);
4416 TYPE_SIZE (union_type
)
4417 = size_binop (MINUS_EXPR
, TYPE_SIZE (gnu_type
),
4418 bit_from_pos (offset
, bitpos
));
4419 TYPE_SIZE_UNIT (union_type
)
4420 = size_binop (MINUS_EXPR
, TYPE_SIZE_UNIT (gnu_type
),
4421 byte_from_pos (offset
, bitpos
));
4425 TYPE_SIZE (union_type
)
4426 = elaborate_expression_1 (TYPE_SIZE (union_type
),
4427 gnat_entity
, "VSIZE",
4430 /* ??? For now, store the size as a multiple of the
4431 alignment in bytes so that we can see the alignment
4433 TYPE_SIZE_UNIT (union_type
)
4434 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type
),
4435 gnat_entity
, "VSIZE_A_UNIT",
4437 TYPE_ALIGN (union_type
));
4439 /* ??? For now, store the offset as a multiple of the
4440 alignment in bytes so that we can see the alignment
4442 DECL_FIELD_OFFSET (variant_part
)
4443 = elaborate_expression_2 (offset
, gnat_entity
,
4444 "VOFFSET", definition
, false,
4449 DECL_SIZE (variant_part
) = TYPE_SIZE (union_type
);
4450 DECL_SIZE_UNIT (variant_part
) = TYPE_SIZE_UNIT (union_type
);
4453 if (operand_equal_p (ada_size
, size
, 0))
4454 ada_size
= TYPE_SIZE (gnu_type
);
4457 = elaborate_expression_1 (ada_size
, gnat_entity
, "RM_SIZE",
4459 SET_TYPE_ADA_SIZE (gnu_type
, ada_size
);
4463 /* Similarly, if this is a record type or subtype at global level, call
4464 elaborate_expression_2 on any field position. Skip any fields that
4465 we haven't made trees for to avoid problems with class-wide types. */
4466 if (IN (kind
, Record_Kind
) && global_bindings_p ())
4467 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
4468 gnat_temp
= Next_Entity (gnat_temp
))
4469 if (Ekind (gnat_temp
) == E_Component
&& present_gnu_tree (gnat_temp
))
4471 tree gnu_field
= get_gnu_tree (gnat_temp
);
4473 /* ??? For now, store the offset as a multiple of the alignment
4474 in bytes so that we can see the alignment from the tree. */
4475 if (!TREE_CONSTANT (DECL_FIELD_OFFSET (gnu_field
))
4476 && !CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field
)))
4478 DECL_FIELD_OFFSET (gnu_field
)
4479 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field
),
4480 gnat_temp
, "OFFSET", definition
,
4482 DECL_OFFSET_ALIGN (gnu_field
));
4484 /* ??? The context of gnu_field is not necessarily gnu_type
4485 so the MULT_EXPR node built above may not be marked by
4486 the call to create_type_decl below. */
4487 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field
));
4491 if (Is_Atomic_Or_VFA (gnat_entity
))
4492 check_ok_for_atomic_type (gnu_type
, gnat_entity
, false);
4494 /* If this is not an unconstrained array type, set some flags. */
4495 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
4497 if (Present (Alignment_Clause (gnat_entity
)))
4498 TYPE_USER_ALIGN (gnu_type
) = 1;
4500 if (Universal_Aliasing (gnat_entity
) && !TYPE_IS_DUMMY_P (gnu_type
))
4501 TYPE_UNIVERSAL_ALIASING_P (gnu_type
) = 1;
4503 /* If it is passed by reference, force BLKmode to ensure that
4504 objects of this type will always be put in memory. */
4505 if (TYPE_MODE (gnu_type
) != BLKmode
4506 && AGGREGATE_TYPE_P (gnu_type
)
4507 && TYPE_BY_REFERENCE_P (gnu_type
))
4508 SET_TYPE_MODE (gnu_type
, BLKmode
);
4511 /* If this is a derived type, relate its alias set to that of its parent
4512 to avoid troubles when a call to an inherited primitive is inlined in
4513 a context where a derived object is accessed. The inlined code works
4514 on the parent view so the resulting code may access the same object
4515 using both the parent and the derived alias sets, which thus have to
4516 conflict. As the same issue arises with component references, the
4517 parent alias set also has to conflict with composite types enclosing
4518 derived components. For instance, if we have:
4525 we want T to conflict with both D and R, in addition to R being a
4526 superset of D by record/component construction.
4528 One way to achieve this is to perform an alias set copy from the
4529 parent to the derived type. This is not quite appropriate, though,
4530 as we don't want separate derived types to conflict with each other:
4532 type I1 is new Integer;
4533 type I2 is new Integer;
4535 We want I1 and I2 to both conflict with Integer but we do not want
4536 I1 to conflict with I2, and an alias set copy on derivation would
4539 The option chosen is to make the alias set of the derived type a
4540 superset of that of its parent type. It trivially fulfills the
4541 simple requirement for the Integer derivation example above, and
4542 the component case as well by superset transitivity:
4545 R ----------> D ----------> T
4547 However, for composite types, conversions between derived types are
4548 translated into VIEW_CONVERT_EXPRs so a sequence like:
4550 type Comp1 is new Comp;
4551 type Comp2 is new Comp;
4552 procedure Proc (C : Comp1);
4560 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4562 and gimplified into:
4569 i.e. generates code involving type punning. Therefore, Comp1 needs
4570 to conflict with Comp2 and an alias set copy is required.
4572 The language rules ensure the parent type is already frozen here. */
4573 if (kind
!= E_Subprogram_Type
4574 && Is_Derived_Type (gnat_entity
)
4575 && !type_annotate_only
)
4577 Entity_Id gnat_parent_type
= Underlying_Type (Etype (gnat_entity
));
4578 /* For constrained packed array subtypes, the implementation type is
4579 used instead of the nominal type. */
4580 if (kind
== E_Array_Subtype
4581 && Is_Constrained (gnat_entity
)
4582 && Present (Packed_Array_Impl_Type (gnat_parent_type
)))
4583 gnat_parent_type
= Packed_Array_Impl_Type (gnat_parent_type
);
4584 relate_alias_sets (gnu_type
, gnat_to_gnu_type (gnat_parent_type
),
4585 Is_Composite_Type (gnat_entity
)
4586 ? ALIAS_SET_COPY
: ALIAS_SET_SUPERSET
);
4589 if (Treat_As_Volatile (gnat_entity
))
4592 = TYPE_QUAL_VOLATILE
4593 | (Is_Atomic_Or_VFA (gnat_entity
) ? TYPE_QUAL_ATOMIC
: 0);
4594 gnu_type
= change_qualified_type (gnu_type
, quals
);
4598 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
,
4599 artificial_p
, debug_info_p
,
4603 TREE_TYPE (gnu_decl
) = gnu_type
;
4604 TYPE_STUB_DECL (gnu_type
) = gnu_decl
;
4608 /* If we got a type that is not dummy, back-annotate the alignment of the
4609 type if not already in the tree. Likewise for the size, if any. */
4610 if (is_type
&& !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
)))
4612 gnu_type
= TREE_TYPE (gnu_decl
);
4614 if (Unknown_Alignment (gnat_entity
))
4616 unsigned int double_align
, align
;
4617 bool is_capped_double
, align_clause
;
4619 /* If the default alignment of "double" or larger scalar types is
4620 specifically capped and this is not an array with an alignment
4621 clause on the component type, return the cap. */
4622 if ((double_align
= double_float_alignment
) > 0)
4624 = is_double_float_or_array (gnat_entity
, &align_clause
);
4625 else if ((double_align
= double_scalar_alignment
) > 0)
4627 = is_double_scalar_or_array (gnat_entity
, &align_clause
);
4629 is_capped_double
= align_clause
= false;
4631 if (is_capped_double
&& !align_clause
)
4632 align
= double_align
;
4634 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
4636 Set_Alignment (gnat_entity
, UI_From_Int (align
));
4639 if (Unknown_Esize (gnat_entity
) && TYPE_SIZE (gnu_type
))
4641 tree gnu_size
= TYPE_SIZE (gnu_type
);
4643 /* If the size is self-referential, annotate the maximum value. */
4644 if (CONTAINS_PLACEHOLDER_P (gnu_size
))
4645 gnu_size
= max_size (gnu_size
, true);
4647 /* If we are just annotating types and the type is tagged, the tag
4648 and the parent components are not generated by the front-end so
4649 alignment and sizes must be adjusted if there is no rep clause. */
4650 if (type_annotate_only
4651 && Is_Tagged_Type (gnat_entity
)
4652 && Unknown_RM_Size (gnat_entity
)
4653 && !VOID_TYPE_P (gnu_type
)
4654 && (!TYPE_FIELDS (gnu_type
)
4655 || integer_zerop (bit_position (TYPE_FIELDS (gnu_type
)))))
4659 if (Is_Derived_Type (gnat_entity
))
4661 Entity_Id gnat_parent
= Etype (Base_Type (gnat_entity
));
4662 offset
= UI_To_gnu (Esize (gnat_parent
), bitsizetype
);
4663 Set_Alignment (gnat_entity
, Alignment (gnat_parent
));
4668 = MAX (TYPE_ALIGN (gnu_type
), POINTER_SIZE
) / BITS_PER_UNIT
;
4669 offset
= bitsize_int (POINTER_SIZE
);
4670 Set_Alignment (gnat_entity
, UI_From_Int (align
));
4673 if (TYPE_FIELDS (gnu_type
))
4675 = round_up (offset
, DECL_ALIGN (TYPE_FIELDS (gnu_type
)));
4677 gnu_size
= size_binop (PLUS_EXPR
, gnu_size
, offset
);
4678 gnu_size
= round_up (gnu_size
, POINTER_SIZE
);
4679 Uint uint_size
= annotate_value (gnu_size
);
4680 Set_RM_Size (gnat_entity
, uint_size
);
4681 Set_Esize (gnat_entity
, uint_size
);
4684 /* If there is a rep clause, only adjust alignment and Esize. */
4685 else if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
4688 = MAX (TYPE_ALIGN (gnu_type
), POINTER_SIZE
) / BITS_PER_UNIT
;
4689 Set_Alignment (gnat_entity
, UI_From_Int (align
));
4690 gnu_size
= round_up (gnu_size
, POINTER_SIZE
);
4691 Set_Esize (gnat_entity
, annotate_value (gnu_size
));
4694 /* Otherwise no adjustment is needed. */
4696 Set_Esize (gnat_entity
, annotate_value (gnu_size
));
4699 if (Unknown_RM_Size (gnat_entity
) && TYPE_SIZE (gnu_type
))
4700 Set_RM_Size (gnat_entity
, annotate_value (rm_size (gnu_type
)));
4703 /* If we haven't already, associate the ..._DECL node that we just made with
4704 the input GNAT entity node. */
4706 save_gnu_tree (gnat_entity
, gnu_decl
, false);
4708 /* Now we are sure gnat_entity has a corresponding ..._DECL node,
4709 eliminate as many deferred computations as possible. */
4710 process_deferred_decl_context (false);
4712 /* If this is an enumeration or floating-point type, we were not able to set
4713 the bounds since they refer to the type. These are always static. */
4714 if ((kind
== E_Enumeration_Type
&& Present (First_Literal (gnat_entity
)))
4715 || (kind
== E_Floating_Point_Type
))
4717 tree gnu_scalar_type
= gnu_type
;
4718 tree gnu_low_bound
, gnu_high_bound
;
4720 /* If this is a padded type, we need to use the underlying type. */
4721 if (TYPE_IS_PADDING_P (gnu_scalar_type
))
4722 gnu_scalar_type
= TREE_TYPE (TYPE_FIELDS (gnu_scalar_type
));
4724 /* If this is a floating point type and we haven't set a floating
4725 point type yet, use this in the evaluation of the bounds. */
4726 if (!longest_float_type_node
&& kind
== E_Floating_Point_Type
)
4727 longest_float_type_node
= gnu_scalar_type
;
4729 gnu_low_bound
= gnat_to_gnu (Type_Low_Bound (gnat_entity
));
4730 gnu_high_bound
= gnat_to_gnu (Type_High_Bound (gnat_entity
));
4732 if (kind
== E_Enumeration_Type
)
4734 /* Enumeration types have specific RM bounds. */
4735 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type
, gnu_low_bound
);
4736 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type
, gnu_high_bound
);
4740 /* Floating-point types don't have specific RM bounds. */
4741 TYPE_GCC_MIN_VALUE (gnu_scalar_type
) = gnu_low_bound
;
4742 TYPE_GCC_MAX_VALUE (gnu_scalar_type
) = gnu_high_bound
;
4746 /* If we deferred processing of incomplete types, re-enable it. If there
4747 were no other disables and we have deferred types to process, do so. */
4749 && --defer_incomplete_level
== 0
4750 && defer_incomplete_list
)
4752 struct incomplete
*p
, *next
;
4754 /* We are back to level 0 for the deferring of incomplete types.
4755 But processing these incomplete types below may itself require
4756 deferring, so preserve what we have and restart from scratch. */
4757 p
= defer_incomplete_list
;
4758 defer_incomplete_list
= NULL
;
4765 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
4766 gnat_to_gnu_type (p
->full_type
));
4771 /* If we are not defining this type, see if it's on one of the lists of
4772 incomplete types. If so, handle the list entry now. */
4773 if (is_type
&& !definition
)
4775 struct incomplete
*p
;
4777 for (p
= defer_incomplete_list
; p
; p
= p
->next
)
4778 if (p
->old_type
&& p
->full_type
== gnat_entity
)
4780 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
4781 TREE_TYPE (gnu_decl
));
4782 p
->old_type
= NULL_TREE
;
4785 for (p
= defer_limited_with_list
; p
; p
= p
->next
)
4787 && (Non_Limited_View (p
->full_type
) == gnat_entity
4788 || Full_View (p
->full_type
) == gnat_entity
))
4790 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
4791 TREE_TYPE (gnu_decl
));
4792 if (TYPE_DUMMY_IN_PROFILE_P (p
->old_type
))
4793 update_profiles_with (p
->old_type
);
4794 p
->old_type
= NULL_TREE
;
4801 /* If this is a packed array type whose original array type is itself
4802 an Itype without freeze node, make sure the latter is processed. */
4803 if (Is_Packed_Array_Impl_Type (gnat_entity
)
4804 && Is_Itype (Original_Array_Type (gnat_entity
))
4805 && No (Freeze_Node (Original_Array_Type (gnat_entity
)))
4806 && !present_gnu_tree (Original_Array_Type (gnat_entity
)))
4807 gnat_to_gnu_entity (Original_Array_Type (gnat_entity
), NULL_TREE
, false);
4812 /* Similar, but if the returned value is a COMPONENT_REF, return the
4816 gnat_to_gnu_field_decl (Entity_Id gnat_entity
)
4818 tree gnu_field
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
4820 if (TREE_CODE (gnu_field
) == COMPONENT_REF
)
4821 gnu_field
= TREE_OPERAND (gnu_field
, 1);
4826 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4827 the GCC type corresponding to that entity. */
4830 gnat_to_gnu_type (Entity_Id gnat_entity
)
4834 /* The back end never attempts to annotate generic types. */
4835 if (Is_Generic_Type (gnat_entity
) && type_annotate_only
)
4836 return void_type_node
;
4838 gnu_decl
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, false);
4839 gcc_assert (TREE_CODE (gnu_decl
) == TYPE_DECL
);
4841 return TREE_TYPE (gnu_decl
);
4844 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4845 the unpadded version of the GCC type corresponding to that entity. */
4848 get_unpadded_type (Entity_Id gnat_entity
)
4850 tree type
= gnat_to_gnu_type (gnat_entity
);
4852 if (TYPE_IS_PADDING_P (type
))
4853 type
= TREE_TYPE (TYPE_FIELDS (type
));
4858 /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
4859 a C++ imported method or equivalent.
4861 We use the predicate on 32-bit x86/Windows to find out whether we need to
4862 use the "thiscall" calling convention for GNAT_ENTITY. This convention is
4863 used for C++ methods (functions with METHOD_TYPE) by the back-end. */
4866 is_cplusplus_method (Entity_Id gnat_entity
)
4868 /* A constructor is a method on the C++ side. We deal with it now because
4869 it is declared without the 'this' parameter in the sources and, although
4870 the front-end will create a version with the 'this' parameter for code
4871 generation purposes, we want to return true for both versions. */
4872 if (Is_Constructor (gnat_entity
))
4875 /* Check that the subprogram has C++ convention. */
4876 if (Convention (gnat_entity
) != Convention_CPP
)
4879 /* And that the type of the first parameter (indirectly) has it too. */
4880 Entity_Id gnat_first
= First_Formal (gnat_entity
);
4881 if (No (gnat_first
))
4884 Entity_Id gnat_type
= Etype (gnat_first
);
4885 if (Is_Access_Type (gnat_type
))
4886 gnat_type
= Directly_Designated_Type (gnat_type
);
4887 if (Convention (gnat_type
) != Convention_CPP
)
4890 /* This is the main case: a C++ virtual method imported as a primitive
4891 operation of a tagged type. */
4892 if (Is_Dispatching_Operation (gnat_entity
))
4895 /* This is set on the E_Subprogram_Type built for a dispatching call. */
4896 if (Is_Dispatch_Table_Entity (gnat_entity
))
4899 /* A thunk needs to be handled like its associated primitive operation. */
4900 if (Is_Subprogram (gnat_entity
) && Is_Thunk (gnat_entity
))
4903 /* Now on to the annoying case: a C++ non-virtual method, imported either
4904 as a non-primitive operation of a tagged type or as a primitive operation
4905 of an untagged type. We cannot reliably differentiate these cases from
4906 their static member or regular function equivalents in Ada, so we ask
4907 the C++ side through the mangled name of the function, as the implicit
4908 'this' parameter is not encoded in the mangled name of a method. */
4909 if (Is_Subprogram (gnat_entity
) && Present (Interface_Name (gnat_entity
)))
4911 String_Pointer sp
= { NULL
, NULL
};
4912 Get_External_Name (gnat_entity
, false, sp
);
4915 struct demangle_component
*cmp
4916 = cplus_demangle_v3_components (Name_Buffer
,
4925 /* We need to release MEM once we have a successful demangling. */
4928 if (cmp
->type
== DEMANGLE_COMPONENT_TYPED_NAME
4929 && cmp
->u
.s_binary
.right
->type
== DEMANGLE_COMPONENT_FUNCTION_TYPE
4930 && (cmp
= cmp
->u
.s_binary
.right
->u
.s_binary
.right
) != NULL
4931 && cmp
->type
== DEMANGLE_COMPONENT_ARGLIST
)
4933 /* Make sure there is at least one parameter in C++ too. */
4934 if (cmp
->u
.s_binary
.left
)
4936 unsigned int n_ada_args
= 0;
4939 gnat_first
= Next_Formal (gnat_first
);
4940 } while (Present (gnat_first
));
4942 unsigned int n_cpp_args
= 0;
4945 cmp
= cmp
->u
.s_binary
.right
;
4948 if (n_cpp_args
< n_ada_args
)
4963 /* Finalize the processing of From_Limited_With incomplete types. */
4966 finalize_from_limited_with (void)
4968 struct incomplete
*p
, *next
;
4970 p
= defer_limited_with_list
;
4971 defer_limited_with_list
= NULL
;
4979 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
4980 gnat_to_gnu_type (p
->full_type
));
4981 if (TYPE_DUMMY_IN_PROFILE_P (p
->old_type
))
4982 update_profiles_with (p
->old_type
);
4989 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a kind
4990 of type (such E_Task_Type) that has a different type which Gigi uses
4991 for its representation. If the type does not have a special type for
4992 its representation, return GNAT_ENTITY. */
4995 Gigi_Equivalent_Type (Entity_Id gnat_entity
)
4997 Entity_Id gnat_equiv
= gnat_entity
;
4999 if (No (gnat_entity
))
5002 switch (Ekind (gnat_entity
))
5004 case E_Class_Wide_Subtype
:
5005 if (Present (Equivalent_Type (gnat_entity
)))
5006 gnat_equiv
= Equivalent_Type (gnat_entity
);
5009 case E_Access_Protected_Subprogram_Type
:
5010 case E_Anonymous_Access_Protected_Subprogram_Type
:
5011 if (Present (Equivalent_Type (gnat_entity
)))
5012 gnat_equiv
= Equivalent_Type (gnat_entity
);
5015 case E_Class_Wide_Type
:
5016 gnat_equiv
= Root_Type (gnat_entity
);
5019 case E_Protected_Type
:
5020 case E_Protected_Subtype
:
5022 case E_Task_Subtype
:
5023 if (Present (Corresponding_Record_Type (gnat_entity
)))
5024 gnat_equiv
= Corresponding_Record_Type (gnat_entity
);
5034 /* Return a GCC tree for a type corresponding to the component type of the
5035 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5036 is for an array being defined. DEBUG_INFO_P is true if we need to write
5037 debug information for other types that we may create in the process. */
5040 gnat_to_gnu_component_type (Entity_Id gnat_array
, bool definition
,
5043 const Entity_Id gnat_type
= Component_Type (gnat_array
);
5044 tree gnu_type
= gnat_to_gnu_type (gnat_type
);
5046 unsigned int max_align
;
5048 /* If an alignment is specified, use it as a cap on the component type
5049 so that it can be honored for the whole type. But ignore it for the
5050 original type of packed array types. */
5051 if (No (Packed_Array_Impl_Type (gnat_array
))
5052 && Known_Alignment (gnat_array
))
5053 max_align
= validate_alignment (Alignment (gnat_array
), gnat_array
, 0);
5057 /* Try to get a smaller form of the component if needed. */
5058 if ((Is_Packed (gnat_array
) || Has_Component_Size_Clause (gnat_array
))
5059 && !Is_Bit_Packed_Array (gnat_array
)
5060 && !Has_Aliased_Components (gnat_array
)
5061 && !Strict_Alignment (gnat_type
)
5062 && RECORD_OR_UNION_TYPE_P (gnu_type
)
5063 && !TYPE_FAT_POINTER_P (gnu_type
)
5064 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type
)))
5065 gnu_type
= make_packable_type (gnu_type
, false, max_align
);
5067 if (Has_Atomic_Components (gnat_array
))
5068 check_ok_for_atomic_type (gnu_type
, gnat_array
, true);
5070 /* Get and validate any specified Component_Size. */
5072 = validate_size (Component_Size (gnat_array
), gnu_type
, gnat_array
,
5073 Is_Bit_Packed_Array (gnat_array
) ? TYPE_DECL
: VAR_DECL
,
5074 true, Has_Component_Size_Clause (gnat_array
));
5076 /* If the array has aliased components and the component size can be zero,
5077 force at least unit size to ensure that the components have distinct
5080 && Has_Aliased_Components (gnat_array
)
5081 && (integer_zerop (TYPE_SIZE (gnu_type
))
5082 || (TREE_CODE (gnu_type
) == ARRAY_TYPE
5083 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
)))))
5085 = size_binop (MAX_EXPR
, TYPE_SIZE (gnu_type
), bitsize_unit_node
);
5087 /* If the component type is a RECORD_TYPE that has a self-referential size,
5088 then use the maximum size for the component size. */
5090 && TREE_CODE (gnu_type
) == RECORD_TYPE
5091 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
5092 gnu_comp_size
= max_size (TYPE_SIZE (gnu_type
), true);
5094 /* Honor the component size. This is not needed for bit-packed arrays. */
5095 if (gnu_comp_size
&& !Is_Bit_Packed_Array (gnat_array
))
5097 tree orig_type
= gnu_type
;
5099 gnu_type
= make_type_from_size (gnu_type
, gnu_comp_size
, false);
5100 if (max_align
> 0 && TYPE_ALIGN (gnu_type
) > max_align
)
5101 gnu_type
= orig_type
;
5103 orig_type
= gnu_type
;
5105 gnu_type
= maybe_pad_type (gnu_type
, gnu_comp_size
, 0, gnat_array
,
5106 true, false, definition
, true);
5108 /* If a padding record was made, declare it now since it will never be
5109 declared otherwise. This is necessary to ensure that its subtrees
5110 are properly marked. */
5111 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
5112 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, true, debug_info_p
,
5116 /* If the component type is a padded type made for a non-bit-packed array
5117 of scalars with reverse storage order, we need to propagate the reverse
5118 storage order to the padding type since it is the innermost enclosing
5119 aggregate type around the scalar. */
5120 if (TYPE_IS_PADDING_P (gnu_type
)
5121 && Reverse_Storage_Order (gnat_array
)
5122 && !Is_Bit_Packed_Array (gnat_array
)
5123 && Is_Scalar_Type (gnat_type
))
5124 gnu_type
= set_reverse_storage_order_on_pad_type (gnu_type
);
5126 if (Has_Volatile_Components (gnat_array
))
5129 = TYPE_QUAL_VOLATILE
5130 | (Has_Atomic_Components (gnat_array
) ? TYPE_QUAL_ATOMIC
: 0);
5131 gnu_type
= change_qualified_type (gnu_type
, quals
);
5137 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM, to be placed
5138 in the parameter list of GNAT_SUBPROG. GNU_PARAM_TYPE is the GCC tree for
5139 the type of the parameter. FIRST is true if this is the first parameter in
5140 the list of GNAT_SUBPROG. Also set CICO to true if the parameter must use
5141 the copy-in copy-out implementation mechanism.
5143 The returned tree is a PARM_DECL, except for the cases where no parameter
5144 needs to be actually passed to the subprogram; the type of this "shadow"
5145 parameter is then returned instead. */
5148 gnat_to_gnu_param (Entity_Id gnat_param
, tree gnu_param_type
, bool first
,
5149 Entity_Id gnat_subprog
, bool *cico
)
5151 Entity_Id gnat_param_type
= Etype (gnat_param
);
5152 Mechanism_Type mech
= Mechanism (gnat_param
);
5153 tree gnu_param_name
= get_entity_name (gnat_param
);
5154 bool foreign
= Has_Foreign_Convention (gnat_subprog
);
5155 bool in_param
= (Ekind (gnat_param
) == E_In_Parameter
);
5156 /* The parameter can be indirectly modified if its address is taken. */
5157 bool ro_param
= in_param
&& !Address_Taken (gnat_param
);
5158 bool by_return
= false, by_component_ptr
= false;
5159 bool by_ref
= false;
5160 bool restricted_aliasing_p
= false;
5161 location_t saved_location
= input_location
;
5164 /* Make sure to use the proper SLOC for vector ABI warnings. */
5165 if (VECTOR_TYPE_P (gnu_param_type
))
5166 Sloc_to_locus (Sloc (gnat_subprog
), &input_location
);
5168 /* Builtins are expanded inline and there is no real call sequence involved.
5169 So the type expected by the underlying expander is always the type of the
5170 argument "as is". */
5171 if (Convention (gnat_subprog
) == Convention_Intrinsic
5172 && Present (Interface_Name (gnat_subprog
)))
5175 /* Handle the first parameter of a valued procedure specially: it's a copy
5176 mechanism for which the parameter is never allocated. */
5177 else if (first
&& Is_Valued_Procedure (gnat_subprog
))
5179 gcc_assert (Ekind (gnat_param
) == E_Out_Parameter
);
5184 /* Or else, see if a Mechanism was supplied that forced this parameter
5185 to be passed one way or another. */
5186 else if (mech
== Default
|| mech
== By_Copy
|| mech
== By_Reference
)
5189 /* Positive mechanism means by copy for sufficiently small parameters. */
5192 if (TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
5193 || TREE_CODE (TYPE_SIZE (gnu_param_type
)) != INTEGER_CST
5194 || compare_tree_int (TYPE_SIZE (gnu_param_type
), mech
) > 0)
5195 mech
= By_Reference
;
5200 /* Otherwise, it's an unsupported mechanism so error out. */
5203 post_error ("unsupported mechanism for&", gnat_param
);
5207 /* If this is either a foreign function or if the underlying type won't
5208 be passed by reference and is as aligned as the original type, strip
5209 off possible padding type. */
5210 if (TYPE_IS_PADDING_P (gnu_param_type
))
5212 tree unpadded_type
= TREE_TYPE (TYPE_FIELDS (gnu_param_type
));
5215 || (!must_pass_by_ref (unpadded_type
)
5216 && mech
!= By_Reference
5217 && (mech
== By_Copy
|| !default_pass_by_ref (unpadded_type
))
5218 && TYPE_ALIGN (unpadded_type
) >= TYPE_ALIGN (gnu_param_type
)))
5219 gnu_param_type
= unpadded_type
;
5222 /* If this is a read-only parameter, make a variant of the type that is
5223 read-only. ??? However, if this is a self-referential type, the type
5224 can be very complex, so skip it for now. */
5225 if (ro_param
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type
)))
5226 gnu_param_type
= change_qualified_type (gnu_param_type
, TYPE_QUAL_CONST
);
5228 /* For foreign conventions, pass arrays as pointers to the element type.
5229 First check for unconstrained array and get the underlying array. */
5230 if (foreign
&& TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5232 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type
))));
5234 /* Arrays are passed as pointers to element type for foreign conventions. */
5235 if (foreign
&& mech
!= By_Copy
&& TREE_CODE (gnu_param_type
) == ARRAY_TYPE
)
5237 /* Strip off any multi-dimensional entries, then strip
5238 off the last array to get the component type. */
5239 while (TREE_CODE (TREE_TYPE (gnu_param_type
)) == ARRAY_TYPE
5240 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type
)))
5241 gnu_param_type
= TREE_TYPE (gnu_param_type
);
5243 by_component_ptr
= true;
5244 gnu_param_type
= TREE_TYPE (gnu_param_type
);
5248 = change_qualified_type (gnu_param_type
, TYPE_QUAL_CONST
);
5250 gnu_param_type
= build_pointer_type (gnu_param_type
);
5253 /* Fat pointers are passed as thin pointers for foreign conventions. */
5254 else if (foreign
&& TYPE_IS_FAT_POINTER_P (gnu_param_type
))
5256 = make_type_from_size (gnu_param_type
, size_int (POINTER_SIZE
), 0);
5258 /* If we were requested or muss pass by reference, do so.
5259 If we were requested to pass by copy, do so.
5260 Otherwise, for foreign conventions, pass In Out or Out parameters
5261 or aggregates by reference. For COBOL and Fortran, pass all
5262 integer and FP types that way too. For Convention Ada, use
5263 the standard Ada default. */
5264 else if (mech
== By_Reference
5265 || must_pass_by_ref (gnu_param_type
)
5268 && (!in_param
|| AGGREGATE_TYPE_P (gnu_param_type
)))
5270 && (Convention (gnat_subprog
) == Convention_Fortran
5271 || Convention (gnat_subprog
) == Convention_COBOL
)
5272 && (INTEGRAL_TYPE_P (gnu_param_type
)
5273 || FLOAT_TYPE_P (gnu_param_type
)))
5275 && default_pass_by_ref (gnu_param_type
)))))
5277 /* We take advantage of 6.2(12) by considering that references built for
5278 parameters whose type isn't by-ref and for which the mechanism hasn't
5279 been forced to by-ref allow only a restricted form of aliasing. */
5280 restricted_aliasing_p
5281 = !TYPE_IS_BY_REFERENCE_P (gnu_param_type
) && mech
!= By_Reference
;
5282 gnu_param_type
= build_reference_type (gnu_param_type
);
5286 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5290 input_location
= saved_location
;
5292 if (mech
== By_Copy
&& (by_ref
|| by_component_ptr
))
5293 post_error ("?cannot pass & by copy", gnat_param
);
5295 /* If this is an Out parameter that isn't passed by reference and isn't
5296 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5297 it will be a VAR_DECL created when we process the procedure, so just
5298 return its type. For the special parameter of a valued procedure,
5301 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5302 Out parameters with discriminants or implicit initial values to be
5303 handled like In Out parameters. These type are normally built as
5304 aggregates, hence passed by reference, except for some packed arrays
5305 which end up encoded in special integer types. Note that scalars can
5306 be given implicit initial values using the Default_Value aspect.
5308 The exception we need to make is then for packed arrays of records
5309 with discriminants or implicit initial values. We have no light/easy
5310 way to check for the latter case, so we merely check for packed arrays
5311 of records. This may lead to useless copy-in operations, but in very
5312 rare cases only, as these would be exceptions in a set of already
5313 exceptional situations. */
5314 if (Ekind (gnat_param
) == E_Out_Parameter
5317 || (!POINTER_TYPE_P (gnu_param_type
)
5318 && !AGGREGATE_TYPE_P (gnu_param_type
)
5319 && !Has_Default_Aspect (gnat_param_type
)))
5320 && !(Is_Array_Type (gnat_param_type
)
5321 && Is_Packed (gnat_param_type
)
5322 && Is_Composite_Type (Component_Type (gnat_param_type
))))
5323 return gnu_param_type
;
5325 gnu_param
= create_param_decl (gnu_param_name
, gnu_param_type
);
5326 TREE_READONLY (gnu_param
) = ro_param
|| by_ref
|| by_component_ptr
;
5327 DECL_BY_REF_P (gnu_param
) = by_ref
;
5328 DECL_BY_COMPONENT_PTR_P (gnu_param
) = by_component_ptr
;
5329 DECL_POINTS_TO_READONLY_P (gnu_param
)
5330 = (ro_param
&& (by_ref
|| by_component_ptr
));
5331 DECL_CAN_NEVER_BE_NULL_P (gnu_param
) = Can_Never_Be_Null (gnat_param
);
5332 DECL_RESTRICTED_ALIASING_P (gnu_param
) = restricted_aliasing_p
;
5333 Sloc_to_locus (Sloc (gnat_param
), &DECL_SOURCE_LOCATION (gnu_param
));
5335 /* If no Mechanism was specified, indicate what we're using, then
5336 back-annotate it. */
5337 if (mech
== Default
)
5338 mech
= (by_ref
|| by_component_ptr
) ? By_Reference
: By_Copy
;
5340 Set_Mechanism (gnat_param
, mech
);
5344 /* Associate GNAT_SUBPROG with GNU_TYPE, which must be a dummy type, so that
5345 GNAT_SUBPROG is updated when GNU_TYPE is completed.
5347 Ada 2012 (AI05-019) says that freezing a subprogram does not always freeze
5348 the corresponding profile, which means that, by the time the freeze node
5349 of the subprogram is encountered, types involved in its profile may still
5350 be not yet frozen. That's why we need to update GNAT_SUBPROG when we see
5351 the freeze node of types involved in its profile, either types of formal
5352 parameters or the return type. */
5355 associate_subprog_with_dummy_type (Entity_Id gnat_subprog
, tree gnu_type
)
5357 gcc_assert (TYPE_IS_DUMMY_P (gnu_type
));
5359 struct tree_entity_vec_map in
;
5360 in
.base
.from
= gnu_type
;
5361 struct tree_entity_vec_map
**slot
5362 = dummy_to_subprog_map
->find_slot (&in
, INSERT
);
5365 tree_entity_vec_map
*e
= ggc_alloc
<tree_entity_vec_map
> ();
5366 e
->base
.from
= gnu_type
;
5371 /* Even if there is already a slot for GNU_TYPE, we need to set the flag
5372 because the vector might have been just emptied by update_profiles_with.
5373 This can happen when there are 2 freeze nodes associated with different
5374 views of the same type; the type will be really complete only after the
5375 second freeze node is encountered. */
5376 TYPE_DUMMY_IN_PROFILE_P (gnu_type
) = 1;
5378 vec
<Entity_Id
, va_gc_atomic
> *v
= (*slot
)->to
;
5380 /* Make sure GNAT_SUBPROG is not associated twice with the same dummy type,
5381 since this would mean updating twice its profile. */
5384 const unsigned len
= v
->length ();
5385 unsigned int l
= 0, u
= len
;
5387 /* Entity_Id is a simple integer so we can implement a stable order on
5388 the vector with an ordered insertion scheme and binary search. */
5391 unsigned int m
= (l
+ u
) / 2;
5392 int diff
= (int) (*v
)[m
] - (int) gnat_subprog
;
5401 /* l == u and therefore is the insertion point. */
5402 vec_safe_insert (v
, l
, gnat_subprog
);
5405 vec_safe_push (v
, gnat_subprog
);
5410 /* Update the GCC tree previously built for the profile of GNAT_SUBPROG. */
5413 update_profile (Entity_Id gnat_subprog
)
5415 tree gnu_param_list
;
5416 tree gnu_type
= gnat_to_gnu_subprog_type (gnat_subprog
, true,
5417 Needs_Debug_Info (gnat_subprog
),
5419 if (DECL_P (gnu_type
))
5421 /* Builtins cannot have their address taken so we can reset them. */
5422 gcc_assert (DECL_BUILT_IN (gnu_type
));
5423 save_gnu_tree (gnat_subprog
, NULL_TREE
, false);
5424 save_gnu_tree (gnat_subprog
, gnu_type
, false);
5428 tree gnu_subprog
= get_gnu_tree (gnat_subprog
);
5430 TREE_TYPE (gnu_subprog
) = gnu_type
;
5432 /* If GNAT_SUBPROG is an actual subprogram, GNU_SUBPROG is a FUNCTION_DECL
5433 and needs to be adjusted too. */
5434 if (Ekind (gnat_subprog
) != E_Subprogram_Type
)
5436 tree gnu_entity_name
= get_entity_name (gnat_subprog
);
5438 = gnu_ext_name_for_subprog (gnat_subprog
, gnu_entity_name
);
5440 DECL_ARGUMENTS (gnu_subprog
) = gnu_param_list
;
5441 finish_subprog_decl (gnu_subprog
, gnu_ext_name
, gnu_type
);
5445 /* Update the GCC trees previously built for the profiles involving GNU_TYPE,
5446 a dummy type which appears in profiles. */
5449 update_profiles_with (tree gnu_type
)
5451 struct tree_entity_vec_map in
;
5452 in
.base
.from
= gnu_type
;
5453 struct tree_entity_vec_map
*e
= dummy_to_subprog_map
->find (&in
);
5455 vec
<Entity_Id
, va_gc_atomic
> *v
= e
->to
;
5458 /* The flag needs to be reset before calling update_profile, in case
5459 associate_subprog_with_dummy_type is again invoked on GNU_TYPE. */
5460 TYPE_DUMMY_IN_PROFILE_P (gnu_type
) = 0;
5464 FOR_EACH_VEC_ELT (*v
, i
, iter
)
5465 update_profile (*iter
);
5470 /* Return the GCC tree for GNAT_TYPE present in the profile of a subprogram.
5472 Ada 2012 (AI05-0151) says that incomplete types coming from a limited
5473 context may now appear as parameter and result types. As a consequence,
5474 we may need to defer their translation until after a freeze node is seen
5475 or to the end of the current unit. We also aim at handling temporarily
5476 incomplete types created by the usual delayed elaboration scheme. */
5479 gnat_to_gnu_profile_type (Entity_Id gnat_type
)
5481 /* This is the same logic as the E_Access_Type case of gnat_to_gnu_entity
5482 so the rationale is exposed in that place. These processings probably
5483 ought to be merged at some point. */
5484 Entity_Id gnat_equiv
= Gigi_Equivalent_Type (gnat_type
);
5485 const bool is_from_limited_with
5486 = (Is_Incomplete_Type (gnat_equiv
)
5487 && From_Limited_With (gnat_equiv
));
5488 Entity_Id gnat_full_direct_first
5489 = (is_from_limited_with
5490 ? Non_Limited_View (gnat_equiv
)
5491 : (Is_Incomplete_Or_Private_Type (gnat_equiv
)
5492 ? Full_View (gnat_equiv
) : Empty
));
5493 Entity_Id gnat_full_direct
5494 = ((is_from_limited_with
5495 && Present (gnat_full_direct_first
)
5496 && Is_Private_Type (gnat_full_direct_first
))
5497 ? Full_View (gnat_full_direct_first
)
5498 : gnat_full_direct_first
);
5499 Entity_Id gnat_full
= Gigi_Equivalent_Type (gnat_full_direct
);
5500 Entity_Id gnat_rep
= Present (gnat_full
) ? gnat_full
: gnat_equiv
;
5501 const bool in_main_unit
= In_Extended_Main_Code_Unit (gnat_rep
);
5504 if (Present (gnat_full
) && present_gnu_tree (gnat_full
))
5505 gnu_type
= TREE_TYPE (get_gnu_tree (gnat_full
));
5507 else if (is_from_limited_with
5509 && !present_gnu_tree (gnat_equiv
)
5510 && Present (gnat_full
)
5511 && (Is_Record_Type (gnat_full
)
5512 || Is_Array_Type (gnat_full
)
5513 || Is_Access_Type (gnat_full
)))
5514 || (in_main_unit
&& Present (Freeze_Node (gnat_rep
)))))
5516 gnu_type
= make_dummy_type (gnat_equiv
);
5520 struct incomplete
*p
= XNEW (struct incomplete
);
5522 p
->old_type
= gnu_type
;
5523 p
->full_type
= gnat_equiv
;
5524 p
->next
= defer_limited_with_list
;
5525 defer_limited_with_list
= p
;
5529 else if (type_annotate_only
&& No (gnat_equiv
))
5530 gnu_type
= void_type_node
;
5533 gnu_type
= gnat_to_gnu_type (gnat_equiv
);
5535 /* Access-to-unconstrained-array types need a special treatment. */
5536 if (Is_Array_Type (gnat_rep
) && !Is_Constrained (gnat_rep
))
5538 if (!TYPE_POINTER_TO (gnu_type
))
5539 build_dummy_unc_pointer_types (gnat_equiv
, gnu_type
);
5545 /* Return a GCC tree for a subprogram type corresponding to GNAT_SUBPROG.
5546 DEFINITION is true if this is for a subprogram being defined. DEBUG_INFO_P
5547 is true if we need to write debug information for other types that we may
5548 create in the process. Also set PARAM_LIST to the list of parameters.
5549 If GNAT_SUBPROG is bound to a GCC builtin, return the DECL for the builtin
5550 directly instead of its type. */
5553 gnat_to_gnu_subprog_type (Entity_Id gnat_subprog
, bool definition
,
5554 bool debug_info_p
, tree
*param_list
)
5556 const Entity_Kind kind
= Ekind (gnat_subprog
);
5557 Entity_Id gnat_return_type
= Etype (gnat_subprog
);
5558 Entity_Id gnat_param
;
5559 tree gnu_type
= present_gnu_tree (gnat_subprog
)
5560 ? TREE_TYPE (get_gnu_tree (gnat_subprog
)) : NULL_TREE
;
5561 tree gnu_return_type
;
5562 tree gnu_param_type_list
= NULL_TREE
;
5563 tree gnu_param_list
= NULL_TREE
;
5564 /* Non-null for subprograms containing parameters passed by copy-in copy-out
5565 (In Out or Out parameters not passed by reference), in which case it is
5566 the list of nodes used to specify the values of the In Out/Out parameters
5567 that are returned as a record upon procedure return. The TREE_PURPOSE of
5568 an element of this list is a FIELD_DECL of the record and the TREE_VALUE
5569 is the PARM_DECL corresponding to that field. This list will be saved in
5570 the TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
5571 tree gnu_cico_list
= NULL_TREE
;
5572 tree gnu_cico_return_type
= NULL_TREE
;
5573 /* Fields in return type of procedure with copy-in copy-out parameters. */
5574 tree gnu_field_list
= NULL_TREE
;
5575 /* The semantics of "pure" in Ada essentially matches that of "const"
5576 in the back-end. In particular, both properties are orthogonal to
5577 the "nothrow" property if the EH circuitry is explicit in the
5578 internal representation of the back-end. If we are to completely
5579 hide the EH circuitry from it, we need to declare that calls to pure
5580 Ada subprograms that can throw have side effects since they can
5581 trigger an "abnormal" transfer of control flow; thus they can be
5582 neither "const" nor "pure" in the back-end sense. */
5583 bool const_flag
= (Back_End_Exceptions () && Is_Pure (gnat_subprog
));
5584 bool return_by_direct_ref_p
= false;
5585 bool return_by_invisi_ref_p
= false;
5586 bool return_unconstrained_p
= false;
5587 bool incomplete_profile_p
= false;
5590 /* Look into the return type and get its associated GCC tree if it is not
5591 void, and then compute various flags for the subprogram type. But make
5592 sure not to do this processing multiple times. */
5593 if (Ekind (gnat_return_type
) == E_Void
)
5594 gnu_return_type
= void_type_node
;
5597 && TREE_CODE (gnu_type
) == FUNCTION_TYPE
5598 && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_type
)))
5600 gnu_return_type
= TREE_TYPE (gnu_type
);
5601 return_unconstrained_p
= TYPE_RETURN_UNCONSTRAINED_P (gnu_type
);
5602 return_by_direct_ref_p
= TYPE_RETURN_BY_DIRECT_REF_P (gnu_type
);
5603 return_by_invisi_ref_p
= TREE_ADDRESSABLE (gnu_type
);
5608 /* For foreign convention subprograms, return System.Address as void *
5609 or equivalent. Note that this comprises GCC builtins. */
5610 if (Has_Foreign_Convention (gnat_subprog
)
5611 && Is_Descendant_Of_Address (gnat_return_type
))
5612 gnu_return_type
= ptr_type_node
;
5614 gnu_return_type
= gnat_to_gnu_profile_type (gnat_return_type
);
5616 /* If this function returns by reference, make the actual return type
5617 the reference type and make a note of that. */
5618 if (Returns_By_Ref (gnat_subprog
))
5620 gnu_return_type
= build_reference_type (gnu_return_type
);
5621 return_by_direct_ref_p
= true;
5624 /* If the return type is an unconstrained array type, the return value
5625 will be allocated on the secondary stack so the actual return type
5626 is the fat pointer type. */
5627 else if (TREE_CODE (gnu_return_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5629 gnu_return_type
= TYPE_REFERENCE_TO (gnu_return_type
);
5630 return_unconstrained_p
= true;
5633 /* This is the same unconstrained array case, but for a dummy type. */
5634 else if (TYPE_REFERENCE_TO (gnu_return_type
)
5635 && TYPE_IS_FAT_POINTER_P (TYPE_REFERENCE_TO (gnu_return_type
)))
5637 gnu_return_type
= TYPE_REFERENCE_TO (gnu_return_type
);
5638 return_unconstrained_p
= true;
5641 /* Likewise, if the return type requires a transient scope, the return
5642 value will also be allocated on the secondary stack so the actual
5643 return type is the reference type. */
5644 else if (Requires_Transient_Scope (gnat_return_type
))
5646 gnu_return_type
= build_reference_type (gnu_return_type
);
5647 return_unconstrained_p
= true;
5650 /* If the Mechanism is By_Reference, ensure this function uses the
5651 target's by-invisible-reference mechanism, which may not be the
5652 same as above (e.g. it might be passing an extra parameter). */
5653 else if (kind
== E_Function
&& Mechanism (gnat_subprog
) == By_Reference
)
5654 return_by_invisi_ref_p
= true;
5656 /* Likewise, if the return type is itself By_Reference. */
5657 else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type
))
5658 return_by_invisi_ref_p
= true;
5660 /* If the type is a padded type and the underlying type would not be
5661 passed by reference or the function has a foreign convention, return
5662 the underlying type. */
5663 else if (TYPE_IS_PADDING_P (gnu_return_type
)
5664 && (!default_pass_by_ref
5665 (TREE_TYPE (TYPE_FIELDS (gnu_return_type
)))
5666 || Has_Foreign_Convention (gnat_subprog
)))
5667 gnu_return_type
= TREE_TYPE (TYPE_FIELDS (gnu_return_type
));
5669 /* If the return type is unconstrained, it must have a maximum size.
5670 Use the padded type as the effective return type. And ensure the
5671 function uses the target's by-invisible-reference mechanism to
5672 avoid copying too much data when it returns. */
5673 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type
)))
5675 tree orig_type
= gnu_return_type
;
5676 tree max_return_size
= max_size (TYPE_SIZE (gnu_return_type
), true);
5678 /* If the size overflows to 0, set it to an arbitrary positive
5679 value so that assignments in the type are preserved. Their
5680 actual size is independent of this positive value. */
5681 if (TREE_CODE (max_return_size
) == INTEGER_CST
5682 && TREE_OVERFLOW (max_return_size
)
5683 && integer_zerop (max_return_size
))
5685 max_return_size
= copy_node (bitsize_unit_node
);
5686 TREE_OVERFLOW (max_return_size
) = 1;
5689 gnu_return_type
= maybe_pad_type (gnu_return_type
, max_return_size
,
5690 0, gnat_subprog
, false, false,
5693 /* Declare it now since it will never be declared otherwise. This
5694 is necessary to ensure that its subtrees are properly marked. */
5695 if (gnu_return_type
!= orig_type
5696 && !DECL_P (TYPE_NAME (gnu_return_type
)))
5697 create_type_decl (TYPE_NAME (gnu_return_type
), gnu_return_type
,
5698 true, debug_info_p
, gnat_subprog
);
5700 return_by_invisi_ref_p
= true;
5703 /* If the return type has a size that overflows, we usually cannot have
5704 a function that returns that type. This usage doesn't really make
5705 sense anyway, so issue an error here. */
5706 if (!return_by_invisi_ref_p
5707 && TYPE_SIZE_UNIT (gnu_return_type
)
5708 && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type
)) == INTEGER_CST
5709 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type
)))
5711 post_error ("cannot return type whose size overflows", gnat_subprog
);
5712 gnu_return_type
= copy_type (gnu_return_type
);
5713 TYPE_SIZE (gnu_return_type
) = bitsize_zero_node
;
5714 TYPE_SIZE_UNIT (gnu_return_type
) = size_zero_node
;
5717 /* If the return type is incomplete, there are 2 cases: if the function
5718 returns by reference, then the return type is only linked indirectly
5719 in the profile, so the profile can be seen as complete since it need
5720 not be further modified, only the reference types need be adjusted;
5721 otherwise the profile is incomplete and need be adjusted too. */
5722 if (TYPE_IS_DUMMY_P (gnu_return_type
))
5724 associate_subprog_with_dummy_type (gnat_subprog
, gnu_return_type
);
5725 incomplete_profile_p
= true;
5728 if (kind
== E_Function
)
5729 Set_Mechanism (gnat_subprog
, return_unconstrained_p
5730 || return_by_direct_ref_p
5731 || return_by_invisi_ref_p
5732 ? By_Reference
: By_Copy
);
5735 /* A procedure (something that doesn't return anything) shouldn't be
5736 considered const since there would be no reason for calling such a
5737 subprogram. Note that procedures with Out (or In Out) parameters
5738 have already been converted into a function with a return type.
5739 Similarly, if the function returns an unconstrained type, then the
5740 function will allocate the return value on the secondary stack and
5741 thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
5742 if (TREE_CODE (gnu_return_type
) == VOID_TYPE
|| return_unconstrained_p
)
5745 /* Loop over the parameters and get their associated GCC tree. While doing
5746 this, build a copy-in copy-out structure if we need one. */
5747 for (gnat_param
= First_Formal_With_Extras (gnat_subprog
), num
= 0;
5748 Present (gnat_param
);
5749 gnat_param
= Next_Formal_With_Extras (gnat_param
), num
++)
5751 const bool mech_is_by_ref
5752 = Mechanism (gnat_param
) == By_Reference
5753 && !(num
== 0 && Is_Valued_Procedure (gnat_subprog
));
5754 tree gnu_param_name
= get_entity_name (gnat_param
);
5755 tree gnu_param
, gnu_param_type
;
5758 /* Fetch an existing parameter with complete type and reuse it. But we
5759 didn't save the CICO property so we can only do it for In parameters
5760 or parameters passed by reference. */
5761 if ((Ekind (gnat_param
) == E_In_Parameter
|| mech_is_by_ref
)
5762 && present_gnu_tree (gnat_param
)
5763 && (gnu_param
= get_gnu_tree (gnat_param
))
5764 && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_param
)))
5766 DECL_CHAIN (gnu_param
) = NULL_TREE
;
5767 gnu_param_type
= TREE_TYPE (gnu_param
);
5770 /* Otherwise translate the parameter type and act accordingly. */
5773 Entity_Id gnat_param_type
= Etype (gnat_param
);
5775 /* For foreign convention subprograms, pass System.Address as void *
5776 or equivalent. Note that this comprises GCC builtins. */
5777 if (Has_Foreign_Convention (gnat_subprog
)
5778 && Is_Descendant_Of_Address (gnat_param_type
))
5779 gnu_param_type
= ptr_type_node
;
5781 gnu_param_type
= gnat_to_gnu_profile_type (gnat_param_type
);
5783 /* If the parameter type is incomplete, there are 2 cases: if it is
5784 passed by reference, then the type is only linked indirectly in
5785 the profile, so the profile can be seen as complete since it need
5786 not be further modified, only the reference type need be adjusted;
5787 otherwise the profile is incomplete and need be adjusted too. */
5788 if (TYPE_IS_DUMMY_P (gnu_param_type
))
5793 || (TYPE_REFERENCE_TO (gnu_param_type
)
5794 && TYPE_IS_FAT_POINTER_P
5795 (TYPE_REFERENCE_TO (gnu_param_type
)))
5796 || TYPE_IS_BY_REFERENCE_P (gnu_param_type
))
5798 gnu_param_type
= build_reference_type (gnu_param_type
);
5800 = create_param_decl (gnu_param_name
, gnu_param_type
);
5801 TREE_READONLY (gnu_param
) = 1;
5802 DECL_BY_REF_P (gnu_param
) = 1;
5803 DECL_POINTS_TO_READONLY_P (gnu_param
)
5804 = (Ekind (gnat_param
) == E_In_Parameter
5805 && !Address_Taken (gnat_param
));
5806 Set_Mechanism (gnat_param
, By_Reference
);
5807 Sloc_to_locus (Sloc (gnat_param
),
5808 &DECL_SOURCE_LOCATION (gnu_param
));
5811 /* ??? This is a kludge to support null procedures in spec taking
5812 a parameter with an untagged incomplete type coming from a
5813 limited context. The front-end creates a body without knowing
5814 anything about the non-limited view, which is illegal Ada and
5815 cannot be supported. Create a parameter with a fake type. */
5816 else if (kind
== E_Procedure
5817 && (gnat_decl
= Parent (gnat_subprog
))
5818 && Nkind (gnat_decl
) == N_Procedure_Specification
5819 && Null_Present (gnat_decl
)
5820 && Is_Incomplete_Type (gnat_param_type
))
5821 gnu_param
= create_param_decl (gnu_param_name
, ptr_type_node
);
5825 /* Build a minimal PARM_DECL without DECL_ARG_TYPE so that
5826 Call_to_gnu will stop if it encounters the PARM_DECL. */
5828 = build_decl (input_location
, PARM_DECL
, gnu_param_name
,
5830 associate_subprog_with_dummy_type (gnat_subprog
,
5832 incomplete_profile_p
= true;
5836 /* Otherwise build the parameter declaration normally. */
5840 = gnat_to_gnu_param (gnat_param
, gnu_param_type
, num
== 0,
5841 gnat_subprog
, &cico
);
5843 /* We are returned either a PARM_DECL or a type if no parameter
5844 needs to be passed; in either case, adjust the type. */
5845 if (DECL_P (gnu_param
))
5846 gnu_param_type
= TREE_TYPE (gnu_param
);
5849 gnu_param_type
= gnu_param
;
5850 gnu_param
= NULL_TREE
;
5855 /* If we have a GCC tree for the parameter, register it. */
5856 save_gnu_tree (gnat_param
, NULL_TREE
, false);
5860 = tree_cons (NULL_TREE
, gnu_param_type
, gnu_param_type_list
);
5861 gnu_param_list
= chainon (gnu_param
, gnu_param_list
);
5862 save_gnu_tree (gnat_param
, gnu_param
, false);
5864 /* If a parameter is a pointer, a function may modify memory through
5865 it and thus shouldn't be considered a const function. Also, the
5866 memory may be modified between two calls, so they can't be CSE'ed.
5867 The latter case also handles by-ref parameters. */
5868 if (POINTER_TYPE_P (gnu_param_type
)
5869 || TYPE_IS_FAT_POINTER_P (gnu_param_type
))
5873 /* If the parameter uses the copy-in copy-out mechanism, allocate a field
5874 for it in the return type and register the association. */
5875 if (cico
&& !incomplete_profile_p
)
5879 gnu_cico_return_type
= make_node (RECORD_TYPE
);
5881 /* If this is a function, we also need a field for the
5882 return value to be placed. */
5883 if (!VOID_TYPE_P (gnu_return_type
))
5886 = create_field_decl (get_identifier ("RETVAL"),
5888 gnu_cico_return_type
, NULL_TREE
,
5890 Sloc_to_locus (Sloc (gnat_subprog
),
5891 &DECL_SOURCE_LOCATION (gnu_field
));
5892 gnu_field_list
= gnu_field
;
5894 = tree_cons (gnu_field
, void_type_node
, NULL_TREE
);
5897 TYPE_NAME (gnu_cico_return_type
) = get_identifier ("RETURN");
5898 /* Set a default alignment to speed up accesses. But we should
5899 not increase the size of the structure too much, lest it does
5900 not fit in return registers anymore. */
5901 SET_TYPE_ALIGN (gnu_cico_return_type
,
5902 get_mode_alignment (ptr_mode
));
5906 = create_field_decl (gnu_param_name
, gnu_param_type
,
5907 gnu_cico_return_type
, NULL_TREE
, NULL_TREE
,
5909 Sloc_to_locus (Sloc (gnat_param
),
5910 &DECL_SOURCE_LOCATION (gnu_field
));
5911 DECL_CHAIN (gnu_field
) = gnu_field_list
;
5912 gnu_field_list
= gnu_field
;
5913 gnu_cico_list
= tree_cons (gnu_field
, gnu_param
, gnu_cico_list
);
5917 /* If the subprogram uses the copy-in copy-out mechanism, possibly adjust
5918 and finish up the return type. */
5919 if (gnu_cico_list
&& !incomplete_profile_p
)
5921 /* If we have a CICO list but it has only one entry, we convert
5922 this function into a function that returns this object. */
5923 if (list_length (gnu_cico_list
) == 1)
5924 gnu_cico_return_type
= TREE_TYPE (TREE_PURPOSE (gnu_cico_list
));
5926 /* Do not finalize the return type if the subprogram is stubbed
5927 since structures are incomplete for the back-end. */
5928 else if (Convention (gnat_subprog
) != Convention_Stubbed
)
5930 finish_record_type (gnu_cico_return_type
, nreverse (gnu_field_list
),
5933 /* Try to promote the mode of the return type if it is passed
5934 in registers, again to speed up accesses. */
5935 if (TYPE_MODE (gnu_cico_return_type
) == BLKmode
5936 && !targetm
.calls
.return_in_memory (gnu_cico_return_type
,
5940 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_cico_return_type
));
5941 unsigned int i
= BITS_PER_UNIT
;
5942 scalar_int_mode mode
;
5946 if (int_mode_for_size (i
, 0).exists (&mode
))
5948 SET_TYPE_MODE (gnu_cico_return_type
, mode
);
5949 SET_TYPE_ALIGN (gnu_cico_return_type
,
5950 GET_MODE_ALIGNMENT (mode
));
5951 TYPE_SIZE (gnu_cico_return_type
)
5952 = bitsize_int (GET_MODE_BITSIZE (mode
));
5953 TYPE_SIZE_UNIT (gnu_cico_return_type
)
5954 = size_int (GET_MODE_SIZE (mode
));
5959 rest_of_record_type_compilation (gnu_cico_return_type
);
5962 gnu_return_type
= gnu_cico_return_type
;
5965 /* The lists have been built in reverse. */
5966 gnu_param_type_list
= nreverse (gnu_param_type_list
);
5967 gnu_param_type_list
= chainon (gnu_param_type_list
, void_list_node
);
5968 *param_list
= nreverse (gnu_param_list
);
5969 gnu_cico_list
= nreverse (gnu_cico_list
);
5971 /* If the profile is incomplete, we only set the (temporary) return and
5972 parameter types; otherwise, we build the full type. In either case,
5973 we reuse an already existing GCC tree that we built previously here. */
5974 if (incomplete_profile_p
)
5976 if (gnu_type
&& TREE_CODE (gnu_type
) == FUNCTION_TYPE
)
5979 gnu_type
= make_node (FUNCTION_TYPE
);
5980 TREE_TYPE (gnu_type
) = gnu_return_type
;
5981 TYPE_ARG_TYPES (gnu_type
) = gnu_param_type_list
;
5982 TYPE_RETURN_UNCONSTRAINED_P (gnu_type
) = return_unconstrained_p
;
5983 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type
) = return_by_direct_ref_p
;
5984 TREE_ADDRESSABLE (gnu_type
) = return_by_invisi_ref_p
;
5988 if (gnu_type
&& TREE_CODE (gnu_type
) == FUNCTION_TYPE
)
5990 TREE_TYPE (gnu_type
) = gnu_return_type
;
5991 TYPE_ARG_TYPES (gnu_type
) = gnu_param_type_list
;
5992 TYPE_CI_CO_LIST (gnu_type
) = gnu_cico_list
;
5993 TYPE_RETURN_UNCONSTRAINED_P (gnu_type
) = return_unconstrained_p
;
5994 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type
) = return_by_direct_ref_p
;
5995 TREE_ADDRESSABLE (gnu_type
) = return_by_invisi_ref_p
;
5996 TYPE_CANONICAL (gnu_type
) = gnu_type
;
5997 layout_type (gnu_type
);
6002 = build_function_type (gnu_return_type
, gnu_param_type_list
);
6004 /* GNU_TYPE may be shared since GCC hashes types. Unshare it if it
6005 has a different TYPE_CI_CO_LIST or flags. */
6006 if (!fntype_same_flags_p (gnu_type
, gnu_cico_list
,
6007 return_unconstrained_p
,
6008 return_by_direct_ref_p
,
6009 return_by_invisi_ref_p
))
6011 gnu_type
= copy_type (gnu_type
);
6012 TYPE_CI_CO_LIST (gnu_type
) = gnu_cico_list
;
6013 TYPE_RETURN_UNCONSTRAINED_P (gnu_type
) = return_unconstrained_p
;
6014 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type
) = return_by_direct_ref_p
;
6015 TREE_ADDRESSABLE (gnu_type
) = return_by_invisi_ref_p
;
6020 gnu_type
= change_qualified_type (gnu_type
, TYPE_QUAL_CONST
);
6022 if (No_Return (gnat_subprog
))
6023 gnu_type
= change_qualified_type (gnu_type
, TYPE_QUAL_VOLATILE
);
6025 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
6026 corresponding DECL node and check the parameter association. */
6027 if (Convention (gnat_subprog
) == Convention_Intrinsic
6028 && Present (Interface_Name (gnat_subprog
)))
6030 tree gnu_ext_name
= create_concat_name (gnat_subprog
, NULL
);
6031 tree gnu_builtin_decl
= builtin_decl_for (gnu_ext_name
);
6033 /* If we have a builtin DECL for that function, use it. Check if
6034 the profiles are compatible and warn if they are not. Note that
6035 the checker is expected to post diagnostics in this case. */
6036 if (gnu_builtin_decl
)
6038 intrin_binding_t inb
6039 = { gnat_subprog
, gnu_type
, TREE_TYPE (gnu_builtin_decl
) };
6041 if (!intrin_profiles_compatible_p (&inb
))
6043 ("?profile of& doesn''t match the builtin it binds!",
6046 return gnu_builtin_decl
;
6049 /* Inability to find the builtin DECL most often indicates a genuine
6050 mistake, but imports of unregistered intrinsics are sometimes used
6051 on purpose to allow hooking in alternate bodies; we post a warning
6052 conditioned on Wshadow in this case, to let developers be notified
6053 on demand without risking false positives with common default sets
6056 post_error ("?gcc intrinsic not found for&!", gnat_subprog
);
6063 /* Return the external name for GNAT_SUBPROG given its entity name. */
6066 gnu_ext_name_for_subprog (Entity_Id gnat_subprog
, tree gnu_entity_name
)
6068 tree gnu_ext_name
= create_concat_name (gnat_subprog
, NULL
);
6070 /* If there was no specified Interface_Name and the external and
6071 internal names of the subprogram are the same, only use the
6072 internal name to allow disambiguation of nested subprograms. */
6073 if (No (Interface_Name (gnat_subprog
)) && gnu_ext_name
== gnu_entity_name
)
6074 gnu_ext_name
= NULL_TREE
;
6076 return gnu_ext_name
;
6079 /* Like build_qualified_type, but TYPE_QUALS is added to the existing
6080 qualifiers on TYPE. */
6083 change_qualified_type (tree type
, int type_quals
)
6085 /* Qualifiers must be put on the associated array type. */
6086 if (TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
6089 return build_qualified_type (type
, TYPE_QUALS (type
) | type_quals
);
6092 /* Set TYPE_NONALIASED_COMPONENT on an array type built by means of
6093 build_nonshared_array_type. */
6096 set_nonaliased_component_on_array_type (tree type
)
6098 TYPE_NONALIASED_COMPONENT (type
) = 1;
6099 TYPE_NONALIASED_COMPONENT (TYPE_CANONICAL (type
)) = 1;
6102 /* Set TYPE_REVERSE_STORAGE_ORDER on an array type built by means of
6103 build_nonshared_array_type. */
6106 set_reverse_storage_order_on_array_type (tree type
)
6108 TYPE_REVERSE_STORAGE_ORDER (type
) = 1;
6109 TYPE_REVERSE_STORAGE_ORDER (TYPE_CANONICAL (type
)) = 1;
6112 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
6115 same_discriminant_p (Entity_Id discr1
, Entity_Id discr2
)
6117 while (Present (Corresponding_Discriminant (discr1
)))
6118 discr1
= Corresponding_Discriminant (discr1
);
6120 while (Present (Corresponding_Discriminant (discr2
)))
6121 discr2
= Corresponding_Discriminant (discr2
);
6124 Original_Record_Component (discr1
) == Original_Record_Component (discr2
);
6127 /* Return true if the array type GNU_TYPE, which represents a dimension of
6128 GNAT_TYPE, has a non-aliased component in the back-end sense. */
6131 array_type_has_nonaliased_component (tree gnu_type
, Entity_Id gnat_type
)
6133 /* If the array type is not the innermost dimension of the GNAT type,
6134 then it has a non-aliased component. */
6135 if (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
6136 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
6139 /* If the array type has an aliased component in the front-end sense,
6140 then it also has an aliased component in the back-end sense. */
6141 if (Has_Aliased_Components (gnat_type
))
6144 /* If this is a derived type, then it has a non-aliased component if
6145 and only if its parent type also has one. */
6146 if (Is_Derived_Type (gnat_type
))
6148 tree gnu_parent_type
= gnat_to_gnu_type (Etype (gnat_type
));
6150 if (TREE_CODE (gnu_parent_type
) == UNCONSTRAINED_ARRAY_TYPE
)
6152 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type
))));
6153 for (index
= Number_Dimensions (gnat_type
) - 1; index
> 0; index
--)
6154 gnu_parent_type
= TREE_TYPE (gnu_parent_type
);
6155 return TYPE_NONALIASED_COMPONENT (gnu_parent_type
);
6158 /* Otherwise, rely exclusively on properties of the element type. */
6159 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type
));
6162 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
6165 compile_time_known_address_p (Node_Id gnat_address
)
6167 /* Handle reference to a constant. */
6168 if (Is_Entity_Name (gnat_address
)
6169 && Ekind (Entity (gnat_address
)) == E_Constant
)
6171 gnat_address
= Constant_Value (Entity (gnat_address
));
6172 if (No (gnat_address
))
6176 /* Catch System'To_Address. */
6177 if (Nkind (gnat_address
) == N_Unchecked_Type_Conversion
)
6178 gnat_address
= Expression (gnat_address
);
6180 return Compile_Time_Known_Value (gnat_address
);
6183 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
6184 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
6187 cannot_be_superflat (Node_Id gnat_range
)
6189 Node_Id gnat_lb
= Low_Bound (gnat_range
), gnat_hb
= High_Bound (gnat_range
);
6190 Node_Id scalar_range
;
6191 tree gnu_lb
, gnu_hb
, gnu_lb_minus_one
;
6193 /* If the low bound is not constant, try to find an upper bound. */
6194 while (Nkind (gnat_lb
) != N_Integer_Literal
6195 && (Ekind (Etype (gnat_lb
)) == E_Signed_Integer_Subtype
6196 || Ekind (Etype (gnat_lb
)) == E_Modular_Integer_Subtype
)
6197 && (scalar_range
= Scalar_Range (Etype (gnat_lb
)))
6198 && (Nkind (scalar_range
) == N_Signed_Integer_Type_Definition
6199 || Nkind (scalar_range
) == N_Range
))
6200 gnat_lb
= High_Bound (scalar_range
);
6202 /* If the high bound is not constant, try to find a lower bound. */
6203 while (Nkind (gnat_hb
) != N_Integer_Literal
6204 && (Ekind (Etype (gnat_hb
)) == E_Signed_Integer_Subtype
6205 || Ekind (Etype (gnat_hb
)) == E_Modular_Integer_Subtype
)
6206 && (scalar_range
= Scalar_Range (Etype (gnat_hb
)))
6207 && (Nkind (scalar_range
) == N_Signed_Integer_Type_Definition
6208 || Nkind (scalar_range
) == N_Range
))
6209 gnat_hb
= Low_Bound (scalar_range
);
6211 /* If we have failed to find constant bounds, punt. */
6212 if (Nkind (gnat_lb
) != N_Integer_Literal
6213 || Nkind (gnat_hb
) != N_Integer_Literal
)
6216 /* We need at least a signed 64-bit type to catch most cases. */
6217 gnu_lb
= UI_To_gnu (Intval (gnat_lb
), sbitsizetype
);
6218 gnu_hb
= UI_To_gnu (Intval (gnat_hb
), sbitsizetype
);
6219 if (TREE_OVERFLOW (gnu_lb
) || TREE_OVERFLOW (gnu_hb
))
6222 /* If the low bound is the smallest integer, nothing can be smaller. */
6223 gnu_lb_minus_one
= size_binop (MINUS_EXPR
, gnu_lb
, sbitsize_one_node
);
6224 if (TREE_OVERFLOW (gnu_lb_minus_one
))
6227 return !tree_int_cst_lt (gnu_hb
, gnu_lb_minus_one
);
6230 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
6233 constructor_address_p (tree gnu_expr
)
6235 while (TREE_CODE (gnu_expr
) == NOP_EXPR
6236 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
6237 || TREE_CODE (gnu_expr
) == NON_LVALUE_EXPR
)
6238 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
6240 return (TREE_CODE (gnu_expr
) == ADDR_EXPR
6241 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == CONSTRUCTOR
);
6244 /* Return true if the size in units represented by GNU_SIZE can be handled by
6245 an allocation. If STATIC_P is true, consider only what can be done with a
6246 static allocation. */
6249 allocatable_size_p (tree gnu_size
, bool static_p
)
6251 /* We can allocate a fixed size if it is a valid for the middle-end. */
6252 if (TREE_CODE (gnu_size
) == INTEGER_CST
)
6253 return valid_constant_size_p (gnu_size
);
6255 /* We can allocate a variable size if this isn't a static allocation. */
6260 /* Return true if GNU_EXPR needs a conversion to GNU_TYPE when used as the
6261 initial value of an object of GNU_TYPE. */
6264 initial_value_needs_conversion (tree gnu_type
, tree gnu_expr
)
6266 /* Do not convert if the object's type is unconstrained because this would
6267 generate useless evaluations of the CONSTRUCTOR to compute the size. */
6268 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
6269 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
6272 /* Do not convert if the object's type is a padding record whose field is of
6273 self-referential size because we want to copy only the actual data. */
6274 if (type_is_padding_self_referential (gnu_type
))
6277 /* Do not convert a call to a function that returns with variable size since
6278 we want to use the return slot optimization in this case. */
6279 if (TREE_CODE (gnu_expr
) == CALL_EXPR
6280 && return_type_with_variable_size_p (TREE_TYPE (gnu_expr
)))
6283 /* Do not convert to a record type with a variant part from a record type
6284 without one, to keep the object simpler. */
6285 if (TREE_CODE (gnu_type
) == RECORD_TYPE
6286 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
6287 && get_variant_part (gnu_type
)
6288 && !get_variant_part (TREE_TYPE (gnu_expr
)))
6291 /* In all the other cases, convert the expression to the object's type. */
6295 /* Given GNAT_ENTITY, elaborate all expressions that are required to
6296 be elaborated at the point of its definition, but do nothing else. */
6299 elaborate_entity (Entity_Id gnat_entity
)
6301 switch (Ekind (gnat_entity
))
6303 case E_Signed_Integer_Subtype
:
6304 case E_Modular_Integer_Subtype
:
6305 case E_Enumeration_Subtype
:
6306 case E_Ordinary_Fixed_Point_Subtype
:
6307 case E_Decimal_Fixed_Point_Subtype
:
6308 case E_Floating_Point_Subtype
:
6310 Node_Id gnat_lb
= Type_Low_Bound (gnat_entity
);
6311 Node_Id gnat_hb
= Type_High_Bound (gnat_entity
);
6313 /* ??? Tests to avoid Constraint_Error in static expressions
6314 are needed until after the front stops generating bogus
6315 conversions on bounds of real types. */
6316 if (!Raises_Constraint_Error (gnat_lb
))
6317 elaborate_expression (gnat_lb
, gnat_entity
, "L", true, false,
6318 Needs_Debug_Info (gnat_entity
));
6319 if (!Raises_Constraint_Error (gnat_hb
))
6320 elaborate_expression (gnat_hb
, gnat_entity
, "U", true, false,
6321 Needs_Debug_Info (gnat_entity
));
6325 case E_Record_Subtype
:
6326 case E_Private_Subtype
:
6327 case E_Limited_Private_Subtype
:
6328 case E_Record_Subtype_With_Private
:
6329 if (Has_Discriminants (gnat_entity
) && Is_Constrained (gnat_entity
))
6331 Node_Id gnat_discriminant_expr
;
6332 Entity_Id gnat_field
;
6335 = First_Discriminant (Implementation_Base_Type (gnat_entity
)),
6336 gnat_discriminant_expr
6337 = First_Elmt (Discriminant_Constraint (gnat_entity
));
6338 Present (gnat_field
);
6339 gnat_field
= Next_Discriminant (gnat_field
),
6340 gnat_discriminant_expr
= Next_Elmt (gnat_discriminant_expr
))
6341 /* Ignore access discriminants. */
6342 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr
))))
6343 elaborate_expression (Node (gnat_discriminant_expr
),
6344 gnat_entity
, get_entity_char (gnat_field
),
6345 true, false, false);
6352 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
6353 NAME, ARGS and ERROR_POINT. */
6356 prepend_one_attribute (struct attrib
**attr_list
,
6357 enum attrib_type attrib_type
,
6360 Node_Id attr_error_point
)
6362 struct attrib
* attr
= (struct attrib
*) xmalloc (sizeof (struct attrib
));
6364 attr
->type
= attrib_type
;
6365 attr
->name
= attr_name
;
6366 attr
->args
= attr_args
;
6367 attr
->error_point
= attr_error_point
;
6369 attr
->next
= *attr_list
;
6373 /* Prepend to ATTR_LIST an entry for an attribute provided by GNAT_PRAGMA. */
6376 prepend_one_attribute_pragma (struct attrib
**attr_list
, Node_Id gnat_pragma
)
6378 const Node_Id gnat_arg
= Pragma_Argument_Associations (gnat_pragma
);
6379 tree gnu_arg0
= NULL_TREE
, gnu_arg1
= NULL_TREE
;
6380 enum attrib_type etype
;
6382 /* Map the pragma at hand. Skip if this isn't one we know how to handle. */
6383 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_pragma
))))
6385 case Pragma_Machine_Attribute
:
6386 etype
= ATTR_MACHINE_ATTRIBUTE
;
6389 case Pragma_Linker_Alias
:
6390 etype
= ATTR_LINK_ALIAS
;
6393 case Pragma_Linker_Section
:
6394 etype
= ATTR_LINK_SECTION
;
6397 case Pragma_Linker_Constructor
:
6398 etype
= ATTR_LINK_CONSTRUCTOR
;
6401 case Pragma_Linker_Destructor
:
6402 etype
= ATTR_LINK_DESTRUCTOR
;
6405 case Pragma_Weak_External
:
6406 etype
= ATTR_WEAK_EXTERNAL
;
6409 case Pragma_Thread_Local_Storage
:
6410 etype
= ATTR_THREAD_LOCAL_STORAGE
;
6417 /* See what arguments we have and turn them into GCC trees for attribute
6418 handlers. These expect identifier for strings. We handle at most two
6419 arguments and static expressions only. */
6420 if (Present (gnat_arg
) && Present (First (gnat_arg
)))
6422 Node_Id gnat_arg0
= Next (First (gnat_arg
));
6423 Node_Id gnat_arg1
= Empty
;
6425 if (Present (gnat_arg0
)
6426 && Is_OK_Static_Expression (Expression (gnat_arg0
)))
6428 gnu_arg0
= gnat_to_gnu (Expression (gnat_arg0
));
6430 if (TREE_CODE (gnu_arg0
) == STRING_CST
)
6432 gnu_arg0
= get_identifier (TREE_STRING_POINTER (gnu_arg0
));
6433 if (IDENTIFIER_LENGTH (gnu_arg0
) == 0)
6437 gnat_arg1
= Next (gnat_arg0
);
6440 if (Present (gnat_arg1
)
6441 && Is_OK_Static_Expression (Expression (gnat_arg1
)))
6443 gnu_arg1
= gnat_to_gnu (Expression (gnat_arg1
));
6445 if (TREE_CODE (gnu_arg1
) == STRING_CST
)
6446 gnu_arg1
= get_identifier (TREE_STRING_POINTER (gnu_arg1
));
6450 /* Prepend to the list. Make a list of the argument we might have, as GCC
6452 prepend_one_attribute (attr_list
, etype
, gnu_arg0
,
6454 ? build_tree_list (NULL_TREE
, gnu_arg1
) : NULL_TREE
,
6455 Present (Next (First (gnat_arg
)))
6456 ? Expression (Next (First (gnat_arg
))) : gnat_pragma
);
6459 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
6462 prepend_attributes (struct attrib
**attr_list
, Entity_Id gnat_entity
)
6466 /* Attributes are stored as Representation Item pragmas. */
6467 for (gnat_temp
= First_Rep_Item (gnat_entity
);
6468 Present (gnat_temp
);
6469 gnat_temp
= Next_Rep_Item (gnat_temp
))
6470 if (Nkind (gnat_temp
) == N_Pragma
)
6471 prepend_one_attribute_pragma (attr_list
, gnat_temp
);
6474 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6475 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6476 return the GCC tree to use for that expression. S is the suffix to use
6477 if a variable needs to be created and DEFINITION is true if this is done
6478 for a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6479 otherwise, we are just elaborating the expression for side-effects. If
6480 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6481 isn't needed for code generation. */
6484 elaborate_expression (Node_Id gnat_expr
, Entity_Id gnat_entity
, const char *s
,
6485 bool definition
, bool need_value
, bool need_debug
)
6489 /* If we already elaborated this expression (e.g. it was involved
6490 in the definition of a private type), use the old value. */
6491 if (present_gnu_tree (gnat_expr
))
6492 return get_gnu_tree (gnat_expr
);
6494 /* If we don't need a value and this is static or a discriminant,
6495 we don't need to do anything. */
6497 && (Is_OK_Static_Expression (gnat_expr
)
6498 || (Nkind (gnat_expr
) == N_Identifier
6499 && Ekind (Entity (gnat_expr
)) == E_Discriminant
)))
6502 /* If it's a static expression, we don't need a variable for debugging. */
6503 if (need_debug
&& Is_OK_Static_Expression (gnat_expr
))
6506 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6507 gnu_expr
= elaborate_expression_1 (gnat_to_gnu (gnat_expr
), gnat_entity
, s
,
6508 definition
, need_debug
);
6510 /* Save the expression in case we try to elaborate this entity again. Since
6511 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6512 if (!CONTAINS_PLACEHOLDER_P (gnu_expr
))
6513 save_gnu_tree (gnat_expr
, gnu_expr
, true);
6515 return need_value
? gnu_expr
: error_mark_node
;
6518 /* Similar, but take a GNU expression and always return a result. */
6521 elaborate_expression_1 (tree gnu_expr
, Entity_Id gnat_entity
, const char *s
,
6522 bool definition
, bool need_debug
)
6524 const bool expr_public_p
= Is_Public (gnat_entity
);
6525 const bool expr_global_p
= expr_public_p
|| global_bindings_p ();
6526 bool expr_variable_p
, use_variable
;
6528 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6529 that an expression cannot contain both a discriminant and a variable. */
6530 if (CONTAINS_PLACEHOLDER_P (gnu_expr
))
6533 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6534 a variable that is initialized to contain the expression when the package
6535 containing the definition is elaborated. If this entity is defined at top
6536 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6537 if this is necessary. */
6538 if (TREE_CONSTANT (gnu_expr
))
6539 expr_variable_p
= false;
6542 /* Skip any conversions and simple constant arithmetics to see if the
6543 expression is based on a read-only variable. */
6544 tree inner
= remove_conversions (gnu_expr
, true);
6546 inner
= skip_simple_constant_arithmetic (inner
);
6548 if (handled_component_p (inner
))
6549 inner
= get_inner_constant_reference (inner
);
6553 && TREE_CODE (inner
) == VAR_DECL
6554 && (TREE_READONLY (inner
) || DECL_READONLY_ONCE_ELAB (inner
)));
6557 /* We only need to use the variable if we are in a global context since GCC
6558 can do the right thing in the local case. However, when not optimizing,
6559 use it for bounds of loop iteration scheme to avoid code duplication. */
6560 use_variable
= expr_variable_p
6564 && Is_Itype (gnat_entity
)
6565 && Nkind (Associated_Node_For_Itype (gnat_entity
))
6566 == N_Loop_Parameter_Specification
));
6568 /* Now create it, possibly only for debugging purposes. */
6569 if (use_variable
|| need_debug
)
6571 /* The following variable creation can happen when processing the body
6572 of subprograms that are defined out of the extended main unit and
6573 inlined. In this case, we are not at the global scope, and thus the
6574 new variable must not be tagged "external", as we used to do here as
6575 soon as DEFINITION was false. */
6577 = create_var_decl (create_concat_name (gnat_entity
, s
), NULL_TREE
,
6578 TREE_TYPE (gnu_expr
), gnu_expr
, true,
6579 expr_public_p
, !definition
&& expr_global_p
,
6580 expr_global_p
, false, true, need_debug
,
6583 /* Using this variable at debug time (if need_debug is true) requires a
6584 proper location. The back-end will compute a location for this
6585 variable only if the variable is used by the generated code.
6586 Returning the variable ensures the caller will use it in generated
6587 code. Note that there is no need for a location if the debug info
6588 contains an integer constant.
6589 TODO: when the encoding-based debug scheme is dropped, move this
6590 condition to the top-level IF block: we will not need to create a
6591 variable anymore in such cases, then. */
6592 if (use_variable
|| (need_debug
&& !TREE_CONSTANT (gnu_expr
)))
6596 return expr_variable_p
? gnat_save_expr (gnu_expr
) : gnu_expr
;
6599 /* Similar, but take an alignment factor and make it explicit in the tree. */
6602 elaborate_expression_2 (tree gnu_expr
, Entity_Id gnat_entity
, const char *s
,
6603 bool definition
, bool need_debug
, unsigned int align
)
6605 tree unit_align
= size_int (align
/ BITS_PER_UNIT
);
6607 size_binop (MULT_EXPR
,
6608 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR
,
6611 gnat_entity
, s
, definition
,
6616 /* Structure to hold internal data for elaborate_reference. */
6625 /* Wrapper function around elaborate_expression_1 for elaborate_reference. */
6628 elaborate_reference_1 (tree ref
, void *data
)
6630 struct er_data
*er
= (struct er_data
*)data
;
6633 /* This is what elaborate_expression_1 does if NEED_DEBUG is false. */
6634 if (TREE_CONSTANT (ref
))
6637 /* If this is a COMPONENT_REF of a fat pointer, elaborate the entire fat
6638 pointer. This may be more efficient, but will also allow us to more
6639 easily find the match for the PLACEHOLDER_EXPR. */
6640 if (TREE_CODE (ref
) == COMPONENT_REF
6641 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (ref
, 0))))
6642 return build3 (COMPONENT_REF
, TREE_TYPE (ref
),
6643 elaborate_reference_1 (TREE_OPERAND (ref
, 0), data
),
6644 TREE_OPERAND (ref
, 1), NULL_TREE
);
6646 sprintf (suffix
, "EXP%d", ++er
->n
);
6648 elaborate_expression_1 (ref
, er
->entity
, suffix
, er
->definition
, false);
6651 /* Elaborate the reference REF to be used as renamed object for GNAT_ENTITY.
6652 DEFINITION is true if this is done for a definition of GNAT_ENTITY and
6653 INIT is set to the first arm of a COMPOUND_EXPR present in REF, if any. */
6656 elaborate_reference (tree ref
, Entity_Id gnat_entity
, bool definition
,
6659 struct er_data er
= { gnat_entity
, definition
, 0 };
6660 return gnat_rewrite_reference (ref
, elaborate_reference_1
, &er
, init
);
6663 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6664 the value passed against the list of choices. */
6667 choices_to_gnu (tree operand
, Node_Id choices
)
6671 tree result
= boolean_false_node
;
6672 tree this_test
, low
= 0, high
= 0, single
= 0;
6674 for (choice
= First (choices
); Present (choice
); choice
= Next (choice
))
6676 switch (Nkind (choice
))
6679 low
= gnat_to_gnu (Low_Bound (choice
));
6680 high
= gnat_to_gnu (High_Bound (choice
));
6683 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6684 build_binary_op (GE_EXPR
, boolean_type_node
,
6685 operand
, low
, true),
6686 build_binary_op (LE_EXPR
, boolean_type_node
,
6687 operand
, high
, true),
6692 case N_Subtype_Indication
:
6693 gnat_temp
= Range_Expression (Constraint (choice
));
6694 low
= gnat_to_gnu (Low_Bound (gnat_temp
));
6695 high
= gnat_to_gnu (High_Bound (gnat_temp
));
6698 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6699 build_binary_op (GE_EXPR
, boolean_type_node
,
6700 operand
, low
, true),
6701 build_binary_op (LE_EXPR
, boolean_type_node
,
6702 operand
, high
, true),
6707 case N_Expanded_Name
:
6708 /* This represents either a subtype range, an enumeration
6709 literal, or a constant Ekind says which. If an enumeration
6710 literal or constant, fall through to the next case. */
6711 if (Ekind (Entity (choice
)) != E_Enumeration_Literal
6712 && Ekind (Entity (choice
)) != E_Constant
)
6714 tree type
= gnat_to_gnu_type (Entity (choice
));
6716 low
= TYPE_MIN_VALUE (type
);
6717 high
= TYPE_MAX_VALUE (type
);
6720 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6721 build_binary_op (GE_EXPR
, boolean_type_node
,
6722 operand
, low
, true),
6723 build_binary_op (LE_EXPR
, boolean_type_node
,
6724 operand
, high
, true),
6729 /* ... fall through ... */
6731 case N_Character_Literal
:
6732 case N_Integer_Literal
:
6733 single
= gnat_to_gnu (choice
);
6734 this_test
= build_binary_op (EQ_EXPR
, boolean_type_node
, operand
,
6738 case N_Others_Choice
:
6739 this_test
= boolean_true_node
;
6746 if (result
== boolean_false_node
)
6749 result
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, result
,
6756 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6757 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6760 adjust_packed (tree field_type
, tree record_type
, int packed
)
6762 /* If the field contains an item of variable size, we cannot pack it
6763 because we cannot create temporaries of non-fixed size in case
6764 we need to take the address of the field. See addressable_p and
6765 the notes on the addressability issues for further details. */
6766 if (type_has_variable_size (field_type
))
6769 /* In the other cases, we can honor the packing. */
6773 /* If the alignment of the record is specified and the field type
6774 is over-aligned, request Storage_Unit alignment for the field. */
6775 if (TYPE_ALIGN (record_type
)
6776 && TYPE_ALIGN (field_type
) > TYPE_ALIGN (record_type
))
6779 /* Likewise if the maximum alignment of the record is specified. */
6780 if (TYPE_MAX_ALIGN (record_type
)
6781 && TYPE_ALIGN (field_type
) > TYPE_MAX_ALIGN (record_type
))
6787 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6788 placed in GNU_RECORD_TYPE.
6790 PACKED is 1 if the enclosing record is packed or -1 if the enclosing
6791 record has Component_Alignment of Storage_Unit.
6793 DEFINITION is true if this field is for a record being defined.
6795 DEBUG_INFO_P is true if we need to write debug information for types
6796 that we may create in the process. */
6799 gnat_to_gnu_field (Entity_Id gnat_field
, tree gnu_record_type
, int packed
,
6800 bool definition
, bool debug_info_p
)
6802 const Entity_Id gnat_record_type
= Underlying_Type (Scope (gnat_field
));
6803 const Entity_Id gnat_field_type
= Etype (gnat_field
);
6804 const bool is_atomic
6805 = (Is_Atomic_Or_VFA (gnat_field
) || Is_Atomic_Or_VFA (gnat_field_type
));
6806 const bool is_aliased
= Is_Aliased (gnat_field
);
6807 const bool is_independent
6808 = (Is_Independent (gnat_field
) || Is_Independent (gnat_field_type
));
6809 const bool is_volatile
6810 = (Treat_As_Volatile (gnat_field
) || Treat_As_Volatile (gnat_field_type
));
6811 const bool is_strict_alignment
= Strict_Alignment (gnat_field_type
);
6812 /* We used to consider that volatile fields also require strict alignment,
6813 but that was an interpolation and would cause us to reject a pragma
6814 volatile on a packed record type containing boolean components, while
6815 there is no basis to do so in the RM. In such cases, the writes will
6816 involve load-modify-store sequences, but that's OK for volatile. The
6817 only constraint is the implementation advice whereby only the bits of
6818 the components should be accessed if they both start and end on byte
6819 boundaries, but that should be guaranteed by the GCC memory model. */
6820 const bool needs_strict_alignment
6821 = (is_atomic
|| is_aliased
|| is_independent
|| is_strict_alignment
);
6822 tree gnu_field_type
= gnat_to_gnu_type (gnat_field_type
);
6823 tree gnu_field_id
= get_entity_name (gnat_field
);
6824 tree gnu_field
, gnu_size
, gnu_pos
;
6826 /* If this field requires strict alignment, we cannot pack it because
6827 it would very likely be under-aligned in the record. */
6828 if (needs_strict_alignment
)
6831 packed
= adjust_packed (gnu_field_type
, gnu_record_type
, packed
);
6833 /* If a size is specified, use it. Otherwise, if the record type is packed,
6834 use the official RM size. See "Handling of Type'Size Values" in Einfo
6835 for further details. */
6836 if (Known_Esize (gnat_field
))
6837 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6838 gnat_field
, FIELD_DECL
, false, true);
6839 else if (packed
== 1)
6840 gnu_size
= validate_size (RM_Size (gnat_field_type
), gnu_field_type
,
6841 gnat_field
, FIELD_DECL
, false, true);
6843 gnu_size
= NULL_TREE
;
6845 /* If we have a specified size that is smaller than that of the field's type,
6846 or a position is specified, and the field's type is a record that doesn't
6847 require strict alignment, see if we can get either an integral mode form
6848 of the type or a smaller form. If we can, show a size was specified for
6849 the field if there wasn't one already, so we know to make this a bitfield
6850 and avoid making things wider.
6852 Changing to an integral mode form is useful when the record is packed as
6853 we can then place the field at a non-byte-aligned position and so achieve
6854 tighter packing. This is in addition required if the field shares a byte
6855 with another field and the front-end lets the back-end handle the access
6856 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6858 Changing to a smaller form is required if the specified size is smaller
6859 than that of the field's type and the type contains sub-fields that are
6860 padded, in order to avoid generating accesses to these sub-fields that
6861 are wider than the field.
6863 We avoid the transformation if it is not required or potentially useful,
6864 as it might entail an increase of the field's alignment and have ripple
6865 effects on the outer record type. A typical case is a field known to be
6866 byte-aligned and not to share a byte with another field. */
6867 if (!needs_strict_alignment
6868 && RECORD_OR_UNION_TYPE_P (gnu_field_type
)
6869 && !TYPE_FAT_POINTER_P (gnu_field_type
)
6870 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type
))
6873 && (tree_int_cst_lt (gnu_size
, TYPE_SIZE (gnu_field_type
))
6874 || (Present (Component_Clause (gnat_field
))
6875 && !(UI_To_Int (Component_Bit_Offset (gnat_field
))
6876 % BITS_PER_UNIT
== 0
6877 && value_factor_p (gnu_size
, BITS_PER_UNIT
)))))))
6879 tree gnu_packable_type
= make_packable_type (gnu_field_type
, true);
6880 if (gnu_packable_type
!= gnu_field_type
)
6882 gnu_field_type
= gnu_packable_type
;
6884 gnu_size
= rm_size (gnu_field_type
);
6888 if (Is_Atomic_Or_VFA (gnat_field
))
6889 check_ok_for_atomic_type (gnu_field_type
, gnat_field
, false);
6891 if (Present (Component_Clause (gnat_field
)))
6893 Node_Id gnat_clause
= Component_Clause (gnat_field
);
6894 Entity_Id gnat_parent
= Parent_Subtype (gnat_record_type
);
6896 gnu_pos
= UI_To_gnu (Component_Bit_Offset (gnat_field
), bitsizetype
);
6897 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6898 gnat_field
, FIELD_DECL
, false, true);
6900 /* Ensure the position does not overlap with the parent subtype, if there
6901 is one. This test is omitted if the parent of the tagged type has a
6902 full rep clause since, in this case, component clauses are allowed to
6903 overlay the space allocated for the parent type and the front-end has
6904 checked that there are no overlapping components. */
6905 if (Present (gnat_parent
) && !Is_Fully_Repped_Tagged_Type (gnat_parent
))
6907 tree gnu_parent
= gnat_to_gnu_type (gnat_parent
);
6909 if (TREE_CODE (TYPE_SIZE (gnu_parent
)) == INTEGER_CST
6910 && tree_int_cst_lt (gnu_pos
, TYPE_SIZE (gnu_parent
)))
6912 ("offset of& must be beyond parent{, minimum allowed is ^}",
6913 Position (gnat_clause
), gnat_field
, TYPE_SIZE_UNIT (gnu_parent
));
6916 /* If this field needs strict alignment, make sure that the record is
6917 sufficiently aligned and that the position and size are consistent
6918 with the type. But don't do it if we are just annotating types and
6919 the field's type is tagged, since tagged types aren't fully laid out
6920 in this mode. Also, note that atomic implies volatile so the inner
6921 test sequences ordering is significant here. */
6922 if (needs_strict_alignment
6923 && !(type_annotate_only
&& Is_Tagged_Type (gnat_field_type
)))
6925 const unsigned int type_align
= TYPE_ALIGN (gnu_field_type
);
6927 if (TYPE_ALIGN (gnu_record_type
) < type_align
)
6928 SET_TYPE_ALIGN (gnu_record_type
, type_align
);
6930 /* If the position is not a multiple of the alignment of the type,
6931 then error out and reset the position. */
6932 if (!integer_zerop (size_binop (TRUNC_MOD_EXPR
, gnu_pos
,
6933 bitsize_int (type_align
))))
6938 s
= "position of atomic field& must be multiple of ^ bits";
6939 else if (is_aliased
)
6940 s
= "position of aliased field& must be multiple of ^ bits";
6941 else if (is_independent
)
6942 s
= "position of independent field& must be multiple of ^ bits";
6943 else if (is_strict_alignment
)
6944 s
= "position of & with aliased or tagged part must be"
6945 " multiple of ^ bits";
6949 post_error_ne_num (s
, First_Bit (gnat_clause
), gnat_field
,
6951 gnu_pos
= NULL_TREE
;
6956 tree gnu_type_size
= TYPE_SIZE (gnu_field_type
);
6957 const int cmp
= tree_int_cst_compare (gnu_size
, gnu_type_size
);
6959 /* If the size is lower than that of the type, or greater for
6960 atomic and aliased, then error out and reset the size. */
6961 if (cmp
< 0 || (cmp
> 0 && (is_atomic
|| is_aliased
)))
6966 s
= "size of atomic field& must be ^ bits";
6967 else if (is_aliased
)
6968 s
= "size of aliased field& must be ^ bits";
6969 else if (is_independent
)
6970 s
= "size of independent field& must be at least ^ bits";
6971 else if (is_strict_alignment
)
6972 s
= "size of & with aliased or tagged part must be"
6977 post_error_ne_tree (s
, Last_Bit (gnat_clause
), gnat_field
,
6979 gnu_size
= NULL_TREE
;
6982 /* Likewise if the size is not a multiple of a byte, */
6983 else if (!integer_zerop (size_binop (TRUNC_MOD_EXPR
, gnu_size
,
6984 bitsize_unit_node
)))
6989 s
= "size of independent field& must be multiple of"
6991 else if (is_strict_alignment
)
6992 s
= "size of & with aliased or tagged part must be"
6993 " multiple of Storage_Unit";
6997 post_error_ne (s
, Last_Bit (gnat_clause
), gnat_field
);
6998 gnu_size
= NULL_TREE
;
7004 /* If the record has rep clauses and this is the tag field, make a rep
7005 clause for it as well. */
7006 else if (Has_Specified_Layout (gnat_record_type
)
7007 && Chars (gnat_field
) == Name_uTag
)
7009 gnu_pos
= bitsize_zero_node
;
7010 gnu_size
= TYPE_SIZE (gnu_field_type
);
7015 gnu_pos
= NULL_TREE
;
7017 /* If we are packing the record and the field is BLKmode, round the
7018 size up to a byte boundary. */
7019 if (packed
&& TYPE_MODE (gnu_field_type
) == BLKmode
&& gnu_size
)
7020 gnu_size
= round_up (gnu_size
, BITS_PER_UNIT
);
7023 /* We need to make the size the maximum for the type if it is
7024 self-referential and an unconstrained type. In that case, we can't
7025 pack the field since we can't make a copy to align it. */
7026 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
7028 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type
))
7029 && !Is_Constrained (Underlying_Type (gnat_field_type
)))
7031 gnu_size
= max_size (TYPE_SIZE (gnu_field_type
), true);
7035 /* If a size is specified, adjust the field's type to it. */
7038 tree orig_field_type
;
7040 /* If the field's type is justified modular, we would need to remove
7041 the wrapper to (better) meet the layout requirements. However we
7042 can do so only if the field is not aliased to preserve the unique
7043 layout, if it has the same storage order as the enclosing record
7044 and if the prescribed size is not greater than that of the packed
7045 array to preserve the justification. */
7046 if (!needs_strict_alignment
7047 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
7048 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
7049 && TYPE_REVERSE_STORAGE_ORDER (gnu_field_type
)
7050 == Reverse_Storage_Order (gnat_record_type
)
7051 && tree_int_cst_compare (gnu_size
, TYPE_ADA_SIZE (gnu_field_type
))
7053 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
7055 /* Similarly if the field's type is a misaligned integral type, but
7056 there is no restriction on the size as there is no justification. */
7057 if (!needs_strict_alignment
7058 && TYPE_IS_PADDING_P (gnu_field_type
)
7059 && INTEGRAL_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_field_type
))))
7060 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
7063 = make_type_from_size (gnu_field_type
, gnu_size
,
7064 Has_Biased_Representation (gnat_field
));
7066 orig_field_type
= gnu_field_type
;
7067 gnu_field_type
= maybe_pad_type (gnu_field_type
, gnu_size
, 0, gnat_field
,
7068 false, false, definition
, true);
7070 /* If a padding record was made, declare it now since it will never be
7071 declared otherwise. This is necessary to ensure that its subtrees
7072 are properly marked. */
7073 if (gnu_field_type
!= orig_field_type
7074 && !DECL_P (TYPE_NAME (gnu_field_type
)))
7075 create_type_decl (TYPE_NAME (gnu_field_type
), gnu_field_type
, true,
7076 debug_info_p
, gnat_field
);
7079 /* Otherwise (or if there was an error), don't specify a position. */
7081 gnu_pos
= NULL_TREE
;
7083 /* If the field's type is a padded type made for a scalar field of a record
7084 type with reverse storage order, we need to propagate the reverse storage
7085 order to the padding type since it is the innermost enclosing aggregate
7086 type around the scalar. */
7087 if (TYPE_IS_PADDING_P (gnu_field_type
)
7088 && TYPE_REVERSE_STORAGE_ORDER (gnu_record_type
)
7089 && Is_Scalar_Type (gnat_field_type
))
7090 gnu_field_type
= set_reverse_storage_order_on_pad_type (gnu_field_type
);
7092 gcc_assert (TREE_CODE (gnu_field_type
) != RECORD_TYPE
7093 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type
));
7095 /* Now create the decl for the field. */
7097 = create_field_decl (gnu_field_id
, gnu_field_type
, gnu_record_type
,
7098 gnu_size
, gnu_pos
, packed
, is_aliased
);
7099 Sloc_to_locus (Sloc (gnat_field
), &DECL_SOURCE_LOCATION (gnu_field
));
7100 DECL_ALIASED_P (gnu_field
) = is_aliased
;
7101 TREE_SIDE_EFFECTS (gnu_field
) = TREE_THIS_VOLATILE (gnu_field
) = is_volatile
;
7103 if (Ekind (gnat_field
) == E_Discriminant
)
7105 DECL_INVARIANT_P (gnu_field
)
7106 = No (Discriminant_Default_Value (gnat_field
));
7107 DECL_DISCRIMINANT_NUMBER (gnu_field
)
7108 = UI_To_gnu (Discriminant_Number (gnat_field
), sizetype
);
7114 /* Return true if at least one member of COMPONENT_LIST needs strict
7118 components_need_strict_alignment (Node_Id component_list
)
7120 Node_Id component_decl
;
7122 for (component_decl
= First_Non_Pragma (Component_Items (component_list
));
7123 Present (component_decl
);
7124 component_decl
= Next_Non_Pragma (component_decl
))
7126 Entity_Id gnat_field
= Defining_Entity (component_decl
);
7128 if (Is_Aliased (gnat_field
))
7131 if (Strict_Alignment (Etype (gnat_field
)))
7138 /* Return true if TYPE is a type with variable size or a padding type with a
7139 field of variable size or a record that has a field with such a type. */
7142 type_has_variable_size (tree type
)
7146 if (!TREE_CONSTANT (TYPE_SIZE (type
)))
7149 if (TYPE_IS_PADDING_P (type
)
7150 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type
))))
7153 if (!RECORD_OR_UNION_TYPE_P (type
))
7156 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
7157 if (type_has_variable_size (TREE_TYPE (field
)))
7163 /* Return true if FIELD is an artificial field. */
7166 field_is_artificial (tree field
)
7168 /* These fields are generated by the front-end proper. */
7169 if (IDENTIFIER_POINTER (DECL_NAME (field
)) [0] == '_')
7172 /* These fields are generated by gigi. */
7173 if (DECL_INTERNAL_P (field
))
7179 /* Return true if FIELD is a non-artificial field with self-referential
7183 field_has_self_size (tree field
)
7185 if (field_is_artificial (field
))
7188 if (DECL_SIZE (field
) && TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
)
7191 return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field
)));
7194 /* Return true if FIELD is a non-artificial field with variable size. */
7197 field_has_variable_size (tree field
)
7199 if (field_is_artificial (field
))
7202 if (DECL_SIZE (field
) && TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
)
7205 return TREE_CODE (TYPE_SIZE (TREE_TYPE (field
))) != INTEGER_CST
;
7208 /* qsort comparer for the bit positions of two record components. */
7211 compare_field_bitpos (const PTR rt1
, const PTR rt2
)
7213 const_tree
const field1
= * (const_tree
const *) rt1
;
7214 const_tree
const field2
= * (const_tree
const *) rt2
;
7216 = tree_int_cst_compare (bit_position (field1
), bit_position (field2
));
7218 return ret
? ret
: (int) (DECL_UID (field1
) - DECL_UID (field2
));
7221 /* Reverse function from gnat_to_gnu_field: return the GNAT field present in
7222 either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE, and
7223 corresponding to the GNU tree GNU_FIELD. */
7226 gnu_field_to_gnat (tree gnu_field
, Node_Id gnat_component_list
,
7227 Entity_Id gnat_record_type
)
7229 Entity_Id gnat_component_decl
, gnat_field
;
7231 if (Present (Component_Items (gnat_component_list
)))
7232 for (gnat_component_decl
7233 = First_Non_Pragma (Component_Items (gnat_component_list
));
7234 Present (gnat_component_decl
);
7235 gnat_component_decl
= Next_Non_Pragma (gnat_component_decl
))
7237 gnat_field
= Defining_Entity (gnat_component_decl
);
7238 if (gnat_to_gnu_field_decl (gnat_field
) == gnu_field
)
7242 if (Has_Discriminants (gnat_record_type
))
7243 for (gnat_field
= First_Stored_Discriminant (gnat_record_type
);
7244 Present (gnat_field
);
7245 gnat_field
= Next_Stored_Discriminant (gnat_field
))
7246 if (gnat_to_gnu_field_decl (gnat_field
) == gnu_field
)
7252 /* Issue a warning for the problematic placement of GNU_FIELD present in
7253 either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE.
7254 IN_VARIANT is true if GNAT_COMPONENT_LIST is the list of a variant.
7255 DO_REORDER is true if fields of GNAT_RECORD_TYPE are being reordered. */
7258 warn_on_field_placement (tree gnu_field
, Node_Id gnat_component_list
,
7259 Entity_Id gnat_record_type
, bool in_variant
,
7264 ? "?variant layout may cause performance issues"
7265 : "?record layout may cause performance issues";
7267 = field_has_self_size (gnu_field
)
7268 ? "?component & whose length depends on a discriminant"
7269 : field_has_variable_size (gnu_field
)
7270 ? "?component & whose length is not fixed"
7271 : "?component & whose length is not multiple of a byte";
7274 ? "?comes too early and was moved down"
7275 : "?comes too early and ought to be moved down";
7276 Entity_Id gnat_field
7277 = gnu_field_to_gnat (gnu_field
, gnat_component_list
, gnat_record_type
);
7279 gcc_assert (Present (gnat_field
));
7281 post_error (msg1
, gnat_field
);
7282 post_error_ne (msg2
, gnat_field
, gnat_field
);
7283 post_error (msg3
, gnat_field
);
7286 /* Structure holding information for a given variant. */
7287 typedef struct vinfo
7289 /* The record type of the variant. */
7292 /* The name of the variant. */
7295 /* The qualifier of the variant. */
7298 /* Whether the variant has a rep clause. */
7301 /* Whether the variant is packed. */
7306 /* Translate and chain GNAT_COMPONENT_LIST present in GNAT_RECORD_TYPE to
7307 GNU_FIELD_LIST, set the result as the field list of GNU_RECORD_TYPE and
7308 finish it up. Return true if GNU_RECORD_TYPE has a rep clause that affects
7309 the layout (see below). When called from gnat_to_gnu_entity during the
7310 processing of a record definition, the GCC node for the parent, if any,
7311 will be the single field of GNU_RECORD_TYPE and the GCC nodes for the
7312 discriminants will be on GNU_FIELD_LIST. The other call to this function
7313 is a recursive call for the component list of a variant and, in this case,
7314 GNU_FIELD_LIST is empty.
7316 PACKED is 1 if this is for a packed record or -1 if this is for a record
7317 with Component_Alignment of Storage_Unit.
7319 DEFINITION is true if we are defining this record type.
7321 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
7322 out the record. This means the alignment only serves to force fields to
7323 be bitfields, but not to require the record to be that aligned. This is
7326 ALL_REP is true if a rep clause is present for all the fields.
7328 UNCHECKED_UNION is true if we are building this type for a record with a
7329 Pragma Unchecked_Union.
7331 ARTIFICIAL is true if this is a type that was generated by the compiler.
7333 DEBUG_INFO is true if we need to write debug information about the type.
7335 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
7336 mean that its contents may be unused as well, only the container itself.
7338 FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
7339 the outer record type down to this variant level. It is nonzero only if
7340 all the fields down to this level have a rep clause and ALL_REP is false.
7342 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
7343 with a rep clause is to be added; in this case, that is all that should
7344 be done with such fields and the return value will be false. */
7347 components_to_record (Node_Id gnat_component_list
, Entity_Id gnat_record_type
,
7348 tree gnu_field_list
, tree gnu_record_type
, int packed
,
7349 bool definition
, bool cancel_alignment
, bool all_rep
,
7350 bool unchecked_union
, bool artificial
, bool debug_info
,
7351 bool maybe_unused
, tree first_free_pos
,
7352 tree
*p_gnu_rep_list
)
7354 const bool needs_xv_encodings
7355 = debug_info
&& gnat_encodings
!= DWARF_GNAT_ENCODINGS_MINIMAL
;
7356 bool all_rep_and_size
= all_rep
&& TYPE_SIZE (gnu_record_type
);
7357 bool variants_have_rep
= all_rep
;
7358 bool layout_with_rep
= false;
7359 bool has_self_field
= false;
7360 bool has_aliased_after_self_field
= false;
7361 Entity_Id gnat_component_decl
, gnat_variant_part
;
7362 tree gnu_field
, gnu_next
, gnu_last
;
7363 tree gnu_variant_part
= NULL_TREE
;
7364 tree gnu_rep_list
= NULL_TREE
;
7366 /* For each component referenced in a component declaration create a GCC
7367 field and add it to the list, skipping pragmas in the GNAT list. */
7368 gnu_last
= tree_last (gnu_field_list
);
7369 if (Present (Component_Items (gnat_component_list
)))
7370 for (gnat_component_decl
7371 = First_Non_Pragma (Component_Items (gnat_component_list
));
7372 Present (gnat_component_decl
);
7373 gnat_component_decl
= Next_Non_Pragma (gnat_component_decl
))
7375 Entity_Id gnat_field
= Defining_Entity (gnat_component_decl
);
7376 Name_Id gnat_name
= Chars (gnat_field
);
7378 /* If present, the _Parent field must have been created as the single
7379 field of the record type. Put it before any other fields. */
7380 if (gnat_name
== Name_uParent
)
7382 gnu_field
= TYPE_FIELDS (gnu_record_type
);
7383 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
7387 gnu_field
= gnat_to_gnu_field (gnat_field
, gnu_record_type
, packed
,
7388 definition
, debug_info
);
7390 /* If this is the _Tag field, put it before any other fields. */
7391 if (gnat_name
== Name_uTag
)
7392 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
7394 /* If this is the _Controller field, put it before the other
7395 fields except for the _Tag or _Parent field. */
7396 else if (gnat_name
== Name_uController
&& gnu_last
)
7398 DECL_CHAIN (gnu_field
) = DECL_CHAIN (gnu_last
);
7399 DECL_CHAIN (gnu_last
) = gnu_field
;
7402 /* If this is a regular field, put it after the other fields. */
7405 DECL_CHAIN (gnu_field
) = gnu_field_list
;
7406 gnu_field_list
= gnu_field
;
7408 gnu_last
= gnu_field
;
7410 /* And record information for the final layout. */
7411 if (field_has_self_size (gnu_field
))
7412 has_self_field
= true;
7413 else if (has_self_field
&& DECL_ALIASED_P (gnu_field
))
7414 has_aliased_after_self_field
= true;
7418 save_gnu_tree (gnat_field
, gnu_field
, false);
7421 /* At the end of the component list there may be a variant part. */
7422 gnat_variant_part
= Variant_Part (gnat_component_list
);
7424 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7425 mutually exclusive and should go in the same memory. To do this we need
7426 to treat each variant as a record whose elements are created from the
7427 component list for the variant. So here we create the records from the
7428 lists for the variants and put them all into the QUAL_UNION_TYPE.
7429 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7430 use GNU_RECORD_TYPE if there are no fields so far. */
7431 if (Present (gnat_variant_part
))
7433 Node_Id gnat_discr
= Name (gnat_variant_part
), variant
;
7434 tree gnu_discr
= gnat_to_gnu (gnat_discr
);
7435 tree gnu_name
= TYPE_IDENTIFIER (gnu_record_type
);
7437 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr
))),
7439 tree gnu_union_type
, gnu_union_name
;
7440 tree this_first_free_pos
, gnu_variant_list
= NULL_TREE
;
7441 bool union_field_needs_strict_alignment
= false;
7442 auto_vec
<vinfo_t
, 16> variant_types
;
7443 vinfo_t
*gnu_variant
;
7444 unsigned int variants_align
= 0;
7448 = concat_name (gnu_name
, IDENTIFIER_POINTER (gnu_var_name
));
7450 /* Reuse the enclosing union if this is an Unchecked_Union whose fields
7451 are all in the variant part, to match the layout of C unions. There
7452 is an associated check below. */
7453 if (TREE_CODE (gnu_record_type
) == UNION_TYPE
)
7454 gnu_union_type
= gnu_record_type
;
7458 = make_node (unchecked_union
? UNION_TYPE
: QUAL_UNION_TYPE
);
7460 TYPE_NAME (gnu_union_type
) = gnu_union_name
;
7461 SET_TYPE_ALIGN (gnu_union_type
, 0);
7462 TYPE_PACKED (gnu_union_type
) = TYPE_PACKED (gnu_record_type
);
7463 TYPE_REVERSE_STORAGE_ORDER (gnu_union_type
)
7464 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type
);
7467 /* If all the fields down to this level have a rep clause, find out
7468 whether all the fields at this level also have one. If so, then
7469 compute the new first free position to be passed downward. */
7470 this_first_free_pos
= first_free_pos
;
7471 if (this_first_free_pos
)
7473 for (gnu_field
= gnu_field_list
;
7475 gnu_field
= DECL_CHAIN (gnu_field
))
7476 if (DECL_FIELD_OFFSET (gnu_field
))
7478 tree pos
= bit_position (gnu_field
);
7479 if (!tree_int_cst_lt (pos
, this_first_free_pos
))
7481 = size_binop (PLUS_EXPR
, pos
, DECL_SIZE (gnu_field
));
7485 this_first_free_pos
= NULL_TREE
;
7490 /* We build the variants in two passes. The bulk of the work is done in
7491 the first pass, that is to say translating the GNAT nodes, building
7492 the container types and computing the associated properties. However
7493 we cannot finish up the container types during this pass because we
7494 don't know where the variant part will be placed until the end. */
7495 for (variant
= First_Non_Pragma (Variants (gnat_variant_part
));
7497 variant
= Next_Non_Pragma (variant
))
7499 tree gnu_variant_type
= make_node (RECORD_TYPE
);
7500 tree gnu_inner_name
, gnu_qual
;
7505 Get_Variant_Encoding (variant
);
7506 gnu_inner_name
= get_identifier_with_length (Name_Buffer
, Name_Len
);
7507 TYPE_NAME (gnu_variant_type
)
7508 = concat_name (gnu_union_name
,
7509 IDENTIFIER_POINTER (gnu_inner_name
));
7511 /* Set the alignment of the inner type in case we need to make
7512 inner objects into bitfields, but then clear it out so the
7513 record actually gets only the alignment required. */
7514 SET_TYPE_ALIGN (gnu_variant_type
, TYPE_ALIGN (gnu_record_type
));
7515 TYPE_PACKED (gnu_variant_type
) = TYPE_PACKED (gnu_record_type
);
7516 TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type
)
7517 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type
);
7519 /* Similarly, if the outer record has a size specified and all
7520 the fields have a rep clause, we can propagate the size. */
7521 if (all_rep_and_size
)
7523 TYPE_SIZE (gnu_variant_type
) = TYPE_SIZE (gnu_record_type
);
7524 TYPE_SIZE_UNIT (gnu_variant_type
)
7525 = TYPE_SIZE_UNIT (gnu_record_type
);
7528 /* Add the fields into the record type for the variant. Note that
7529 we aren't sure to really use it at this point, see below. */
7531 = components_to_record (Component_List (variant
), gnat_record_type
,
7532 NULL_TREE
, gnu_variant_type
, packed
,
7533 definition
, !all_rep_and_size
, all_rep
,
7534 unchecked_union
, true, needs_xv_encodings
,
7535 true, this_first_free_pos
,
7536 all_rep
|| this_first_free_pos
7537 ? NULL
: &gnu_rep_list
);
7539 /* Translate the qualifier and annotate the GNAT node. */
7540 gnu_qual
= choices_to_gnu (gnu_discr
, Discrete_Choices (variant
));
7541 Set_Present_Expr (variant
, annotate_value (gnu_qual
));
7543 /* Deal with packedness like in gnat_to_gnu_field. */
7544 if (components_need_strict_alignment (Component_List (variant
)))
7547 union_field_needs_strict_alignment
= true;
7551 = adjust_packed (gnu_variant_type
, gnu_record_type
, packed
);
7553 /* Push this variant onto the stack for the second pass. */
7554 vinfo
.type
= gnu_variant_type
;
7555 vinfo
.name
= gnu_inner_name
;
7556 vinfo
.qual
= gnu_qual
;
7557 vinfo
.has_rep
= has_rep
;
7558 vinfo
.packed
= field_packed
;
7559 variant_types
.safe_push (vinfo
);
7561 /* Compute the global properties that will determine the placement of
7562 the variant part. */
7563 variants_have_rep
|= has_rep
;
7564 if (!field_packed
&& TYPE_ALIGN (gnu_variant_type
) > variants_align
)
7565 variants_align
= TYPE_ALIGN (gnu_variant_type
);
7568 /* Round up the first free position to the alignment of the variant part
7569 for the variants without rep clause. This will guarantee a consistent
7570 layout independently of the placement of the variant part. */
7571 if (variants_have_rep
&& variants_align
> 0 && this_first_free_pos
)
7572 this_first_free_pos
= round_up (this_first_free_pos
, variants_align
);
7574 /* In the second pass, the container types are adjusted if necessary and
7575 finished up, then the corresponding fields of the variant part are
7576 built with their qualifier, unless this is an unchecked union. */
7577 FOR_EACH_VEC_ELT (variant_types
, i
, gnu_variant
)
7579 tree gnu_variant_type
= gnu_variant
->type
;
7580 tree gnu_field_list
= TYPE_FIELDS (gnu_variant_type
);
7582 /* If this is an Unchecked_Union whose fields are all in the variant
7583 part and we have a single field with no representation clause or
7584 placed at offset zero, use the field directly to match the layout
7586 if (TREE_CODE (gnu_record_type
) == UNION_TYPE
7588 && !DECL_CHAIN (gnu_field_list
)
7589 && (!DECL_FIELD_OFFSET (gnu_field_list
)
7590 || integer_zerop (bit_position (gnu_field_list
))))
7592 gnu_field
= gnu_field_list
;
7593 DECL_CONTEXT (gnu_field
) = gnu_record_type
;
7597 /* Finalize the variant type now. We used to throw away empty
7598 record types but we no longer do that because we need them to
7599 generate complete debug info for the variant; otherwise, the
7600 union type definition will be lacking the fields associated
7601 with these empty variants. */
7602 if (gnu_field_list
&& variants_have_rep
&& !gnu_variant
->has_rep
)
7604 /* The variant part will be at offset 0 so we need to ensure
7605 that the fields are laid out starting from the first free
7606 position at this level. */
7607 tree gnu_rep_type
= make_node (RECORD_TYPE
);
7609 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type
)
7610 = TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type
);
7611 finish_record_type (gnu_rep_type
, NULL_TREE
, 0, debug_info
);
7613 = create_rep_part (gnu_rep_type
, gnu_variant_type
,
7614 this_first_free_pos
);
7615 DECL_CHAIN (gnu_rep_part
) = gnu_field_list
;
7616 gnu_field_list
= gnu_rep_part
;
7617 finish_record_type (gnu_variant_type
, gnu_field_list
, 0,
7622 rest_of_record_type_compilation (gnu_variant_type
);
7623 create_type_decl (TYPE_NAME (gnu_variant_type
), gnu_variant_type
,
7624 true, needs_xv_encodings
, gnat_component_list
);
7627 = create_field_decl (gnu_variant
->name
, gnu_variant_type
,
7630 ? TYPE_SIZE (gnu_variant_type
) : 0,
7631 variants_have_rep
? bitsize_zero_node
: 0,
7632 gnu_variant
->packed
, 0);
7634 DECL_INTERNAL_P (gnu_field
) = 1;
7636 if (!unchecked_union
)
7637 DECL_QUALIFIER (gnu_field
) = gnu_variant
->qual
;
7640 DECL_CHAIN (gnu_field
) = gnu_variant_list
;
7641 gnu_variant_list
= gnu_field
;
7644 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7645 if (gnu_variant_list
)
7647 int union_field_packed
;
7649 if (all_rep_and_size
)
7651 TYPE_SIZE (gnu_union_type
) = TYPE_SIZE (gnu_record_type
);
7652 TYPE_SIZE_UNIT (gnu_union_type
)
7653 = TYPE_SIZE_UNIT (gnu_record_type
);
7656 finish_record_type (gnu_union_type
, nreverse (gnu_variant_list
),
7657 all_rep_and_size
? 1 : 0, needs_xv_encodings
);
7659 /* If GNU_UNION_TYPE is our record type, it means we must have an
7660 Unchecked_Union with no fields. Verify that and, if so, just
7662 if (gnu_union_type
== gnu_record_type
)
7664 gcc_assert (unchecked_union
7667 return variants_have_rep
;
7670 create_type_decl (TYPE_NAME (gnu_union_type
), gnu_union_type
, true,
7671 needs_xv_encodings
, gnat_component_list
);
7673 /* Deal with packedness like in gnat_to_gnu_field. */
7674 if (union_field_needs_strict_alignment
)
7675 union_field_packed
= 0;
7678 = adjust_packed (gnu_union_type
, gnu_record_type
, packed
);
7681 = create_field_decl (gnu_var_name
, gnu_union_type
, gnu_record_type
,
7683 ? TYPE_SIZE (gnu_union_type
) : 0,
7684 variants_have_rep
? bitsize_zero_node
: 0,
7685 union_field_packed
, 0);
7687 DECL_INTERNAL_P (gnu_variant_part
) = 1;
7691 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they do,
7692 pull them out and put them onto the appropriate list. We have to do it
7693 in a separate pass since we want to handle the discriminants but can't
7694 play with them until we've used them in debugging data above.
7696 Similarly, pull out the fields with zero size and no rep clause, as they
7697 would otherwise modify the layout and thus very likely run afoul of the
7698 Ada semantics, which are different from those of C here.
7700 Finally, if there is an aliased field placed in the list after fields
7701 with self-referential size, pull out the latter in the same way.
7703 Optionally, if the reordering mechanism is enabled, pull out the fields
7704 with self-referential size, variable size and fixed size not a multiple
7705 of a byte, so that they don't cause the regular fields to be either at
7706 self-referential/variable offset or misaligned. Note, in the latter
7707 case, that this can only happen in packed record types so the alignment
7708 is effectively capped to the byte for the whole record.
7710 Optionally, if the layout warning is enabled, keep track of the above 4
7711 different kinds of fields and issue a warning if some of them would be
7712 (or are being) reordered by the reordering mechanism.
7714 Finally, pull out the fields whose size is not a multiple of a byte, so
7715 that they don't cause the regular fields to be misaligned. As this can
7716 only happen in packed record types, the alignment is capped to the byte.
7718 ??? If we reorder them, debugging information will be wrong but there is
7719 nothing that can be done about this at the moment. */
7720 const bool do_reorder
= OK_To_Reorder_Components (gnat_record_type
);
7721 const bool w_reorder
7722 = Warn_On_Questionable_Layout
7723 && (Convention (gnat_record_type
) == Convention_Ada
);
7724 const bool in_variant
= (p_gnu_rep_list
!= NULL
);
7725 tree gnu_zero_list
= NULL_TREE
;
7726 tree gnu_self_list
= NULL_TREE
;
7727 tree gnu_var_list
= NULL_TREE
;
7728 tree gnu_bitp_list
= NULL_TREE
;
7729 tree gnu_tmp_bitp_list
= NULL_TREE
;
7730 unsigned int tmp_bitp_size
= 0;
7731 unsigned int last_reorder_field_type
= -1;
7732 unsigned int tmp_last_reorder_field_type
= -1;
7734 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7737 DECL_CHAIN (gnu_last) = gnu_next; \
7739 gnu_field_list = gnu_next; \
7741 DECL_CHAIN (gnu_field) = (LIST); \
7742 (LIST) = gnu_field; \
7745 gnu_last
= NULL_TREE
;
7746 for (gnu_field
= gnu_field_list
; gnu_field
; gnu_field
= gnu_next
)
7748 gnu_next
= DECL_CHAIN (gnu_field
);
7750 if (DECL_FIELD_OFFSET (gnu_field
))
7752 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list
);
7756 if (DECL_SIZE (gnu_field
) && integer_zerop (DECL_SIZE (gnu_field
)))
7758 DECL_FIELD_OFFSET (gnu_field
) = size_zero_node
;
7759 SET_DECL_OFFSET_ALIGN (gnu_field
, BIGGEST_ALIGNMENT
);
7760 DECL_FIELD_BIT_OFFSET (gnu_field
) = bitsize_zero_node
;
7761 if (DECL_ALIASED_P (gnu_field
))
7762 SET_TYPE_ALIGN (gnu_record_type
,
7763 MAX (TYPE_ALIGN (gnu_record_type
),
7764 TYPE_ALIGN (TREE_TYPE (gnu_field
))));
7765 MOVE_FROM_FIELD_LIST_TO (gnu_zero_list
);
7769 if (has_aliased_after_self_field
&& field_has_self_size (gnu_field
))
7771 MOVE_FROM_FIELD_LIST_TO (gnu_self_list
);
7775 /* We don't need further processing in default mode. */
7776 if (!w_reorder
&& !do_reorder
)
7778 gnu_last
= gnu_field
;
7782 if (field_has_self_size (gnu_field
))
7786 if (last_reorder_field_type
< 4)
7787 warn_on_field_placement (gnu_field
, gnat_component_list
,
7788 gnat_record_type
, in_variant
,
7791 last_reorder_field_type
= 4;
7796 MOVE_FROM_FIELD_LIST_TO (gnu_self_list
);
7801 else if (field_has_variable_size (gnu_field
))
7805 if (last_reorder_field_type
< 3)
7806 warn_on_field_placement (gnu_field
, gnat_component_list
,
7807 gnat_record_type
, in_variant
,
7810 last_reorder_field_type
= 3;
7815 MOVE_FROM_FIELD_LIST_TO (gnu_var_list
);
7822 /* If the field has no size, then it cannot be bit-packed. */
7823 const unsigned int bitp_size
7824 = DECL_SIZE (gnu_field
)
7825 ? TREE_INT_CST_LOW (DECL_SIZE (gnu_field
)) % BITS_PER_UNIT
7828 /* If the field is bit-packed, we move it to a temporary list that
7829 contains the contiguously preceding bit-packed fields, because
7830 we want to be able to put them back if the misalignment happens
7831 to cancel itself after several bit-packed fields. */
7834 tmp_bitp_size
= (tmp_bitp_size
+ bitp_size
) % BITS_PER_UNIT
;
7836 if (last_reorder_field_type
!= 2)
7838 tmp_last_reorder_field_type
= last_reorder_field_type
;
7839 last_reorder_field_type
= 2;
7844 MOVE_FROM_FIELD_LIST_TO (gnu_tmp_bitp_list
);
7849 /* No more bit-packed fields, move the existing ones to the end or
7850 put them back at their original location. */
7851 else if (last_reorder_field_type
== 2 || gnu_tmp_bitp_list
)
7853 last_reorder_field_type
= 1;
7855 if (tmp_bitp_size
!= 0)
7857 if (w_reorder
&& tmp_last_reorder_field_type
< 2)
7858 warn_on_field_placement (gnu_tmp_bitp_list
7859 ? gnu_tmp_bitp_list
: gnu_last
,
7860 gnat_component_list
,
7861 gnat_record_type
, in_variant
,
7865 gnu_bitp_list
= chainon (gnu_tmp_bitp_list
, gnu_bitp_list
);
7867 gnu_tmp_bitp_list
= NULL_TREE
;
7872 /* Rechain the temporary list in front of GNU_FIELD. */
7873 tree gnu_bitp_field
= gnu_field
;
7874 while (gnu_tmp_bitp_list
)
7876 tree gnu_bitp_next
= DECL_CHAIN (gnu_tmp_bitp_list
);
7877 DECL_CHAIN (gnu_tmp_bitp_list
) = gnu_bitp_field
;
7879 DECL_CHAIN (gnu_last
) = gnu_tmp_bitp_list
;
7881 gnu_field_list
= gnu_tmp_bitp_list
;
7882 gnu_bitp_field
= gnu_tmp_bitp_list
;
7883 gnu_tmp_bitp_list
= gnu_bitp_next
;
7889 last_reorder_field_type
= 1;
7892 gnu_last
= gnu_field
;
7895 #undef MOVE_FROM_FIELD_LIST_TO
7897 gnu_field_list
= nreverse (gnu_field_list
);
7899 /* If permitted, we reorder the fields as follows:
7901 1) all (groups of) fields whose length is fixed and multiple of a byte,
7902 2) the remaining fields whose length is fixed and not multiple of a byte,
7903 3) the remaining fields whose length doesn't depend on discriminants,
7904 4) all fields whose length depends on discriminants,
7905 5) the variant part,
7907 within the record and within each variant recursively. */
7911 /* If we have pending bit-packed fields, warn if they would be moved
7912 to after regular fields. */
7913 if (last_reorder_field_type
== 2
7914 && tmp_bitp_size
!= 0
7915 && tmp_last_reorder_field_type
< 2)
7916 warn_on_field_placement (gnu_tmp_bitp_list
7917 ? gnu_tmp_bitp_list
: gnu_field_list
,
7918 gnat_component_list
, gnat_record_type
,
7919 in_variant
, do_reorder
);
7924 /* If we have pending bit-packed fields on the temporary list, we put
7925 them either on the bit-packed list or back on the regular list. */
7926 if (gnu_tmp_bitp_list
)
7928 if (tmp_bitp_size
!= 0)
7929 gnu_bitp_list
= chainon (gnu_tmp_bitp_list
, gnu_bitp_list
);
7931 gnu_field_list
= chainon (gnu_tmp_bitp_list
, gnu_field_list
);
7935 = chainon (gnu_field_list
,
7936 chainon (gnu_bitp_list
,
7937 chainon (gnu_var_list
, gnu_self_list
)));
7940 /* Otherwise, if there is an aliased field placed after a field whose length
7941 depends on discriminants, we put all the fields of the latter sort, last.
7942 We need to do this in case an object of this record type is mutable. */
7943 else if (has_aliased_after_self_field
)
7944 gnu_field_list
= chainon (gnu_field_list
, gnu_self_list
);
7946 /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
7947 in our REP list to the previous level because this level needs them in
7948 order to do a correct layout, i.e. avoid having overlapping fields. */
7949 if (p_gnu_rep_list
&& gnu_rep_list
)
7950 *p_gnu_rep_list
= chainon (*p_gnu_rep_list
, gnu_rep_list
);
7952 /* Deal with the annoying case of an extension of a record with variable size
7953 and partial rep clause, for which the _Parent field is forced at offset 0
7954 and has variable size, which we do not support below. Note that we cannot
7955 do it if the field has fixed size because we rely on the presence of the
7956 REP part built below to trigger the reordering of the fields in a derived
7957 record type when all the fields have a fixed position. */
7958 else if (gnu_rep_list
7959 && !DECL_CHAIN (gnu_rep_list
)
7960 && TREE_CODE (DECL_SIZE (gnu_rep_list
)) != INTEGER_CST
7961 && !variants_have_rep
7963 && integer_zerop (first_free_pos
)
7964 && integer_zerop (bit_position (gnu_rep_list
)))
7966 DECL_CHAIN (gnu_rep_list
) = gnu_field_list
;
7967 gnu_field_list
= gnu_rep_list
;
7968 gnu_rep_list
= NULL_TREE
;
7971 /* Otherwise, sort the fields by bit position and put them into their own
7972 record, before the others, if we also have fields without rep clause. */
7973 else if (gnu_rep_list
)
7975 tree gnu_rep_type
, gnu_rep_part
;
7976 int i
, len
= list_length (gnu_rep_list
);
7977 tree
*gnu_arr
= XALLOCAVEC (tree
, len
);
7979 /* If all the fields have a rep clause, we can do a flat layout. */
7980 layout_with_rep
= !gnu_field_list
7981 && (!gnu_variant_part
|| variants_have_rep
);
7983 = layout_with_rep
? gnu_record_type
: make_node (RECORD_TYPE
);
7985 for (gnu_field
= gnu_rep_list
, i
= 0;
7987 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
7988 gnu_arr
[i
] = gnu_field
;
7990 qsort (gnu_arr
, len
, sizeof (tree
), compare_field_bitpos
);
7992 /* Put the fields in the list in order of increasing position, which
7993 means we start from the end. */
7994 gnu_rep_list
= NULL_TREE
;
7995 for (i
= len
- 1; i
>= 0; i
--)
7997 DECL_CHAIN (gnu_arr
[i
]) = gnu_rep_list
;
7998 gnu_rep_list
= gnu_arr
[i
];
7999 DECL_CONTEXT (gnu_arr
[i
]) = gnu_rep_type
;
8002 if (layout_with_rep
)
8003 gnu_field_list
= gnu_rep_list
;
8006 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type
)
8007 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type
);
8008 finish_record_type (gnu_rep_type
, gnu_rep_list
, 1, debug_info
);
8010 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
8011 without rep clause are laid out starting from this position.
8012 Therefore, we force it as a minimal size on the REP part. */
8014 = create_rep_part (gnu_rep_type
, gnu_record_type
, first_free_pos
);
8016 /* Chain the REP part at the beginning of the field list. */
8017 DECL_CHAIN (gnu_rep_part
) = gnu_field_list
;
8018 gnu_field_list
= gnu_rep_part
;
8022 /* Chain the variant part at the end of the field list. */
8023 if (gnu_variant_part
)
8024 gnu_field_list
= chainon (gnu_field_list
, gnu_variant_part
);
8026 if (cancel_alignment
)
8027 SET_TYPE_ALIGN (gnu_record_type
, 0);
8029 TYPE_ARTIFICIAL (gnu_record_type
) = artificial
;
8031 finish_record_type (gnu_record_type
, gnu_field_list
, layout_with_rep
? 1 : 0,
8032 debug_info
&& !maybe_unused
);
8034 /* Chain the fields with zero size at the beginning of the field list. */
8036 TYPE_FIELDS (gnu_record_type
)
8037 = chainon (gnu_zero_list
, TYPE_FIELDS (gnu_record_type
));
8039 return (gnu_rep_list
&& !p_gnu_rep_list
) || variants_have_rep
;
8042 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
8043 placed into an Esize, Component_Bit_Offset, or Component_Size value
8044 in the GNAT tree. */
8047 annotate_value (tree gnu_size
)
8049 static int var_count
= 0;
8051 Node_Ref_Or_Val ops
[3] = { No_Uint
, No_Uint
, No_Uint
};
8052 struct tree_int_map in
;
8054 /* See if we've already saved the value for this node. */
8055 if (EXPR_P (gnu_size
) || DECL_P (gnu_size
))
8057 struct tree_int_map
*e
;
8059 in
.base
.from
= gnu_size
;
8060 e
= annotate_value_cache
->find (&in
);
8063 return (Node_Ref_Or_Val
) e
->to
;
8066 in
.base
.from
= NULL_TREE
;
8068 /* If we do not return inside this switch, TCODE will be set to the
8069 code to be used in a call to Create_Node. */
8070 switch (TREE_CODE (gnu_size
))
8073 /* For negative values, build NEGATE_EXPR of the opposite. Such values
8074 can appear for discriminants in expressions for variants. */
8075 if (tree_int_cst_sgn (gnu_size
) < 0)
8077 tree t
= wide_int_to_tree (sizetype
, wi::neg (gnu_size
));
8078 tcode
= Negate_Expr
;
8079 ops
[0] = UI_From_gnu (t
);
8082 return TREE_OVERFLOW (gnu_size
) ? No_Uint
: UI_From_gnu (gnu_size
);
8086 /* The only case we handle here is a simple discriminant reference. */
8087 if (DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size
, 1)))
8089 tree ref
= gnu_size
;
8090 gnu_size
= TREE_OPERAND (ref
, 1);
8092 /* Climb up the chain of successive extensions, if any. */
8093 while (TREE_CODE (TREE_OPERAND (ref
, 0)) == COMPONENT_REF
8094 && DECL_NAME (TREE_OPERAND (TREE_OPERAND (ref
, 0), 1))
8096 ref
= TREE_OPERAND (ref
, 0);
8098 if (TREE_CODE (TREE_OPERAND (ref
, 0)) == PLACEHOLDER_EXPR
)
8100 /* Fall through to common processing as a FIELD_DECL. */
8101 tcode
= Discrim_Val
;
8102 ops
[0] = UI_From_gnu (DECL_DISCRIMINANT_NUMBER (gnu_size
));
8112 tcode
= Dynamic_Val
;
8113 ops
[0] = UI_From_Int (++var_count
);
8117 case NON_LVALUE_EXPR
:
8118 return annotate_value (TREE_OPERAND (gnu_size
, 0));
8120 /* Now just list the operations we handle. */
8121 case COND_EXPR
: tcode
= Cond_Expr
; break;
8122 case MINUS_EXPR
: tcode
= Minus_Expr
; break;
8123 case TRUNC_DIV_EXPR
: tcode
= Trunc_Div_Expr
; break;
8124 case CEIL_DIV_EXPR
: tcode
= Ceil_Div_Expr
; break;
8125 case FLOOR_DIV_EXPR
: tcode
= Floor_Div_Expr
; break;
8126 case TRUNC_MOD_EXPR
: tcode
= Trunc_Mod_Expr
; break;
8127 case CEIL_MOD_EXPR
: tcode
= Ceil_Mod_Expr
; break;
8128 case FLOOR_MOD_EXPR
: tcode
= Floor_Mod_Expr
; break;
8129 case EXACT_DIV_EXPR
: tcode
= Exact_Div_Expr
; break;
8130 case NEGATE_EXPR
: tcode
= Negate_Expr
; break;
8131 case MIN_EXPR
: tcode
= Min_Expr
; break;
8132 case MAX_EXPR
: tcode
= Max_Expr
; break;
8133 case ABS_EXPR
: tcode
= Abs_Expr
; break;
8134 case TRUTH_ANDIF_EXPR
: tcode
= Truth_Andif_Expr
; break;
8135 case TRUTH_ORIF_EXPR
: tcode
= Truth_Orif_Expr
; break;
8136 case TRUTH_AND_EXPR
: tcode
= Truth_And_Expr
; break;
8137 case TRUTH_OR_EXPR
: tcode
= Truth_Or_Expr
; break;
8138 case TRUTH_XOR_EXPR
: tcode
= Truth_Xor_Expr
; break;
8139 case TRUTH_NOT_EXPR
: tcode
= Truth_Not_Expr
; break;
8140 case LT_EXPR
: tcode
= Lt_Expr
; break;
8141 case LE_EXPR
: tcode
= Le_Expr
; break;
8142 case GT_EXPR
: tcode
= Gt_Expr
; break;
8143 case GE_EXPR
: tcode
= Ge_Expr
; break;
8144 case EQ_EXPR
: tcode
= Eq_Expr
; break;
8145 case NE_EXPR
: tcode
= Ne_Expr
; break;
8149 tcode
= (TREE_CODE (gnu_size
) == MULT_EXPR
? Mult_Expr
: Plus_Expr
);
8150 /* Fold conversions from bytes to bits into inner operations. */
8151 if (TREE_CODE (TREE_OPERAND (gnu_size
, 1)) == INTEGER_CST
8152 && CONVERT_EXPR_P (TREE_OPERAND (gnu_size
, 0)))
8154 tree inner_op
= TREE_OPERAND (TREE_OPERAND (gnu_size
, 0), 0);
8155 if (TREE_CODE (inner_op
) == TREE_CODE (gnu_size
)
8156 && TREE_CODE (TREE_OPERAND (inner_op
, 1)) == INTEGER_CST
)
8158 tree inner_op_op1
= TREE_OPERAND (inner_op
, 1);
8159 tree gnu_size_op1
= TREE_OPERAND (gnu_size
, 1);
8161 if (TREE_CODE (gnu_size
) == MULT_EXPR
)
8162 op1
= wi::mul (inner_op_op1
, gnu_size_op1
);
8164 op1
= wi::add (inner_op_op1
, gnu_size_op1
);
8165 ops
[1] = UI_From_gnu (wide_int_to_tree (sizetype
, op1
));
8166 ops
[0] = annotate_value (TREE_OPERAND (inner_op
, 0));
8172 tcode
= Bit_And_Expr
;
8173 /* For negative values in sizetype, build NEGATE_EXPR of the opposite.
8174 Such values appear in expressions with aligning patterns. Note that,
8175 since sizetype is unsigned, we have to jump through some hoops. */
8176 if (TREE_CODE (TREE_OPERAND (gnu_size
, 1)) == INTEGER_CST
)
8178 tree op1
= TREE_OPERAND (gnu_size
, 1);
8179 wide_int signed_op1
= wi::sext (op1
, TYPE_PRECISION (sizetype
));
8180 if (wi::neg_p (signed_op1
))
8182 op1
= wide_int_to_tree (sizetype
, wi::neg (signed_op1
));
8183 ops
[1] = annotate_value (build1 (NEGATE_EXPR
, sizetype
, op1
));
8189 /* In regular mode, inline back only if symbolic annotation is requested
8190 in order to avoid memory explosion on big discriminated record types.
8191 But not in ASIS mode, as symbolic annotation is required for DDA. */
8192 if (List_Representation_Info
== 3 || type_annotate_only
)
8194 tree t
= maybe_inline_call_in_expr (gnu_size
);
8195 return t
? annotate_value (t
) : No_Uint
;
8198 return Uint_Minus_1
;
8204 /* Now get each of the operands that's relevant for this code. If any
8205 cannot be expressed as a repinfo node, say we can't. */
8206 for (int i
= 0; i
< TREE_CODE_LENGTH (TREE_CODE (gnu_size
)); i
++)
8207 if (ops
[i
] == No_Uint
)
8209 ops
[i
] = annotate_value (TREE_OPERAND (gnu_size
, i
));
8210 if (ops
[i
] == No_Uint
)
8214 Node_Ref_Or_Val ret
= Create_Node (tcode
, ops
[0], ops
[1], ops
[2]);
8216 /* Save the result in the cache. */
8219 struct tree_int_map
**h
;
8220 /* We can't assume the hash table data hasn't moved since the initial
8221 look up, so we have to search again. Allocating and inserting an
8222 entry at that point would be an alternative, but then we'd better
8223 discard the entry if we decided not to cache it. */
8224 h
= annotate_value_cache
->find_slot (&in
, INSERT
);
8226 *h
= ggc_alloc
<tree_int_map
> ();
8227 (*h
)->base
.from
= in
.base
.from
;
8234 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
8235 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
8236 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
8237 BY_REF is true if the object is used by reference. */
8240 annotate_object (Entity_Id gnat_entity
, tree gnu_type
, tree size
, bool by_ref
)
8244 if (TYPE_IS_FAT_POINTER_P (gnu_type
))
8245 gnu_type
= TYPE_UNCONSTRAINED_ARRAY (gnu_type
);
8247 gnu_type
= TREE_TYPE (gnu_type
);
8250 if (Unknown_Esize (gnat_entity
))
8252 if (TREE_CODE (gnu_type
) == RECORD_TYPE
8253 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
8254 size
= TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
))));
8256 size
= TYPE_SIZE (gnu_type
);
8259 Set_Esize (gnat_entity
, annotate_value (size
));
8262 if (Unknown_Alignment (gnat_entity
))
8263 Set_Alignment (gnat_entity
,
8264 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
8267 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
8268 Return NULL_TREE if there is no such element in the list. */
8271 purpose_member_field (const_tree elem
, tree list
)
8275 tree field
= TREE_PURPOSE (list
);
8276 if (SAME_FIELD_P (field
, elem
))
8278 list
= TREE_CHAIN (list
);
8283 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
8284 set Component_Bit_Offset and Esize of the components to the position and
8285 size used by Gigi. */
8288 annotate_rep (Entity_Id gnat_entity
, tree gnu_type
)
8290 /* For an extension, the inherited components have not been translated because
8291 they are fetched from the _Parent component on the fly. */
8292 const bool is_extension
8293 = Is_Tagged_Type (gnat_entity
) && Is_Derived_Type (gnat_entity
);
8295 /* We operate by first making a list of all fields and their position (we
8296 can get the size easily) and then update all the sizes in the tree. */
8298 = build_position_list (gnu_type
, false, size_zero_node
, bitsize_zero_node
,
8299 BIGGEST_ALIGNMENT
, NULL_TREE
);
8301 for (Entity_Id gnat_field
= First_Entity (gnat_entity
);
8302 Present (gnat_field
);
8303 gnat_field
= Next_Entity (gnat_field
))
8304 if ((Ekind (gnat_field
) == E_Component
8305 && (is_extension
|| present_gnu_tree (gnat_field
)))
8306 || (Ekind (gnat_field
) == E_Discriminant
8307 && !Is_Unchecked_Union (Scope (gnat_field
))))
8309 tree t
= purpose_member_field (gnat_to_gnu_field_decl (gnat_field
),
8315 /* If we are just annotating types and the type is tagged, the tag
8316 and the parent components are not generated by the front-end so
8317 we need to add the appropriate offset to each component without
8318 representation clause. */
8319 if (type_annotate_only
8320 && Is_Tagged_Type (gnat_entity
)
8321 && No (Component_Clause (gnat_field
)))
8323 /* For a component appearing in the current extension, the
8324 offset is the size of the parent. */
8325 if (Is_Derived_Type (gnat_entity
)
8326 && Original_Record_Component (gnat_field
) == gnat_field
)
8328 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity
))),
8331 parent_offset
= bitsize_int (POINTER_SIZE
);
8333 if (TYPE_FIELDS (gnu_type
))
8335 = round_up (parent_offset
,
8336 DECL_ALIGN (TYPE_FIELDS (gnu_type
)));
8339 parent_offset
= bitsize_zero_node
;
8341 Set_Component_Bit_Offset
8344 (size_binop (PLUS_EXPR
,
8345 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t
), 0),
8346 TREE_VEC_ELT (TREE_VALUE (t
), 2)),
8349 Set_Esize (gnat_field
,
8350 annotate_value (DECL_SIZE (TREE_PURPOSE (t
))));
8352 else if (is_extension
)
8354 /* If there is no entry, this is an inherited component whose
8355 position is the same as in the parent type. */
8356 Entity_Id gnat_orig_field
= Original_Record_Component (gnat_field
);
8358 /* If we are just annotating types, discriminants renaming those of
8359 the parent have no entry so deal with them specifically. */
8360 if (type_annotate_only
8361 && gnat_orig_field
== gnat_field
8362 && Ekind (gnat_field
) == E_Discriminant
)
8363 gnat_orig_field
= Corresponding_Discriminant (gnat_field
);
8365 Set_Component_Bit_Offset (gnat_field
,
8366 Component_Bit_Offset (gnat_orig_field
));
8368 Set_Esize (gnat_field
, Esize (gnat_orig_field
));
8373 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
8374 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
8375 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
8376 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
8377 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
8378 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
8379 pre-existing list to be chained to the newly created entries. */
8382 build_position_list (tree gnu_type
, bool do_not_flatten_variant
, tree gnu_pos
,
8383 tree gnu_bitpos
, unsigned int offset_align
, tree gnu_list
)
8387 for (gnu_field
= TYPE_FIELDS (gnu_type
);
8389 gnu_field
= DECL_CHAIN (gnu_field
))
8391 tree gnu_our_bitpos
= size_binop (PLUS_EXPR
, gnu_bitpos
,
8392 DECL_FIELD_BIT_OFFSET (gnu_field
));
8393 tree gnu_our_offset
= size_binop (PLUS_EXPR
, gnu_pos
,
8394 DECL_FIELD_OFFSET (gnu_field
));
8395 unsigned int our_offset_align
8396 = MIN (offset_align
, DECL_OFFSET_ALIGN (gnu_field
));
8397 tree v
= make_tree_vec (3);
8399 TREE_VEC_ELT (v
, 0) = gnu_our_offset
;
8400 TREE_VEC_ELT (v
, 1) = size_int (our_offset_align
);
8401 TREE_VEC_ELT (v
, 2) = gnu_our_bitpos
;
8402 gnu_list
= tree_cons (gnu_field
, v
, gnu_list
);
8404 /* Recurse on internal fields, flattening the nested fields except for
8405 those in the variant part, if requested. */
8406 if (DECL_INTERNAL_P (gnu_field
))
8408 tree gnu_field_type
= TREE_TYPE (gnu_field
);
8409 if (do_not_flatten_variant
8410 && TREE_CODE (gnu_field_type
) == QUAL_UNION_TYPE
)
8412 = build_position_list (gnu_field_type
, do_not_flatten_variant
,
8413 size_zero_node
, bitsize_zero_node
,
8414 BIGGEST_ALIGNMENT
, gnu_list
);
8417 = build_position_list (gnu_field_type
, do_not_flatten_variant
,
8418 gnu_our_offset
, gnu_our_bitpos
,
8419 our_offset_align
, gnu_list
);
8426 /* Return a list describing the substitutions needed to reflect the
8427 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
8428 be in any order. The values in an element of the list are in the form
8429 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
8430 a definition of GNAT_SUBTYPE. */
8432 static vec
<subst_pair
>
8433 build_subst_list (Entity_Id gnat_subtype
, Entity_Id gnat_type
, bool definition
)
8435 vec
<subst_pair
> gnu_list
= vNULL
;
8436 Entity_Id gnat_discrim
;
8437 Node_Id gnat_constr
;
8439 for (gnat_discrim
= First_Stored_Discriminant (gnat_type
),
8440 gnat_constr
= First_Elmt (Stored_Constraint (gnat_subtype
));
8441 Present (gnat_discrim
);
8442 gnat_discrim
= Next_Stored_Discriminant (gnat_discrim
),
8443 gnat_constr
= Next_Elmt (gnat_constr
))
8444 /* Ignore access discriminants. */
8445 if (!Is_Access_Type (Etype (Node (gnat_constr
))))
8447 tree gnu_field
= gnat_to_gnu_field_decl (gnat_discrim
);
8448 tree replacement
= convert (TREE_TYPE (gnu_field
),
8449 elaborate_expression
8450 (Node (gnat_constr
), gnat_subtype
,
8451 get_entity_char (gnat_discrim
),
8452 definition
, true, false));
8453 subst_pair s
= { gnu_field
, replacement
};
8454 gnu_list
.safe_push (s
);
8460 /* Scan all fields in QUAL_UNION_TYPE and return a list describing the
8461 variants of QUAL_UNION_TYPE that are still relevant after applying
8462 the substitutions described in SUBST_LIST. GNU_LIST is a pre-existing
8463 list to be prepended to the newly created entries. */
8465 static vec
<variant_desc
>
8466 build_variant_list (tree qual_union_type
, vec
<subst_pair
> subst_list
,
8467 vec
<variant_desc
> gnu_list
)
8471 for (gnu_field
= TYPE_FIELDS (qual_union_type
);
8473 gnu_field
= DECL_CHAIN (gnu_field
))
8475 tree qual
= DECL_QUALIFIER (gnu_field
);
8479 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
8480 qual
= SUBSTITUTE_IN_EXPR (qual
, s
->discriminant
, s
->replacement
);
8482 /* If the new qualifier is not unconditionally false, its variant may
8483 still be accessed. */
8484 if (!integer_zerop (qual
))
8486 tree variant_type
= TREE_TYPE (gnu_field
), variant_subpart
;
8487 variant_desc v
= { variant_type
, gnu_field
, qual
, NULL_TREE
};
8489 gnu_list
.safe_push (v
);
8491 /* Recurse on the variant subpart of the variant, if any. */
8492 variant_subpart
= get_variant_part (variant_type
);
8493 if (variant_subpart
)
8494 gnu_list
= build_variant_list (TREE_TYPE (variant_subpart
),
8495 subst_list
, gnu_list
);
8497 /* If the new qualifier is unconditionally true, the subsequent
8498 variants cannot be accessed. */
8499 if (integer_onep (qual
))
8507 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
8508 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
8509 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
8510 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
8511 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
8512 true if we are being called to process the Component_Size of GNAT_OBJECT;
8513 this is used only for error messages. ZERO_OK is true if a size of zero
8514 is permitted; if ZERO_OK is false, it means that a size of zero should be
8515 treated as an unspecified size. */
8518 validate_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_object
,
8519 enum tree_code kind
, bool component_p
, bool zero_ok
)
8521 Node_Id gnat_error_node
;
8522 tree type_size
, size
;
8524 /* Return 0 if no size was specified. */
8525 if (uint_size
== No_Uint
)
8528 /* Ignore a negative size since that corresponds to our back-annotation. */
8529 if (UI_Lt (uint_size
, Uint_0
))
8532 /* Find the node to use for error messages. */
8533 if ((Ekind (gnat_object
) == E_Component
8534 || Ekind (gnat_object
) == E_Discriminant
)
8535 && Present (Component_Clause (gnat_object
)))
8536 gnat_error_node
= Last_Bit (Component_Clause (gnat_object
));
8537 else if (Present (Size_Clause (gnat_object
)))
8538 gnat_error_node
= Expression (Size_Clause (gnat_object
));
8540 gnat_error_node
= gnat_object
;
8542 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8543 but cannot be represented in bitsizetype. */
8544 size
= UI_To_gnu (uint_size
, bitsizetype
);
8545 if (TREE_OVERFLOW (size
))
8548 post_error_ne ("component size for& is too large", gnat_error_node
,
8551 post_error_ne ("size for& is too large", gnat_error_node
,
8556 /* Ignore a zero size if it is not permitted. */
8557 if (!zero_ok
&& integer_zerop (size
))
8560 /* The size of objects is always a multiple of a byte. */
8561 if (kind
== VAR_DECL
8562 && !integer_zerop (size_binop (TRUNC_MOD_EXPR
, size
, bitsize_unit_node
)))
8565 post_error_ne ("component size for& is not a multiple of Storage_Unit",
8566 gnat_error_node
, gnat_object
);
8568 post_error_ne ("size for& is not a multiple of Storage_Unit",
8569 gnat_error_node
, gnat_object
);
8573 /* If this is an integral type or a packed array type, the front-end has
8574 already verified the size, so we need not do it here (which would mean
8575 checking against the bounds). However, if this is an aliased object,
8576 it may not be smaller than the type of the object. */
8577 if ((INTEGRAL_TYPE_P (gnu_type
) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type
))
8578 && !(kind
== VAR_DECL
&& Is_Aliased (gnat_object
)))
8581 /* If the object is a record that contains a template, add the size of the
8582 template to the specified size. */
8583 if (TREE_CODE (gnu_type
) == RECORD_TYPE
8584 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
8585 size
= size_binop (PLUS_EXPR
, DECL_SIZE (TYPE_FIELDS (gnu_type
)), size
);
8587 if (kind
== VAR_DECL
8588 /* If a type needs strict alignment, a component of this type in
8589 a packed record cannot be packed and thus uses the type size. */
8590 || (kind
== TYPE_DECL
&& Strict_Alignment (gnat_object
)))
8591 type_size
= TYPE_SIZE (gnu_type
);
8593 type_size
= rm_size (gnu_type
);
8595 /* Modify the size of a discriminated type to be the maximum size. */
8596 if (type_size
&& CONTAINS_PLACEHOLDER_P (type_size
))
8597 type_size
= max_size (type_size
, true);
8599 /* If this is an access type or a fat pointer, the minimum size is that given
8600 by the smallest integral mode that's valid for pointers. */
8601 if (TREE_CODE (gnu_type
) == POINTER_TYPE
|| TYPE_IS_FAT_POINTER_P (gnu_type
))
8603 scalar_int_mode p_mode
= NARROWEST_INT_MODE
;
8604 while (!targetm
.valid_pointer_mode (p_mode
))
8605 p_mode
= GET_MODE_WIDER_MODE (p_mode
).require ();
8606 type_size
= bitsize_int (GET_MODE_BITSIZE (p_mode
));
8609 /* Issue an error either if the default size of the object isn't a constant
8610 or if the new size is smaller than it. */
8611 if (TREE_CODE (type_size
) != INTEGER_CST
8612 || TREE_OVERFLOW (type_size
)
8613 || tree_int_cst_lt (size
, type_size
))
8617 ("component size for& too small{, minimum allowed is ^}",
8618 gnat_error_node
, gnat_object
, type_size
);
8621 ("size for& too small{, minimum allowed is ^}",
8622 gnat_error_node
, gnat_object
, type_size
);
8629 /* Similarly, but both validate and process a value of RM size. This routine
8630 is only called for types. */
8633 set_rm_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_entity
)
8635 Node_Id gnat_attr_node
;
8636 tree old_size
, size
;
8638 /* Do nothing if no size was specified. */
8639 if (uint_size
== No_Uint
)
8642 /* Ignore a negative size since that corresponds to our back-annotation. */
8643 if (UI_Lt (uint_size
, Uint_0
))
8646 /* Only issue an error if a Value_Size clause was explicitly given.
8647 Otherwise, we'd be duplicating an error on the Size clause. */
8649 = Get_Attribute_Definition_Clause (gnat_entity
, Attr_Value_Size
);
8651 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8652 but cannot be represented in bitsizetype. */
8653 size
= UI_To_gnu (uint_size
, bitsizetype
);
8654 if (TREE_OVERFLOW (size
))
8656 if (Present (gnat_attr_node
))
8657 post_error_ne ("Value_Size for& is too large", gnat_attr_node
,
8662 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8663 exists, or this is an integer type, in which case the front-end will
8664 have always set it. */
8665 if (No (gnat_attr_node
)
8666 && integer_zerop (size
)
8667 && !Has_Size_Clause (gnat_entity
)
8668 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
8671 old_size
= rm_size (gnu_type
);
8673 /* If the old size is self-referential, get the maximum size. */
8674 if (CONTAINS_PLACEHOLDER_P (old_size
))
8675 old_size
= max_size (old_size
, true);
8677 /* Issue an error either if the old size of the object isn't a constant or
8678 if the new size is smaller than it. The front-end has already verified
8679 this for scalar and packed array types. */
8680 if (TREE_CODE (old_size
) != INTEGER_CST
8681 || TREE_OVERFLOW (old_size
)
8682 || (AGGREGATE_TYPE_P (gnu_type
)
8683 && !(TREE_CODE (gnu_type
) == ARRAY_TYPE
8684 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type
))
8685 && !(TYPE_IS_PADDING_P (gnu_type
)
8686 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
))) == ARRAY_TYPE
8687 && TYPE_PACKED_ARRAY_TYPE_P
8688 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))
8689 && tree_int_cst_lt (size
, old_size
)))
8691 if (Present (gnat_attr_node
))
8693 ("Value_Size for& too small{, minimum allowed is ^}",
8694 gnat_attr_node
, gnat_entity
, old_size
);
8698 /* Otherwise, set the RM size proper for integral types... */
8699 if ((TREE_CODE (gnu_type
) == INTEGER_TYPE
8700 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
8701 || (TREE_CODE (gnu_type
) == ENUMERAL_TYPE
8702 || TREE_CODE (gnu_type
) == BOOLEAN_TYPE
))
8703 SET_TYPE_RM_SIZE (gnu_type
, size
);
8705 /* ...or the Ada size for record and union types. */
8706 else if (RECORD_OR_UNION_TYPE_P (gnu_type
)
8707 && !TYPE_FAT_POINTER_P (gnu_type
))
8708 SET_TYPE_ADA_SIZE (gnu_type
, size
);
8711 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8712 a type or object whose present alignment is ALIGN. If this alignment is
8713 valid, return it. Otherwise, give an error and return ALIGN. */
8716 validate_alignment (Uint alignment
, Entity_Id gnat_entity
, unsigned int align
)
8718 unsigned int max_allowed_alignment
= get_target_maximum_allowed_alignment ();
8719 unsigned int new_align
;
8720 Node_Id gnat_error_node
;
8722 /* Don't worry about checking alignment if alignment was not specified
8723 by the source program and we already posted an error for this entity. */
8724 if (Error_Posted (gnat_entity
) && !Has_Alignment_Clause (gnat_entity
))
8727 /* Post the error on the alignment clause if any. Note, for the implicit
8728 base type of an array type, the alignment clause is on the first
8730 if (Present (Alignment_Clause (gnat_entity
)))
8731 gnat_error_node
= Expression (Alignment_Clause (gnat_entity
));
8733 else if (Is_Itype (gnat_entity
)
8734 && Is_Array_Type (gnat_entity
)
8735 && Etype (gnat_entity
) == gnat_entity
8736 && Present (Alignment_Clause (First_Subtype (gnat_entity
))))
8738 Expression (Alignment_Clause (First_Subtype (gnat_entity
)));
8741 gnat_error_node
= gnat_entity
;
8743 /* Within GCC, an alignment is an integer, so we must make sure a value is
8744 specified that fits in that range. Also, there is an upper bound to
8745 alignments we can support/allow. */
8746 if (!UI_Is_In_Int_Range (alignment
)
8747 || ((new_align
= UI_To_Int (alignment
)) > max_allowed_alignment
))
8748 post_error_ne_num ("largest supported alignment for& is ^",
8749 gnat_error_node
, gnat_entity
, max_allowed_alignment
);
8750 else if (!(Present (Alignment_Clause (gnat_entity
))
8751 && From_At_Mod (Alignment_Clause (gnat_entity
)))
8752 && new_align
* BITS_PER_UNIT
< align
)
8754 unsigned int double_align
;
8755 bool is_capped_double
, align_clause
;
8757 /* If the default alignment of "double" or larger scalar types is
8758 specifically capped and the new alignment is above the cap, do
8759 not post an error and change the alignment only if there is an
8760 alignment clause; this makes it possible to have the associated
8761 GCC type overaligned by default for performance reasons. */
8762 if ((double_align
= double_float_alignment
) > 0)
8765 = Is_Type (gnat_entity
) ? gnat_entity
: Etype (gnat_entity
);
8767 = is_double_float_or_array (gnat_type
, &align_clause
);
8769 else if ((double_align
= double_scalar_alignment
) > 0)
8772 = Is_Type (gnat_entity
) ? gnat_entity
: Etype (gnat_entity
);
8774 = is_double_scalar_or_array (gnat_type
, &align_clause
);
8777 is_capped_double
= align_clause
= false;
8779 if (is_capped_double
&& new_align
>= double_align
)
8782 align
= new_align
* BITS_PER_UNIT
;
8786 if (is_capped_double
)
8787 align
= double_align
* BITS_PER_UNIT
;
8789 post_error_ne_num ("alignment for& must be at least ^",
8790 gnat_error_node
, gnat_entity
,
8791 align
/ BITS_PER_UNIT
);
8796 new_align
= (new_align
> 0 ? new_align
* BITS_PER_UNIT
: 1);
8797 if (new_align
> align
)
8804 /* Verify that TYPE is something we can implement atomically. If not, issue
8805 an error for GNAT_ENTITY. COMPONENT_P is true if we are being called to
8806 process a component type. */
8809 check_ok_for_atomic_type (tree type
, Entity_Id gnat_entity
, bool component_p
)
8811 Node_Id gnat_error_point
= gnat_entity
;
8814 enum mode_class mclass
;
8818 /* If this is an anonymous base type, nothing to check, the error will be
8819 reported on the source type if need be. */
8820 if (!Comes_From_Source (gnat_entity
))
8823 mode
= TYPE_MODE (type
);
8824 mclass
= GET_MODE_CLASS (mode
);
8825 align
= TYPE_ALIGN (type
);
8826 size
= TYPE_SIZE (type
);
8828 /* Consider all aligned floating-point types atomic and any aligned types
8829 that are represented by integers no wider than a machine word. */
8830 scalar_int_mode int_mode
;
8831 if ((mclass
== MODE_FLOAT
8832 || (is_a
<scalar_int_mode
> (mode
, &int_mode
)
8833 && GET_MODE_BITSIZE (int_mode
) <= BITS_PER_WORD
))
8834 && align
>= GET_MODE_ALIGNMENT (mode
))
8837 /* For the moment, also allow anything that has an alignment equal to its
8838 size and which is smaller than a word. */
8840 && TREE_CODE (size
) == INTEGER_CST
8841 && compare_tree_int (size
, align
) == 0
8842 && align
<= BITS_PER_WORD
)
8845 for (gnat_node
= First_Rep_Item (gnat_entity
);
8846 Present (gnat_node
);
8847 gnat_node
= Next_Rep_Item (gnat_node
))
8848 if (Nkind (gnat_node
) == N_Pragma
)
8850 unsigned char pragma_id
8851 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)));
8853 if ((pragma_id
== Pragma_Atomic
&& !component_p
)
8854 || (pragma_id
== Pragma_Atomic_Components
&& component_p
))
8856 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
8862 post_error_ne ("atomic access to component of & cannot be guaranteed",
8863 gnat_error_point
, gnat_entity
);
8864 else if (Is_Volatile_Full_Access (gnat_entity
))
8865 post_error_ne ("volatile full access to & cannot be guaranteed",
8866 gnat_error_point
, gnat_entity
);
8868 post_error_ne ("atomic access to & cannot be guaranteed",
8869 gnat_error_point
, gnat_entity
);
8873 /* Helper for the intrin compatibility checks family. Evaluate whether
8874 two types are definitely incompatible. */
8877 intrin_types_incompatible_p (tree t1
, tree t2
)
8879 enum tree_code code
;
8881 if (TYPE_MAIN_VARIANT (t1
) == TYPE_MAIN_VARIANT (t2
))
8884 if (TYPE_MODE (t1
) != TYPE_MODE (t2
))
8887 if (TREE_CODE (t1
) != TREE_CODE (t2
))
8890 code
= TREE_CODE (t1
);
8896 return TYPE_PRECISION (t1
) != TYPE_PRECISION (t2
);
8899 case REFERENCE_TYPE
:
8900 /* Assume designated types are ok. We'd need to account for char * and
8901 void * variants to do better, which could rapidly get messy and isn't
8902 clearly worth the effort. */
8912 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8913 on the Ada/builtin argument lists for the INB binding. */
8916 intrin_arglists_compatible_p (intrin_binding_t
* inb
)
8918 function_args_iterator ada_iter
, btin_iter
;
8920 function_args_iter_init (&ada_iter
, inb
->ada_fntype
);
8921 function_args_iter_init (&btin_iter
, inb
->btin_fntype
);
8923 /* Sequence position of the last argument we checked. */
8928 tree ada_type
= function_args_iter_cond (&ada_iter
);
8929 tree btin_type
= function_args_iter_cond (&btin_iter
);
8931 /* If we've exhausted both lists simultaneously, we're done. */
8932 if (!ada_type
&& !btin_type
)
8935 /* If one list is shorter than the other, they fail to match. */
8936 if (!ada_type
|| !btin_type
)
8939 /* If we're done with the Ada args and not with the internal builtin
8940 args, or the other way around, complain. */
8941 if (ada_type
== void_type_node
8942 && btin_type
!= void_type_node
)
8944 post_error ("?Ada arguments list too short!", inb
->gnat_entity
);
8948 if (btin_type
== void_type_node
8949 && ada_type
!= void_type_node
)
8951 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8952 inb
->gnat_entity
, inb
->gnat_entity
, argpos
);
8956 /* Otherwise, check that types match for the current argument. */
8958 if (intrin_types_incompatible_p (ada_type
, btin_type
))
8960 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8961 inb
->gnat_entity
, inb
->gnat_entity
, argpos
);
8966 function_args_iter_next (&ada_iter
);
8967 function_args_iter_next (&btin_iter
);
8973 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8974 on the Ada/builtin return values for the INB binding. */
8977 intrin_return_compatible_p (intrin_binding_t
* inb
)
8979 tree ada_return_type
= TREE_TYPE (inb
->ada_fntype
);
8980 tree btin_return_type
= TREE_TYPE (inb
->btin_fntype
);
8982 /* Accept function imported as procedure, common and convenient. */
8983 if (VOID_TYPE_P (ada_return_type
)
8984 && !VOID_TYPE_P (btin_return_type
))
8987 /* Check return types compatibility otherwise. Note that this
8988 handles void/void as well. */
8989 if (intrin_types_incompatible_p (btin_return_type
, ada_return_type
))
8991 post_error ("?intrinsic binding type mismatch on return value!",
8999 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
9000 compatible. Issue relevant warnings when they are not.
9002 This is intended as a light check to diagnose the most obvious cases, not
9003 as a full fledged type compatibility predicate. It is the programmer's
9004 responsibility to ensure correctness of the Ada declarations in Imports,
9005 especially when binding straight to a compiler internal. */
9008 intrin_profiles_compatible_p (intrin_binding_t
* inb
)
9010 /* Check compatibility on return values and argument lists, each responsible
9011 for posting warnings as appropriate. Ensure use of the proper sloc for
9014 bool arglists_compatible_p
, return_compatible_p
;
9015 location_t saved_location
= input_location
;
9017 Sloc_to_locus (Sloc (inb
->gnat_entity
), &input_location
);
9019 return_compatible_p
= intrin_return_compatible_p (inb
);
9020 arglists_compatible_p
= intrin_arglists_compatible_p (inb
);
9022 input_location
= saved_location
;
9024 return return_compatible_p
&& arglists_compatible_p
;
9027 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
9028 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
9029 specified size for this field. POS_LIST is a position list describing
9030 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
9034 create_field_decl_from (tree old_field
, tree field_type
, tree record_type
,
9035 tree size
, tree pos_list
,
9036 vec
<subst_pair
> subst_list
)
9038 tree t
= TREE_VALUE (purpose_member (old_field
, pos_list
));
9039 tree pos
= TREE_VEC_ELT (t
, 0), bitpos
= TREE_VEC_ELT (t
, 2);
9040 unsigned int offset_align
= tree_to_uhwi (TREE_VEC_ELT (t
, 1));
9041 tree new_pos
, new_field
;
9045 if (CONTAINS_PLACEHOLDER_P (pos
))
9046 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
9047 pos
= SUBSTITUTE_IN_EXPR (pos
, s
->discriminant
, s
->replacement
);
9049 /* If the position is now a constant, we can set it as the position of the
9050 field when we make it. Otherwise, we need to deal with it specially. */
9051 if (TREE_CONSTANT (pos
))
9052 new_pos
= bit_from_pos (pos
, bitpos
);
9054 new_pos
= NULL_TREE
;
9057 = create_field_decl (DECL_NAME (old_field
), field_type
, record_type
,
9058 size
, new_pos
, DECL_PACKED (old_field
),
9059 !DECL_NONADDRESSABLE_P (old_field
));
9063 normalize_offset (&pos
, &bitpos
, offset_align
);
9064 /* Finalize the position. */
9065 DECL_FIELD_OFFSET (new_field
) = variable_size (pos
);
9066 DECL_FIELD_BIT_OFFSET (new_field
) = bitpos
;
9067 SET_DECL_OFFSET_ALIGN (new_field
, offset_align
);
9068 DECL_SIZE (new_field
) = size
;
9069 DECL_SIZE_UNIT (new_field
)
9070 = convert (sizetype
,
9071 size_binop (CEIL_DIV_EXPR
, size
, bitsize_unit_node
));
9072 layout_decl (new_field
, DECL_OFFSET_ALIGN (new_field
));
9075 DECL_INTERNAL_P (new_field
) = DECL_INTERNAL_P (old_field
);
9076 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field
, old_field
);
9077 DECL_DISCRIMINANT_NUMBER (new_field
) = DECL_DISCRIMINANT_NUMBER (old_field
);
9078 TREE_THIS_VOLATILE (new_field
) = TREE_THIS_VOLATILE (old_field
);
9083 /* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
9084 it is the minimal size the REP_PART must have. */
9087 create_rep_part (tree rep_type
, tree record_type
, tree min_size
)
9091 if (min_size
&& !tree_int_cst_lt (TYPE_SIZE (rep_type
), min_size
))
9092 min_size
= NULL_TREE
;
9094 field
= create_field_decl (get_identifier ("REP"), rep_type
, record_type
,
9095 min_size
, NULL_TREE
, 0, 1);
9096 DECL_INTERNAL_P (field
) = 1;
9101 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
9104 get_rep_part (tree record_type
)
9106 tree field
= TYPE_FIELDS (record_type
);
9108 /* The REP part is the first field, internal, another record, and its name
9109 starts with an 'R'. */
9111 && DECL_INTERNAL_P (field
)
9112 && TREE_CODE (TREE_TYPE (field
)) == RECORD_TYPE
9113 && IDENTIFIER_POINTER (DECL_NAME (field
)) [0] == 'R')
9119 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
9122 get_variant_part (tree record_type
)
9126 /* The variant part is the only internal field that is a qualified union. */
9127 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
9128 if (DECL_INTERNAL_P (field
)
9129 && TREE_CODE (TREE_TYPE (field
)) == QUAL_UNION_TYPE
)
9135 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
9136 the list of variants to be used and RECORD_TYPE is the type of the parent.
9137 POS_LIST is a position list describing the layout of fields present in
9138 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
9139 layout. DEBUG_INFO_P is true if we need to write debug information. */
9142 create_variant_part_from (tree old_variant_part
,
9143 vec
<variant_desc
> variant_list
,
9144 tree record_type
, tree pos_list
,
9145 vec
<subst_pair
> subst_list
,
9148 tree offset
= DECL_FIELD_OFFSET (old_variant_part
);
9149 tree old_union_type
= TREE_TYPE (old_variant_part
);
9150 tree new_union_type
, new_variant_part
;
9151 tree union_field_list
= NULL_TREE
;
9155 /* First create the type of the variant part from that of the old one. */
9156 new_union_type
= make_node (QUAL_UNION_TYPE
);
9157 TYPE_NAME (new_union_type
)
9158 = concat_name (TYPE_NAME (record_type
),
9159 IDENTIFIER_POINTER (DECL_NAME (old_variant_part
)));
9161 /* If the position of the variant part is constant, subtract it from the
9162 size of the type of the parent to get the new size. This manual CSE
9163 reduces the code size when not optimizing. */
9164 if (TREE_CODE (offset
) == INTEGER_CST
9165 && TYPE_SIZE (record_type
)
9166 && TYPE_SIZE_UNIT (record_type
))
9168 tree bitpos
= DECL_FIELD_BIT_OFFSET (old_variant_part
);
9169 tree first_bit
= bit_from_pos (offset
, bitpos
);
9170 TYPE_SIZE (new_union_type
)
9171 = size_binop (MINUS_EXPR
, TYPE_SIZE (record_type
), first_bit
);
9172 TYPE_SIZE_UNIT (new_union_type
)
9173 = size_binop (MINUS_EXPR
, TYPE_SIZE_UNIT (record_type
),
9174 byte_from_pos (offset
, bitpos
));
9175 SET_TYPE_ADA_SIZE (new_union_type
,
9176 size_binop (MINUS_EXPR
, TYPE_ADA_SIZE (record_type
),
9178 SET_TYPE_ALIGN (new_union_type
, TYPE_ALIGN (old_union_type
));
9179 relate_alias_sets (new_union_type
, old_union_type
, ALIAS_SET_COPY
);
9182 copy_and_substitute_in_size (new_union_type
, old_union_type
, subst_list
);
9184 /* Now finish up the new variants and populate the union type. */
9185 FOR_EACH_VEC_ELT_REVERSE (variant_list
, i
, v
)
9187 tree old_field
= v
->field
, new_field
;
9188 tree old_variant
, old_variant_subpart
, new_variant
, field_list
;
9190 /* Skip variants that don't belong to this nesting level. */
9191 if (DECL_CONTEXT (old_field
) != old_union_type
)
9194 /* Retrieve the list of fields already added to the new variant. */
9195 new_variant
= v
->new_type
;
9196 field_list
= TYPE_FIELDS (new_variant
);
9198 /* If the old variant had a variant subpart, we need to create a new
9199 variant subpart and add it to the field list. */
9200 old_variant
= v
->type
;
9201 old_variant_subpart
= get_variant_part (old_variant
);
9202 if (old_variant_subpart
)
9204 tree new_variant_subpart
9205 = create_variant_part_from (old_variant_subpart
, variant_list
,
9206 new_variant
, pos_list
, subst_list
,
9208 DECL_CHAIN (new_variant_subpart
) = field_list
;
9209 field_list
= new_variant_subpart
;
9212 /* Finish up the new variant and create the field. */
9213 finish_record_type (new_variant
, nreverse (field_list
), 2, debug_info_p
);
9214 compute_record_mode (new_variant
);
9215 create_type_decl (TYPE_NAME (new_variant
), new_variant
, true,
9216 debug_info_p
, Empty
);
9219 = create_field_decl_from (old_field
, new_variant
, new_union_type
,
9220 TYPE_SIZE (new_variant
),
9221 pos_list
, subst_list
);
9222 DECL_QUALIFIER (new_field
) = v
->qual
;
9223 DECL_INTERNAL_P (new_field
) = 1;
9224 DECL_CHAIN (new_field
) = union_field_list
;
9225 union_field_list
= new_field
;
9228 /* Finish up the union type and create the variant part. Note that we don't
9229 reverse the field list because VARIANT_LIST has been traversed in reverse
9231 finish_record_type (new_union_type
, union_field_list
, 2, debug_info_p
);
9232 compute_record_mode (new_union_type
);
9233 create_type_decl (TYPE_NAME (new_union_type
), new_union_type
, true,
9234 debug_info_p
, Empty
);
9237 = create_field_decl_from (old_variant_part
, new_union_type
, record_type
,
9238 TYPE_SIZE (new_union_type
),
9239 pos_list
, subst_list
);
9240 DECL_INTERNAL_P (new_variant_part
) = 1;
9242 /* With multiple discriminants it is possible for an inner variant to be
9243 statically selected while outer ones are not; in this case, the list
9244 of fields of the inner variant is not flattened and we end up with a
9245 qualified union with a single member. Drop the useless container. */
9246 if (!DECL_CHAIN (union_field_list
))
9248 DECL_CONTEXT (union_field_list
) = record_type
;
9249 DECL_FIELD_OFFSET (union_field_list
)
9250 = DECL_FIELD_OFFSET (new_variant_part
);
9251 DECL_FIELD_BIT_OFFSET (union_field_list
)
9252 = DECL_FIELD_BIT_OFFSET (new_variant_part
);
9253 SET_DECL_OFFSET_ALIGN (union_field_list
,
9254 DECL_OFFSET_ALIGN (new_variant_part
));
9255 new_variant_part
= union_field_list
;
9258 return new_variant_part
;
9261 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
9262 which are both RECORD_TYPE, after applying the substitutions described
9266 copy_and_substitute_in_size (tree new_type
, tree old_type
,
9267 vec
<subst_pair
> subst_list
)
9272 TYPE_SIZE (new_type
) = TYPE_SIZE (old_type
);
9273 TYPE_SIZE_UNIT (new_type
) = TYPE_SIZE_UNIT (old_type
);
9274 SET_TYPE_ADA_SIZE (new_type
, TYPE_ADA_SIZE (old_type
));
9275 SET_TYPE_ALIGN (new_type
, TYPE_ALIGN (old_type
));
9276 relate_alias_sets (new_type
, old_type
, ALIAS_SET_COPY
);
9278 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type
)))
9279 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
9280 TYPE_SIZE (new_type
)
9281 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type
),
9282 s
->discriminant
, s
->replacement
);
9284 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type
)))
9285 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
9286 TYPE_SIZE_UNIT (new_type
)
9287 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type
),
9288 s
->discriminant
, s
->replacement
);
9290 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type
)))
9291 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
9293 (new_type
, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type
),
9294 s
->discriminant
, s
->replacement
));
9296 /* Finalize the size. */
9297 TYPE_SIZE (new_type
) = variable_size (TYPE_SIZE (new_type
));
9298 TYPE_SIZE_UNIT (new_type
) = variable_size (TYPE_SIZE_UNIT (new_type
));
9301 /* Return true if DISC is a stored discriminant of RECORD_TYPE. */
9304 is_stored_discriminant (Entity_Id discr
, Entity_Id record_type
)
9306 if (Is_Tagged_Type (record_type
))
9307 return No (Corresponding_Discriminant (discr
));
9308 else if (Ekind (record_type
) == E_Record_Type
)
9309 return Original_Record_Component (discr
) == discr
;
9314 /* Copy the layout from {GNAT,GNU}_OLD_TYPE to {GNAT,GNU}_NEW_TYPE, which are
9315 both record types, after applying the substitutions described in SUBST_LIST.
9316 DEBUG_INFO_P is true if we need to write debug information for NEW_TYPE. */
9319 copy_and_substitute_in_layout (Entity_Id gnat_new_type
,
9320 Entity_Id gnat_old_type
,
9323 vec
<subst_pair
> gnu_subst_list
,
9326 const bool is_subtype
= (Ekind (gnat_new_type
) == E_Record_Subtype
);
9327 tree gnu_field_list
= NULL_TREE
;
9328 bool selected_variant
, all_constant_pos
= true;
9329 vec
<variant_desc
> gnu_variant_list
;
9331 /* Look for REP and variant parts in the old type. */
9332 tree gnu_rep_part
= get_rep_part (gnu_old_type
);
9333 tree gnu_variant_part
= get_variant_part (gnu_old_type
);
9335 /* If there is a variant part, we must compute whether the constraints
9336 statically select a particular variant. If so, we simply drop the
9337 qualified union and flatten the list of fields. Otherwise we will
9338 build a new qualified union for the variants that are still relevant. */
9339 if (gnu_variant_part
)
9344 gnu_variant_list
= build_variant_list (TREE_TYPE (gnu_variant_part
),
9345 gnu_subst_list
, vNULL
);
9347 /* If all the qualifiers are unconditionally true, the innermost variant
9348 is statically selected. */
9349 selected_variant
= true;
9350 FOR_EACH_VEC_ELT (gnu_variant_list
, i
, v
)
9351 if (!integer_onep (v
->qual
))
9353 selected_variant
= false;
9357 /* Otherwise, create the new variants. */
9358 if (!selected_variant
)
9359 FOR_EACH_VEC_ELT (gnu_variant_list
, i
, v
)
9361 tree old_variant
= v
->type
;
9362 tree new_variant
= make_node (RECORD_TYPE
);
9364 = concat_name (DECL_NAME (gnu_variant_part
),
9365 IDENTIFIER_POINTER (DECL_NAME (v
->field
)));
9366 TYPE_NAME (new_variant
)
9367 = concat_name (TYPE_NAME (gnu_new_type
),
9368 IDENTIFIER_POINTER (suffix
));
9369 TYPE_REVERSE_STORAGE_ORDER (new_variant
)
9370 = TYPE_REVERSE_STORAGE_ORDER (gnu_new_type
);
9371 copy_and_substitute_in_size (new_variant
, old_variant
,
9373 v
->new_type
= new_variant
;
9378 gnu_variant_list
.create (0);
9379 selected_variant
= false;
9382 /* Make a list of fields and their position in the old type. */
9384 = build_position_list (gnu_old_type
,
9385 gnu_variant_list
.exists () && !selected_variant
,
9386 size_zero_node
, bitsize_zero_node
,
9387 BIGGEST_ALIGNMENT
, NULL_TREE
);
9389 /* Now go down every component in the new type and compute its size and
9390 position from those of the component in the old type and the stored
9391 constraints of the new type. */
9392 Entity_Id gnat_field
, gnat_old_field
;
9393 for (gnat_field
= First_Entity (gnat_new_type
);
9394 Present (gnat_field
);
9395 gnat_field
= Next_Entity (gnat_field
))
9396 if ((Ekind (gnat_field
) == E_Component
9397 || (Ekind (gnat_field
) == E_Discriminant
9398 && is_stored_discriminant (gnat_field
, gnat_new_type
)))
9399 && (gnat_old_field
= is_subtype
9400 ? Original_Record_Component (gnat_field
)
9401 : Corresponding_Record_Component (gnat_field
))
9402 && Underlying_Type (Scope (gnat_old_field
)) == gnat_old_type
9403 && present_gnu_tree (gnat_old_field
))
9405 Name_Id gnat_name
= Chars (gnat_field
);
9406 tree gnu_old_field
= get_gnu_tree (gnat_old_field
);
9407 if (TREE_CODE (gnu_old_field
) == COMPONENT_REF
)
9408 gnu_old_field
= TREE_OPERAND (gnu_old_field
, 1);
9409 tree gnu_context
= DECL_CONTEXT (gnu_old_field
);
9410 tree gnu_field
, gnu_field_type
, gnu_size
, gnu_pos
;
9411 tree gnu_cont_type
, gnu_last
= NULL_TREE
;
9413 /* If the type is the same, retrieve the GCC type from the
9414 old field to take into account possible adjustments. */
9415 if (Etype (gnat_field
) == Etype (gnat_old_field
))
9416 gnu_field_type
= TREE_TYPE (gnu_old_field
);
9418 gnu_field_type
= gnat_to_gnu_type (Etype (gnat_field
));
9420 /* If there was a component clause, the field types must be the same
9421 for the old and new types, so copy the data from the old field to
9422 avoid recomputation here. Also if the field is justified modular
9423 and the optimization in gnat_to_gnu_field was applied. */
9424 if (Present (Component_Clause (gnat_old_field
))
9425 || (TREE_CODE (gnu_field_type
) == RECORD_TYPE
9426 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
9427 && TREE_TYPE (TYPE_FIELDS (gnu_field_type
))
9428 == TREE_TYPE (gnu_old_field
)))
9430 gnu_size
= DECL_SIZE (gnu_old_field
);
9431 gnu_field_type
= TREE_TYPE (gnu_old_field
);
9434 /* If the old field was packed and of constant size, we have to get the
9435 old size here as it might differ from what the Etype conveys and the
9436 latter might overlap with the following field. Try to arrange the
9437 type for possible better packing along the way. */
9438 else if (DECL_PACKED (gnu_old_field
)
9439 && TREE_CODE (DECL_SIZE (gnu_old_field
)) == INTEGER_CST
)
9441 gnu_size
= DECL_SIZE (gnu_old_field
);
9442 if (RECORD_OR_UNION_TYPE_P (gnu_field_type
)
9443 && !TYPE_FAT_POINTER_P (gnu_field_type
)
9444 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type
)))
9445 gnu_field_type
= make_packable_type (gnu_field_type
, true);
9449 gnu_size
= TYPE_SIZE (gnu_field_type
);
9451 /* If the context of the old field is the old type or its REP part,
9452 put the field directly in the new type; otherwise look up the
9453 context in the variant list and put the field either in the new
9454 type if there is a selected variant or in one new variant. */
9455 if (gnu_context
== gnu_old_type
9456 || (gnu_rep_part
&& gnu_context
== TREE_TYPE (gnu_rep_part
)))
9457 gnu_cont_type
= gnu_new_type
;
9464 FOR_EACH_VEC_ELT (gnu_variant_list
, i
, v
)
9465 if (gnu_context
== v
->type
9466 || ((rep_part
= get_rep_part (v
->type
))
9467 && gnu_context
== TREE_TYPE (rep_part
)))
9471 gnu_cont_type
= selected_variant
? gnu_new_type
: v
->new_type
;
9473 /* The front-end may pass us "ghost" components if it fails to
9474 recognize that a constrain statically selects a particular
9475 variant. Discard them. */
9479 /* Now create the new field modeled on the old one. */
9481 = create_field_decl_from (gnu_old_field
, gnu_field_type
,
9482 gnu_cont_type
, gnu_size
,
9483 gnu_pos_list
, gnu_subst_list
);
9484 gnu_pos
= DECL_FIELD_OFFSET (gnu_field
);
9486 /* If the context is a variant, put it in the new variant directly. */
9487 if (gnu_cont_type
!= gnu_new_type
)
9489 DECL_CHAIN (gnu_field
) = TYPE_FIELDS (gnu_cont_type
);
9490 TYPE_FIELDS (gnu_cont_type
) = gnu_field
;
9493 /* To match the layout crafted in components_to_record, if this is
9494 the _Tag or _Parent field, put it before any other fields. */
9495 else if (gnat_name
== Name_uTag
|| gnat_name
== Name_uParent
)
9496 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
9498 /* Similarly, if this is the _Controller field, put it before the
9499 other fields except for the _Tag or _Parent field. */
9500 else if (gnat_name
== Name_uController
&& gnu_last
)
9502 DECL_CHAIN (gnu_field
) = DECL_CHAIN (gnu_last
);
9503 DECL_CHAIN (gnu_last
) = gnu_field
;
9506 /* Otherwise, put it after the other fields. */
9509 DECL_CHAIN (gnu_field
) = gnu_field_list
;
9510 gnu_field_list
= gnu_field
;
9512 gnu_last
= gnu_field
;
9513 if (TREE_CODE (gnu_pos
) != INTEGER_CST
)
9514 all_constant_pos
= false;
9517 /* For a stored discriminant in a derived type, replace the field. */
9518 if (!is_subtype
&& Ekind (gnat_field
) == E_Discriminant
)
9520 tree gnu_ref
= get_gnu_tree (gnat_field
);
9521 TREE_OPERAND (gnu_ref
, 1) = gnu_field
;
9524 save_gnu_tree (gnat_field
, gnu_field
, false);
9527 /* If there is a variant list, a selected variant and the fields all have a
9528 constant position, put them in order of increasing position to match that
9529 of constant CONSTRUCTORs. Likewise if there is no variant list but a REP
9530 part, since the latter has been flattened in the process. */
9531 if ((gnu_variant_list
.exists () ? selected_variant
: gnu_rep_part
!= NULL
)
9532 && all_constant_pos
)
9534 const int len
= list_length (gnu_field_list
);
9535 tree
*field_arr
= XALLOCAVEC (tree
, len
), t
= gnu_field_list
;
9537 for (int i
= 0; t
; t
= DECL_CHAIN (t
), i
++)
9540 qsort (field_arr
, len
, sizeof (tree
), compare_field_bitpos
);
9542 gnu_field_list
= NULL_TREE
;
9543 for (int i
= 0; i
< len
; i
++)
9545 DECL_CHAIN (field_arr
[i
]) = gnu_field_list
;
9546 gnu_field_list
= field_arr
[i
];
9550 /* If there is a variant list and no selected variant, we need to create the
9551 nest of variant parts from the old nest. */
9552 else if (gnu_variant_list
.exists () && !selected_variant
)
9554 tree new_variant_part
9555 = create_variant_part_from (gnu_variant_part
, gnu_variant_list
,
9556 gnu_new_type
, gnu_pos_list
,
9557 gnu_subst_list
, debug_info_p
);
9558 DECL_CHAIN (new_variant_part
) = gnu_field_list
;
9559 gnu_field_list
= new_variant_part
;
9562 gnu_variant_list
.release ();
9563 gnu_subst_list
.release ();
9565 gnu_field_list
= nreverse (gnu_field_list
);
9567 /* If NEW_TYPE is a subtype, it inherits all the attributes from OLD_TYPE.
9568 Otherwise sizes and alignment must be computed independently. */
9571 finish_record_type (gnu_new_type
, gnu_field_list
, 2, debug_info_p
);
9572 compute_record_mode (gnu_new_type
);
9575 finish_record_type (gnu_new_type
, gnu_field_list
, 1, debug_info_p
);
9577 /* Now go through the entities again looking for Itypes that we have not yet
9578 elaborated (e.g. Etypes of fields that have Original_Components). */
9579 for (Entity_Id gnat_field
= First_Entity (gnat_new_type
);
9580 Present (gnat_field
);
9581 gnat_field
= Next_Entity (gnat_field
))
9582 if ((Ekind (gnat_field
) == E_Component
9583 || Ekind (gnat_field
) == E_Discriminant
)
9584 && Is_Itype (Etype (gnat_field
))
9585 && !present_gnu_tree (Etype (gnat_field
)))
9586 gnat_to_gnu_entity (Etype (gnat_field
), NULL_TREE
, false);
9589 /* Associate to GNU_TYPE, the translation of GNAT_ENTITY, which is
9590 the implementation type of a packed array type (Is_Packed_Array_Impl_Type),
9591 the original array type if it has been translated. This association is a
9592 parallel type for GNAT encodings or a debug type for standard DWARF. Note
9593 that for standard DWARF, we also want to get the original type name. */
9596 associate_original_type_to_packed_array (tree gnu_type
, Entity_Id gnat_entity
)
9598 Entity_Id gnat_original_array_type
9599 = Underlying_Type (Original_Array_Type (gnat_entity
));
9600 tree gnu_original_array_type
;
9602 if (!present_gnu_tree (gnat_original_array_type
))
9605 gnu_original_array_type
= gnat_to_gnu_type (gnat_original_array_type
);
9607 if (TYPE_IS_DUMMY_P (gnu_original_array_type
))
9610 if (gnat_encodings
== DWARF_GNAT_ENCODINGS_MINIMAL
)
9612 tree original_name
= TYPE_NAME (gnu_original_array_type
);
9614 if (TREE_CODE (original_name
) == TYPE_DECL
)
9615 original_name
= DECL_NAME (original_name
);
9617 SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type
, gnu_original_array_type
);
9618 TYPE_NAME (gnu_type
) = original_name
;
9621 add_parallel_type (gnu_type
, gnu_original_array_type
);
9624 /* Given a type T, a FIELD_DECL F, and a replacement value R, return an
9625 equivalent type with adjusted size expressions where all occurrences
9626 of references to F in a PLACEHOLDER_EXPR have been replaced by R.
9628 The function doesn't update the layout of the type, i.e. it assumes
9629 that the substitution is purely formal. That's why the replacement
9630 value R must itself contain a PLACEHOLDER_EXPR. */
9633 substitute_in_type (tree t
, tree f
, tree r
)
9637 gcc_assert (CONTAINS_PLACEHOLDER_P (r
));
9639 switch (TREE_CODE (t
))
9646 /* First the domain types of arrays. */
9647 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t
))
9648 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t
)))
9650 tree low
= SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t
), f
, r
);
9651 tree high
= SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t
), f
, r
);
9653 if (low
== TYPE_GCC_MIN_VALUE (t
) && high
== TYPE_GCC_MAX_VALUE (t
))
9657 TYPE_GCC_MIN_VALUE (nt
) = low
;
9658 TYPE_GCC_MAX_VALUE (nt
) = high
;
9660 if (TREE_CODE (t
) == INTEGER_TYPE
&& TYPE_INDEX_TYPE (t
))
9662 (nt
, substitute_in_type (TYPE_INDEX_TYPE (t
), f
, r
));
9667 /* Then the subtypes. */
9668 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t
))
9669 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t
)))
9671 tree low
= SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t
), f
, r
);
9672 tree high
= SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t
), f
, r
);
9674 if (low
== TYPE_RM_MIN_VALUE (t
) && high
== TYPE_RM_MAX_VALUE (t
))
9678 SET_TYPE_RM_MIN_VALUE (nt
, low
);
9679 SET_TYPE_RM_MAX_VALUE (nt
, high
);
9687 nt
= substitute_in_type (TREE_TYPE (t
), f
, r
);
9688 if (nt
== TREE_TYPE (t
))
9691 return build_complex_type (nt
);
9694 /* These should never show up here. */
9699 tree component
= substitute_in_type (TREE_TYPE (t
), f
, r
);
9700 tree domain
= substitute_in_type (TYPE_DOMAIN (t
), f
, r
);
9702 if (component
== TREE_TYPE (t
) && domain
== TYPE_DOMAIN (t
))
9705 nt
= build_nonshared_array_type (component
, domain
);
9706 SET_TYPE_ALIGN (nt
, TYPE_ALIGN (t
));
9707 TYPE_USER_ALIGN (nt
) = TYPE_USER_ALIGN (t
);
9708 SET_TYPE_MODE (nt
, TYPE_MODE (t
));
9709 TYPE_SIZE (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t
), f
, r
);
9710 TYPE_SIZE_UNIT (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t
), f
, r
);
9711 TYPE_MULTI_ARRAY_P (nt
) = TYPE_MULTI_ARRAY_P (t
);
9712 TYPE_CONVENTION_FORTRAN_P (nt
) = TYPE_CONVENTION_FORTRAN_P (t
);
9713 if (TYPE_REVERSE_STORAGE_ORDER (t
))
9714 set_reverse_storage_order_on_array_type (nt
);
9715 if (TYPE_NONALIASED_COMPONENT (t
))
9716 set_nonaliased_component_on_array_type (nt
);
9722 case QUAL_UNION_TYPE
:
9724 bool changed_field
= false;
9727 /* Start out with no fields, make new fields, and chain them
9728 in. If we haven't actually changed the type of any field,
9729 discard everything we've done and return the old type. */
9731 TYPE_FIELDS (nt
) = NULL_TREE
;
9733 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
9735 tree new_field
= copy_node (field
), new_n
;
9737 new_n
= substitute_in_type (TREE_TYPE (field
), f
, r
);
9738 if (new_n
!= TREE_TYPE (field
))
9740 TREE_TYPE (new_field
) = new_n
;
9741 changed_field
= true;
9744 new_n
= SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field
), f
, r
);
9745 if (new_n
!= DECL_FIELD_OFFSET (field
))
9747 DECL_FIELD_OFFSET (new_field
) = new_n
;
9748 changed_field
= true;
9751 /* Do the substitution inside the qualifier, if any. */
9752 if (TREE_CODE (t
) == QUAL_UNION_TYPE
)
9754 new_n
= SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field
), f
, r
);
9755 if (new_n
!= DECL_QUALIFIER (field
))
9757 DECL_QUALIFIER (new_field
) = new_n
;
9758 changed_field
= true;
9762 DECL_CONTEXT (new_field
) = nt
;
9763 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field
, field
);
9765 DECL_CHAIN (new_field
) = TYPE_FIELDS (nt
);
9766 TYPE_FIELDS (nt
) = new_field
;
9772 TYPE_FIELDS (nt
) = nreverse (TYPE_FIELDS (nt
));
9773 TYPE_SIZE (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t
), f
, r
);
9774 TYPE_SIZE_UNIT (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t
), f
, r
);
9775 SET_TYPE_ADA_SIZE (nt
, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t
), f
, r
));
9784 /* Return the RM size of GNU_TYPE. This is the actual number of bits
9785 needed to represent the object. */
9788 rm_size (tree gnu_type
)
9790 /* For integral types, we store the RM size explicitly. */
9791 if (INTEGRAL_TYPE_P (gnu_type
) && TYPE_RM_SIZE (gnu_type
))
9792 return TYPE_RM_SIZE (gnu_type
);
9794 /* Return the RM size of the actual data plus the size of the template. */
9795 if (TREE_CODE (gnu_type
) == RECORD_TYPE
9796 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
9798 size_binop (PLUS_EXPR
,
9799 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)))),
9800 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
9802 /* For record or union types, we store the size explicitly. */
9803 if (RECORD_OR_UNION_TYPE_P (gnu_type
)
9804 && !TYPE_FAT_POINTER_P (gnu_type
)
9805 && TYPE_ADA_SIZE (gnu_type
))
9806 return TYPE_ADA_SIZE (gnu_type
);
9808 /* For other types, this is just the size. */
9809 return TYPE_SIZE (gnu_type
);
9812 /* Return the name to be used for GNAT_ENTITY. If a type, create a
9813 fully-qualified name, possibly with type information encoding.
9814 Otherwise, return the name. */
9817 get_entity_char (Entity_Id gnat_entity
)
9819 Get_Encoded_Name (gnat_entity
);
9820 return ggc_strdup (Name_Buffer
);
9824 get_entity_name (Entity_Id gnat_entity
)
9826 Get_Encoded_Name (gnat_entity
);
9827 return get_identifier_with_length (Name_Buffer
, Name_Len
);
9830 /* Return an identifier representing the external name to be used for
9831 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
9832 and the specified suffix. */
9835 create_concat_name (Entity_Id gnat_entity
, const char *suffix
)
9837 const Entity_Kind kind
= Ekind (gnat_entity
);
9838 const bool has_suffix
= (suffix
!= NULL
);
9839 String_Template temp
= {1, has_suffix
? strlen (suffix
) : 0};
9840 String_Pointer sp
= {suffix
, &temp
};
9842 Get_External_Name (gnat_entity
, has_suffix
, sp
);
9844 /* A variable using the Stdcall convention lives in a DLL. We adjust
9845 its name to use the jump table, the _imp__NAME contains the address
9846 for the NAME variable. */
9847 if ((kind
== E_Variable
|| kind
== E_Constant
)
9848 && Has_Stdcall_Convention (gnat_entity
))
9850 const int len
= strlen (STDCALL_PREFIX
) + Name_Len
;
9851 char *new_name
= (char *) alloca (len
+ 1);
9852 strcpy (new_name
, STDCALL_PREFIX
);
9853 strcat (new_name
, Name_Buffer
);
9854 return get_identifier_with_length (new_name
, len
);
9857 return get_identifier_with_length (Name_Buffer
, Name_Len
);
9860 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
9861 string, return a new IDENTIFIER_NODE that is the concatenation of
9862 the name followed by "___" and the specified suffix. */
9865 concat_name (tree gnu_name
, const char *suffix
)
9867 const int len
= IDENTIFIER_LENGTH (gnu_name
) + 3 + strlen (suffix
);
9868 char *new_name
= (char *) alloca (len
+ 1);
9869 strcpy (new_name
, IDENTIFIER_POINTER (gnu_name
));
9870 strcat (new_name
, "___");
9871 strcat (new_name
, suffix
);
9872 return get_identifier_with_length (new_name
, len
);
9875 /* Initialize data structures of the decl.c module. */
9878 init_gnat_decl (void)
9880 /* Initialize the cache of annotated values. */
9881 annotate_value_cache
= hash_table
<value_annotation_hasher
>::create_ggc (512);
9883 /* Initialize the association of dummy types with subprograms. */
9884 dummy_to_subprog_map
= hash_table
<dummy_type_hasher
>::create_ggc (512);
9887 /* Destroy data structures of the decl.c module. */
9890 destroy_gnat_decl (void)
9892 /* Destroy the cache of annotated values. */
9893 annotate_value_cache
->empty ();
9894 annotate_value_cache
= NULL
;
9896 /* Destroy the association of dummy types with subprograms. */
9897 dummy_to_subprog_map
->empty ();
9898 dummy_to_subprog_map
= NULL
;
9901 #include "gt-ada-decl.h"