1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2011, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License along with GCC; see the file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
35 #include "tree-inline.h"
53 /* Convention_Stdcall should be processed in a specific way on 32 bits
54 Windows targets only. The macro below is a helper to avoid having to
55 check for a Windows specific attribute throughout this unit. */
57 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
59 #define Has_Stdcall_Convention(E) \
60 (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
62 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
65 #define Has_Stdcall_Convention(E) 0
68 /* Stack realignment is necessary for functions with foreign conventions when
69 the ABI doesn't mandate as much as what the compiler assumes - that is, up
70 to PREFERRED_STACK_BOUNDARY.
72 Such realignment can be requested with a dedicated function type attribute
73 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
74 characterize the situations where the attribute should be set. We rely on
75 compiler configuration settings for 'main' to decide. */
77 #ifdef MAIN_STACK_BOUNDARY
78 #define FOREIGN_FORCE_REALIGN_STACK \
79 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
81 #define FOREIGN_FORCE_REALIGN_STACK 0
86 struct incomplete
*next
;
91 /* These variables are used to defer recursively expanding incomplete types
92 while we are processing an array, a record or a subprogram type. */
93 static int defer_incomplete_level
= 0;
94 static struct incomplete
*defer_incomplete_list
;
96 /* This variable is used to delay expanding From_With_Type types until the
98 static struct incomplete
*defer_limited_with
;
100 /* These variables are used to defer finalizing types. The element of the
101 list is the TYPE_DECL associated with the type. */
102 static int defer_finalize_level
= 0;
103 static VEC (tree
,heap
) *defer_finalize_list
;
105 typedef struct subst_pair_d
{
110 DEF_VEC_O(subst_pair
);
111 DEF_VEC_ALLOC_O(subst_pair
,heap
);
113 typedef struct variant_desc_d
{
114 /* The type of the variant. */
117 /* The associated field. */
120 /* The value of the qualifier. */
123 /* The record associated with this variant. */
127 DEF_VEC_O(variant_desc
);
128 DEF_VEC_ALLOC_O(variant_desc
,heap
);
130 /* A hash table used to cache the result of annotate_value. */
131 static GTY ((if_marked ("tree_int_map_marked_p"),
132 param_is (struct tree_int_map
))) htab_t annotate_value_cache
;
141 static void relate_alias_sets (tree
, tree
, enum alias_set_op
);
143 static bool allocatable_size_p (tree
, bool);
144 static void prepend_one_attribute_to (struct attrib
**,
145 enum attr_type
, tree
, tree
, Node_Id
);
146 static void prepend_attributes (Entity_Id
, struct attrib
**);
147 static tree
elaborate_expression (Node_Id
, Entity_Id
, tree
, bool, bool, bool);
148 static bool is_variable_size (tree
);
149 static tree
elaborate_expression_1 (tree
, Entity_Id
, tree
, bool, bool);
150 static tree
elaborate_expression_2 (tree
, Entity_Id
, tree
, bool, bool,
152 static tree
make_packable_type (tree
, bool);
153 static tree
gnat_to_gnu_component_type (Entity_Id
, bool, bool);
154 static tree
gnat_to_gnu_param (Entity_Id
, Mechanism_Type
, Entity_Id
, bool,
156 static tree
gnat_to_gnu_field (Entity_Id
, tree
, int, bool, bool);
157 static bool same_discriminant_p (Entity_Id
, Entity_Id
);
158 static bool array_type_has_nonaliased_component (tree
, Entity_Id
);
159 static bool compile_time_known_address_p (Node_Id
);
160 static bool cannot_be_superflat_p (Node_Id
);
161 static bool constructor_address_p (tree
);
162 static void components_to_record (tree
, Node_Id
, tree
, int, bool, bool, bool,
163 bool, bool, bool, bool, tree
*);
164 static Uint
annotate_value (tree
);
165 static void annotate_rep (Entity_Id
, tree
);
166 static tree
build_position_list (tree
, bool, tree
, tree
, unsigned int, tree
);
167 static VEC(subst_pair
,heap
) *build_subst_list (Entity_Id
, Entity_Id
, bool);
168 static VEC(variant_desc
,heap
) *build_variant_list (tree
,
169 VEC(subst_pair
,heap
) *,
170 VEC(variant_desc
,heap
) *);
171 static tree
validate_size (Uint
, tree
, Entity_Id
, enum tree_code
, bool, bool);
172 static void set_rm_size (Uint
, tree
, Entity_Id
);
173 static tree
make_type_from_size (tree
, tree
, bool);
174 static unsigned int validate_alignment (Uint
, Entity_Id
, unsigned int);
175 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT
);
176 static void check_ok_for_atomic (tree
, Entity_Id
, bool);
177 static tree
create_field_decl_from (tree
, tree
, tree
, tree
, tree
,
178 VEC(subst_pair
,heap
) *);
179 static tree
get_rep_part (tree
);
180 static tree
create_variant_part_from (tree
, VEC(variant_desc
,heap
) *, tree
,
181 tree
, VEC(subst_pair
,heap
) *);
182 static void copy_and_substitute_in_size (tree
, tree
, VEC(subst_pair
,heap
) *);
183 static void rest_of_type_decl_compilation_no_defer (tree
);
185 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
186 to pass around calls performing profile compatibility checks. */
189 Entity_Id gnat_entity
; /* The Ada subprogram entity. */
190 tree ada_fntype
; /* The corresponding GCC type node. */
191 tree btin_fntype
; /* The GCC builtin function type node. */
194 static bool intrin_profiles_compatible_p (intrin_binding_t
*);
196 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
197 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
198 and associate the ..._DECL node with the input GNAT defining identifier.
200 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
201 initial value (in GCC tree form). This is optional for a variable. For
202 a renamed entity, GNU_EXPR gives the object being renamed.
204 DEFINITION is nonzero if this call is intended for a definition. This is
205 used for separate compilation where it is necessary to know whether an
206 external declaration or a definition must be created if the GCC equivalent
207 was not created previously. The value of 1 is normally used for a nonzero
208 DEFINITION, but a value of 2 is used in special circumstances, defined in
212 gnat_to_gnu_entity (Entity_Id gnat_entity
, tree gnu_expr
, int definition
)
214 /* Contains the kind of the input GNAT node. */
215 const Entity_Kind kind
= Ekind (gnat_entity
);
216 /* True if this is a type. */
217 const bool is_type
= IN (kind
, Type_Kind
);
218 /* True if debug info is requested for this entity. */
219 const bool debug_info_p
= Needs_Debug_Info (gnat_entity
);
220 /* True if this entity is to be considered as imported. */
221 const bool imported_p
222 = (Is_Imported (gnat_entity
) && No (Address_Clause (gnat_entity
)));
223 /* For a type, contains the equivalent GNAT node to be used in gigi. */
224 Entity_Id gnat_equiv_type
= Empty
;
225 /* Temporary used to walk the GNAT tree. */
227 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
228 This node will be associated with the GNAT node by calling at the end
229 of the `switch' statement. */
230 tree gnu_decl
= NULL_TREE
;
231 /* Contains the GCC type to be used for the GCC node. */
232 tree gnu_type
= NULL_TREE
;
233 /* Contains the GCC size tree to be used for the GCC node. */
234 tree gnu_size
= NULL_TREE
;
235 /* Contains the GCC name to be used for the GCC node. */
236 tree gnu_entity_name
;
237 /* True if we have already saved gnu_decl as a GNAT association. */
239 /* True if we incremented defer_incomplete_level. */
240 bool this_deferred
= false;
241 /* True if we incremented force_global. */
242 bool this_global
= false;
243 /* True if we should check to see if elaborated during processing. */
244 bool maybe_present
= false;
245 /* True if we made GNU_DECL and its type here. */
246 bool this_made_decl
= false;
247 /* Size and alignment of the GCC node, if meaningful. */
248 unsigned int esize
= 0, align
= 0;
249 /* Contains the list of attributes directly attached to the entity. */
250 struct attrib
*attr_list
= NULL
;
252 /* Since a use of an Itype is a definition, process it as such if it
253 is not in a with'ed unit. */
256 && Is_Itype (gnat_entity
)
257 && !present_gnu_tree (gnat_entity
)
258 && In_Extended_Main_Code_Unit (gnat_entity
))
260 /* Ensure that we are in a subprogram mentioned in the Scope chain of
261 this entity, our current scope is global, or we encountered a task
262 or entry (where we can't currently accurately check scoping). */
263 if (!current_function_decl
264 || DECL_ELABORATION_PROC_P (current_function_decl
))
266 process_type (gnat_entity
);
267 return get_gnu_tree (gnat_entity
);
270 for (gnat_temp
= Scope (gnat_entity
);
272 gnat_temp
= Scope (gnat_temp
))
274 if (Is_Type (gnat_temp
))
275 gnat_temp
= Underlying_Type (gnat_temp
);
277 if (Ekind (gnat_temp
) == E_Subprogram_Body
)
279 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp
)));
281 if (IN (Ekind (gnat_temp
), Subprogram_Kind
)
282 && Present (Protected_Body_Subprogram (gnat_temp
)))
283 gnat_temp
= Protected_Body_Subprogram (gnat_temp
);
285 if (Ekind (gnat_temp
) == E_Entry
286 || Ekind (gnat_temp
) == E_Entry_Family
287 || Ekind (gnat_temp
) == E_Task_Type
288 || (IN (Ekind (gnat_temp
), Subprogram_Kind
)
289 && present_gnu_tree (gnat_temp
)
290 && (current_function_decl
291 == gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0))))
293 process_type (gnat_entity
);
294 return get_gnu_tree (gnat_entity
);
298 /* This abort means the Itype has an incorrect scope, i.e. that its
299 scope does not correspond to the subprogram it is declared in. */
303 /* If we've already processed this entity, return what we got last time.
304 If we are defining the node, we should not have already processed it.
305 In that case, we will abort below when we try to save a new GCC tree
306 for this object. We also need to handle the case of getting a dummy
307 type when a Full_View exists. */
308 if ((!definition
|| (is_type
&& imported_p
))
309 && present_gnu_tree (gnat_entity
))
311 gnu_decl
= get_gnu_tree (gnat_entity
);
313 if (TREE_CODE (gnu_decl
) == TYPE_DECL
314 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
))
315 && IN (kind
, Incomplete_Or_Private_Kind
)
316 && Present (Full_View (gnat_entity
)))
319 = gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 0);
320 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
321 save_gnu_tree (gnat_entity
, gnu_decl
, false);
327 /* If this is a numeric or enumeral type, or an access type, a nonzero
328 Esize must be specified unless it was specified by the programmer. */
329 gcc_assert (!Unknown_Esize (gnat_entity
)
330 || Has_Size_Clause (gnat_entity
)
331 || (!IN (kind
, Numeric_Kind
)
332 && !IN (kind
, Enumeration_Kind
)
333 && (!IN (kind
, Access_Kind
)
334 || kind
== E_Access_Protected_Subprogram_Type
335 || kind
== E_Anonymous_Access_Protected_Subprogram_Type
336 || kind
== E_Access_Subtype
)));
338 /* The RM size must be specified for all discrete and fixed-point types. */
339 gcc_assert (!(IN (kind
, Discrete_Or_Fixed_Point_Kind
)
340 && Unknown_RM_Size (gnat_entity
)));
342 /* If we get here, it means we have not yet done anything with this entity.
343 If we are not defining it, it must be a type or an entity that is defined
344 elsewhere or externally, otherwise we should have defined it already. */
345 gcc_assert (definition
346 || type_annotate_only
348 || kind
== E_Discriminant
349 || kind
== E_Component
351 || (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
352 || Is_Public (gnat_entity
));
354 /* Get the name of the entity and set up the line number and filename of
355 the original definition for use in any decl we make. */
356 gnu_entity_name
= get_entity_name (gnat_entity
);
357 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
359 /* For cases when we are not defining (i.e., we are referencing from
360 another compilation unit) public entities, show we are at global level
361 for the purpose of computing scopes. Don't do this for components or
362 discriminants since the relevant test is whether or not the record is
363 being defined. Don't do this for constants either as we'll look into
364 their defining expression in the local context. */
366 && kind
!= E_Component
367 && kind
!= E_Discriminant
368 && kind
!= E_Constant
369 && Is_Public (gnat_entity
)
370 && !Is_Statically_Allocated (gnat_entity
))
371 force_global
++, this_global
= true;
373 /* Handle any attributes directly attached to the entity. */
374 if (Has_Gigi_Rep_Item (gnat_entity
))
375 prepend_attributes (gnat_entity
, &attr_list
);
377 /* Do some common processing for types. */
380 /* Compute the equivalent type to be used in gigi. */
381 gnat_equiv_type
= Gigi_Equivalent_Type (gnat_entity
);
383 /* Machine_Attributes on types are expected to be propagated to
384 subtypes. The corresponding Gigi_Rep_Items are only attached
385 to the first subtype though, so we handle the propagation here. */
386 if (Base_Type (gnat_entity
) != gnat_entity
387 && !Is_First_Subtype (gnat_entity
)
388 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity
))))
389 prepend_attributes (First_Subtype (Base_Type (gnat_entity
)),
392 /* Compute a default value for the size of the type. */
393 if (Known_Esize (gnat_entity
)
394 && UI_Is_In_Int_Range (Esize (gnat_entity
)))
396 unsigned int max_esize
;
397 esize
= UI_To_Int (Esize (gnat_entity
));
399 if (IN (kind
, Float_Kind
))
400 max_esize
= fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE
);
401 else if (IN (kind
, Access_Kind
))
402 max_esize
= POINTER_SIZE
* 2;
404 max_esize
= LONG_LONG_TYPE_SIZE
;
406 if (esize
> max_esize
)
414 /* If this is a use of a deferred constant without address clause,
415 get its full definition. */
417 && No (Address_Clause (gnat_entity
))
418 && Present (Full_View (gnat_entity
)))
421 = gnat_to_gnu_entity (Full_View (gnat_entity
), gnu_expr
, 0);
426 /* If we have an external constant that we are not defining, get the
427 expression that is was defined to represent. We may throw it away
428 later if it is not a constant. But do not retrieve the expression
429 if it is an allocator because the designated type might be dummy
432 && !No_Initialization (Declaration_Node (gnat_entity
))
433 && Present (Expression (Declaration_Node (gnat_entity
)))
434 && Nkind (Expression (Declaration_Node (gnat_entity
)))
437 bool went_into_elab_proc
= false;
439 /* The expression may contain N_Expression_With_Actions nodes and
440 thus object declarations from other units. In this case, even
441 though the expression will eventually be discarded since not a
442 constant, the declarations would be stuck either in the global
443 varpool or in the current scope. Therefore we force the local
444 context and create a fake scope that we'll zap at the end. */
445 if (!current_function_decl
)
447 current_function_decl
= get_elaboration_procedure ();
448 went_into_elab_proc
= true;
452 gnu_expr
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
455 if (went_into_elab_proc
)
456 current_function_decl
= NULL_TREE
;
459 /* Ignore deferred constant definitions without address clause since
460 they are processed fully in the front-end. If No_Initialization
461 is set, this is not a deferred constant but a constant whose value
462 is built manually. And constants that are renamings are handled
466 && No (Address_Clause (gnat_entity
))
467 && !No_Initialization (Declaration_Node (gnat_entity
))
468 && No (Renamed_Object (gnat_entity
)))
470 gnu_decl
= error_mark_node
;
475 /* Ignore constant definitions already marked with the error node. See
476 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
479 && present_gnu_tree (gnat_entity
)
480 && get_gnu_tree (gnat_entity
) == error_mark_node
)
482 maybe_present
= true;
489 /* We used to special case VMS exceptions here to directly map them to
490 their associated condition code. Since this code had to be masked
491 dynamically to strip off the severity bits, this caused trouble in
492 the GCC/ZCX case because the "type" pointers we store in the tables
493 have to be static. We now don't special case here anymore, and let
494 the regular processing take place, which leaves us with a regular
495 exception data object for VMS exceptions too. The condition code
496 mapping is taken care of by the front end and the bitmasking by the
503 /* The GNAT record where the component was defined. */
504 Entity_Id gnat_record
= Underlying_Type (Scope (gnat_entity
));
506 /* If the variable is an inherited record component (in the case of
507 extended record types), just return the inherited entity, which
508 must be a FIELD_DECL. Likewise for discriminants.
509 For discriminants of untagged records which have explicit
510 stored discriminants, return the entity for the corresponding
511 stored discriminant. Also use Original_Record_Component
512 if the record has a private extension. */
513 if (Present (Original_Record_Component (gnat_entity
))
514 && Original_Record_Component (gnat_entity
) != gnat_entity
)
517 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity
),
518 gnu_expr
, definition
);
523 /* If the enclosing record has explicit stored discriminants,
524 then it is an untagged record. If the Corresponding_Discriminant
525 is not empty then this must be a renamed discriminant and its
526 Original_Record_Component must point to the corresponding explicit
527 stored discriminant (i.e. we should have taken the previous
529 else if (Present (Corresponding_Discriminant (gnat_entity
))
530 && Is_Tagged_Type (gnat_record
))
532 /* A tagged record has no explicit stored discriminants. */
533 gcc_assert (First_Discriminant (gnat_record
)
534 == First_Stored_Discriminant (gnat_record
));
536 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity
),
537 gnu_expr
, definition
);
542 else if (Present (CR_Discriminant (gnat_entity
))
543 && type_annotate_only
)
545 gnu_decl
= gnat_to_gnu_entity (CR_Discriminant (gnat_entity
),
546 gnu_expr
, definition
);
551 /* If the enclosing record has explicit stored discriminants, then
552 it is an untagged record. If the Corresponding_Discriminant
553 is not empty then this must be a renamed discriminant and its
554 Original_Record_Component must point to the corresponding explicit
555 stored discriminant (i.e. we should have taken the first
557 else if (Present (Corresponding_Discriminant (gnat_entity
))
558 && (First_Discriminant (gnat_record
)
559 != First_Stored_Discriminant (gnat_record
)))
562 /* Otherwise, if we are not defining this and we have no GCC type
563 for the containing record, make one for it. Then we should
564 have made our own equivalent. */
565 else if (!definition
&& !present_gnu_tree (gnat_record
))
567 /* ??? If this is in a record whose scope is a protected
568 type and we have an Original_Record_Component, use it.
569 This is a workaround for major problems in protected type
571 Entity_Id Scop
= Scope (Scope (gnat_entity
));
572 if ((Is_Protected_Type (Scop
)
573 || (Is_Private_Type (Scop
)
574 && Present (Full_View (Scop
))
575 && Is_Protected_Type (Full_View (Scop
))))
576 && Present (Original_Record_Component (gnat_entity
)))
579 = gnat_to_gnu_entity (Original_Record_Component
586 gnat_to_gnu_entity (Scope (gnat_entity
), NULL_TREE
, 0);
587 gnu_decl
= get_gnu_tree (gnat_entity
);
593 /* Here we have no GCC type and this is a reference rather than a
594 definition. This should never happen. Most likely the cause is
595 reference before declaration in the gnat tree for gnat_entity. */
599 case E_Loop_Parameter
:
600 case E_Out_Parameter
:
603 /* Simple variables, loop variables, Out parameters and exceptions. */
607 = ((kind
== E_Constant
|| kind
== E_Variable
)
608 && Is_True_Constant (gnat_entity
)
609 && !Treat_As_Volatile (gnat_entity
)
610 && (((Nkind (Declaration_Node (gnat_entity
))
611 == N_Object_Declaration
)
612 && Present (Expression (Declaration_Node (gnat_entity
))))
613 || Present (Renamed_Object (gnat_entity
))
615 bool inner_const_flag
= const_flag
;
616 bool static_p
= Is_Statically_Allocated (gnat_entity
);
617 bool mutable_p
= false;
618 bool used_by_ref
= false;
619 tree gnu_ext_name
= NULL_TREE
;
620 tree renamed_obj
= NULL_TREE
;
621 tree gnu_object_size
;
623 if (Present (Renamed_Object (gnat_entity
)) && !definition
)
625 if (kind
== E_Exception
)
626 gnu_expr
= gnat_to_gnu_entity (Renamed_Entity (gnat_entity
),
629 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_entity
));
632 /* Get the type after elaborating the renamed object. */
633 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
635 /* If this is a standard exception definition, then use the standard
636 exception type. This is necessary to make sure that imported and
637 exported views of exceptions are properly merged in LTO mode. */
638 if (TREE_CODE (TYPE_NAME (gnu_type
)) == TYPE_DECL
639 && DECL_NAME (TYPE_NAME (gnu_type
)) == exception_data_name_id
)
640 gnu_type
= except_type_node
;
642 /* For a debug renaming declaration, build a debug-only entity. */
643 if (Present (Debug_Renaming_Link (gnat_entity
)))
645 /* Force a non-null value to make sure the symbol is retained. */
646 tree value
= build1 (INDIRECT_REF
, gnu_type
,
648 build_pointer_type (gnu_type
),
649 integer_minus_one_node
));
650 gnu_decl
= build_decl (input_location
,
651 VAR_DECL
, gnu_entity_name
, gnu_type
);
652 SET_DECL_VALUE_EXPR (gnu_decl
, value
);
653 DECL_HAS_VALUE_EXPR_P (gnu_decl
) = 1;
654 gnat_pushdecl (gnu_decl
, gnat_entity
);
658 /* If this is a loop variable, its type should be the base type.
659 This is because the code for processing a loop determines whether
660 a normal loop end test can be done by comparing the bounds of the
661 loop against those of the base type, which is presumed to be the
662 size used for computation. But this is not correct when the size
663 of the subtype is smaller than the type. */
664 if (kind
== E_Loop_Parameter
)
665 gnu_type
= get_base_type (gnu_type
);
667 /* Reject non-renamed objects whose type is an unconstrained array or
668 any object whose type is a dummy type or void. */
669 if ((TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
670 && No (Renamed_Object (gnat_entity
)))
671 || TYPE_IS_DUMMY_P (gnu_type
)
672 || TREE_CODE (gnu_type
) == VOID_TYPE
)
674 gcc_assert (type_annotate_only
);
677 return error_mark_node
;
680 /* If an alignment is specified, use it if valid. Note that exceptions
681 are objects but don't have an alignment. We must do this before we
682 validate the size, since the alignment can affect the size. */
683 if (kind
!= E_Exception
&& Known_Alignment (gnat_entity
))
685 gcc_assert (Present (Alignment (gnat_entity
)));
687 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
688 TYPE_ALIGN (gnu_type
));
690 /* No point in changing the type if there is an address clause
691 as the final type of the object will be a reference type. */
692 if (Present (Address_Clause (gnat_entity
)))
696 tree orig_type
= gnu_type
;
699 = maybe_pad_type (gnu_type
, NULL_TREE
, align
, gnat_entity
,
700 false, false, definition
, true);
702 /* If a padding record was made, declare it now since it will
703 never be declared otherwise. This is necessary to ensure
704 that its subtrees are properly marked. */
705 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
706 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, NULL
, true,
707 debug_info_p
, gnat_entity
);
711 /* If we are defining the object, see if it has a Size and validate it
712 if so. If we are not defining the object and a Size clause applies,
713 simply retrieve the value. We don't want to ignore the clause and
714 it is expected to have been validated already. Then get the new
717 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
,
718 gnat_entity
, VAR_DECL
, false,
719 Has_Size_Clause (gnat_entity
));
720 else if (Has_Size_Clause (gnat_entity
))
721 gnu_size
= UI_To_gnu (Esize (gnat_entity
), bitsizetype
);
726 = make_type_from_size (gnu_type
, gnu_size
,
727 Has_Biased_Representation (gnat_entity
));
729 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0))
730 gnu_size
= NULL_TREE
;
733 /* If this object has self-referential size, it must be a record with
734 a default discriminant. We are supposed to allocate an object of
735 the maximum size in this case, unless it is a constant with an
736 initializing expression, in which case we can get the size from
737 that. Note that the resulting size may still be a variable, so
738 this may end up with an indirect allocation. */
739 if (No (Renamed_Object (gnat_entity
))
740 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
742 if (gnu_expr
&& kind
== E_Constant
)
744 tree size
= TYPE_SIZE (TREE_TYPE (gnu_expr
));
745 if (CONTAINS_PLACEHOLDER_P (size
))
747 /* If the initializing expression is itself a constant,
748 despite having a nominal type with self-referential
749 size, we can get the size directly from it. */
750 if (TREE_CODE (gnu_expr
) == COMPONENT_REF
752 (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
753 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == VAR_DECL
754 && (TREE_READONLY (TREE_OPERAND (gnu_expr
, 0))
755 || DECL_READONLY_ONCE_ELAB
756 (TREE_OPERAND (gnu_expr
, 0))))
757 gnu_size
= DECL_SIZE (TREE_OPERAND (gnu_expr
, 0));
760 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_expr
);
765 /* We may have no GNU_EXPR because No_Initialization is
766 set even though there's an Expression. */
767 else if (kind
== E_Constant
768 && (Nkind (Declaration_Node (gnat_entity
))
769 == N_Object_Declaration
)
770 && Present (Expression (Declaration_Node (gnat_entity
))))
772 = TYPE_SIZE (gnat_to_gnu_type
774 (Expression (Declaration_Node (gnat_entity
)))));
777 gnu_size
= max_size (TYPE_SIZE (gnu_type
), true);
782 /* If the size is zero byte, make it one byte since some linkers have
783 troubles with zero-sized objects. If the object will have a
784 template, that will make it nonzero so don't bother. Also avoid
785 doing that for an object renaming or an object with an address
786 clause, as we would lose useful information on the view size
787 (e.g. for null array slices) and we are not allocating the object
790 && integer_zerop (gnu_size
)
791 && !TREE_OVERFLOW (gnu_size
))
792 || (TYPE_SIZE (gnu_type
)
793 && integer_zerop (TYPE_SIZE (gnu_type
))
794 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type
))))
795 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
796 || !Is_Array_Type (Etype (gnat_entity
)))
797 && No (Renamed_Object (gnat_entity
))
798 && No (Address_Clause (gnat_entity
)))
799 gnu_size
= bitsize_unit_node
;
801 /* If this is an object with no specified size and alignment, and
802 if either it is atomic or we are not optimizing alignment for
803 space and it is composite and not an exception, an Out parameter
804 or a reference to another object, and the size of its type is a
805 constant, set the alignment to the smallest one which is not
806 smaller than the size, with an appropriate cap. */
807 if (!gnu_size
&& align
== 0
808 && (Is_Atomic (gnat_entity
)
809 || (!Optimize_Alignment_Space (gnat_entity
)
810 && kind
!= E_Exception
811 && kind
!= E_Out_Parameter
812 && Is_Composite_Type (Etype (gnat_entity
))
813 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
814 && !Is_Exported (gnat_entity
)
816 && No (Renamed_Object (gnat_entity
))
817 && No (Address_Clause (gnat_entity
))))
818 && TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
)
820 unsigned int size_cap
, align_cap
;
822 /* No point in promoting the alignment if this doesn't prevent
823 BLKmode access to the object, in particular block copy, as
824 this will for example disable the NRV optimization for it.
825 No point in jumping through all the hoops needed in order
826 to support BIGGEST_ALIGNMENT if we don't really have to.
827 So we cap to the smallest alignment that corresponds to
828 a known efficient memory access pattern of the target. */
829 if (Is_Atomic (gnat_entity
))
832 align_cap
= BIGGEST_ALIGNMENT
;
836 size_cap
= MAX_FIXED_MODE_SIZE
;
837 align_cap
= get_mode_alignment (ptr_mode
);
840 if (!host_integerp (TYPE_SIZE (gnu_type
), 1)
841 || compare_tree_int (TYPE_SIZE (gnu_type
), size_cap
) > 0)
843 else if (compare_tree_int (TYPE_SIZE (gnu_type
), align_cap
) > 0)
846 align
= ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type
), 1));
848 /* But make sure not to under-align the object. */
849 if (align
<= TYPE_ALIGN (gnu_type
))
852 /* And honor the minimum valid atomic alignment, if any. */
853 #ifdef MINIMUM_ATOMIC_ALIGNMENT
854 else if (align
< MINIMUM_ATOMIC_ALIGNMENT
)
855 align
= MINIMUM_ATOMIC_ALIGNMENT
;
859 /* If the object is set to have atomic components, find the component
860 type and validate it.
862 ??? Note that we ignore Has_Volatile_Components on objects; it's
863 not at all clear what to do in that case. */
864 if (Has_Atomic_Components (gnat_entity
))
866 tree gnu_inner
= (TREE_CODE (gnu_type
) == ARRAY_TYPE
867 ? TREE_TYPE (gnu_type
) : gnu_type
);
869 while (TREE_CODE (gnu_inner
) == ARRAY_TYPE
870 && TYPE_MULTI_ARRAY_P (gnu_inner
))
871 gnu_inner
= TREE_TYPE (gnu_inner
);
873 check_ok_for_atomic (gnu_inner
, gnat_entity
, true);
876 /* Now check if the type of the object allows atomic access. Note
877 that we must test the type, even if this object has size and
878 alignment to allow such access, because we will be going inside
879 the padded record to assign to the object. We could fix this by
880 always copying via an intermediate value, but it's not clear it's
882 if (Is_Atomic (gnat_entity
))
883 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
885 /* If this is an aliased object with an unconstrained nominal subtype,
886 make a type that includes the template. */
887 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
888 && Is_Array_Type (Etype (gnat_entity
))
889 && !type_annotate_only
)
892 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity
))));
894 = build_unc_object_type_from_ptr (gnu_fat
, gnu_type
,
895 concat_name (gnu_entity_name
,
900 #ifdef MINIMUM_ATOMIC_ALIGNMENT
901 /* If the size is a constant and no alignment is specified, force
902 the alignment to be the minimum valid atomic alignment. The
903 restriction on constant size avoids problems with variable-size
904 temporaries; if the size is variable, there's no issue with
905 atomic access. Also don't do this for a constant, since it isn't
906 necessary and can interfere with constant replacement. Finally,
907 do not do it for Out parameters since that creates an
908 size inconsistency with In parameters. */
909 if (align
== 0 && MINIMUM_ATOMIC_ALIGNMENT
> TYPE_ALIGN (gnu_type
)
910 && !FLOAT_TYPE_P (gnu_type
)
911 && !const_flag
&& No (Renamed_Object (gnat_entity
))
912 && !imported_p
&& No (Address_Clause (gnat_entity
))
913 && kind
!= E_Out_Parameter
914 && (gnu_size
? TREE_CODE (gnu_size
) == INTEGER_CST
915 : TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
))
916 align
= MINIMUM_ATOMIC_ALIGNMENT
;
919 /* Make a new type with the desired size and alignment, if needed.
920 But do not take into account alignment promotions to compute the
921 size of the object. */
922 gnu_object_size
= gnu_size
? gnu_size
: TYPE_SIZE (gnu_type
);
923 if (gnu_size
|| align
> 0)
925 tree orig_type
= gnu_type
;
927 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
928 false, false, definition
,
929 gnu_size
? true : false);
931 /* If a padding record was made, declare it now since it will
932 never be declared otherwise. This is necessary to ensure
933 that its subtrees are properly marked. */
934 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
935 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, NULL
, true,
936 debug_info_p
, gnat_entity
);
939 /* If this is a renaming, avoid as much as possible to create a new
940 object. However, in several cases, creating it is required.
941 This processing needs to be applied to the raw expression so
942 as to make it more likely to rename the underlying object. */
943 if (Present (Renamed_Object (gnat_entity
)))
945 bool create_normal_object
= false;
947 /* If the renamed object had padding, strip off the reference
948 to the inner object and reset our type. */
949 if ((TREE_CODE (gnu_expr
) == COMPONENT_REF
950 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
951 /* Strip useless conversions around the object. */
952 || gnat_useless_type_conversion (gnu_expr
))
954 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
955 gnu_type
= TREE_TYPE (gnu_expr
);
958 /* Case 1: If this is a constant renaming stemming from a function
959 call, treat it as a normal object whose initial value is what
960 is being renamed. RM 3.3 says that the result of evaluating a
961 function call is a constant object. As a consequence, it can
962 be the inner object of a constant renaming. In this case, the
963 renaming must be fully instantiated, i.e. it cannot be a mere
964 reference to (part of) an existing object. */
967 tree inner_object
= gnu_expr
;
968 while (handled_component_p (inner_object
))
969 inner_object
= TREE_OPERAND (inner_object
, 0);
970 if (TREE_CODE (inner_object
) == CALL_EXPR
)
971 create_normal_object
= true;
974 /* Otherwise, see if we can proceed with a stabilized version of
975 the renamed entity or if we need to make a new object. */
976 if (!create_normal_object
)
978 tree maybe_stable_expr
= NULL_TREE
;
981 /* Case 2: If the renaming entity need not be materialized and
982 the renamed expression is something we can stabilize, use
983 that for the renaming. At the global level, we can only do
984 this if we know no SAVE_EXPRs need be made, because the
985 expression we return might be used in arbitrary conditional
986 branches so we must force the evaluation of the SAVE_EXPRs
987 immediately and this requires a proper function context.
988 Note that an external constant is at the global level. */
989 if (!Materialize_Entity (gnat_entity
)
990 && (!((!definition
&& kind
== E_Constant
)
991 || global_bindings_p ())
992 || (staticp (gnu_expr
)
993 && !TREE_SIDE_EFFECTS (gnu_expr
))))
996 = gnat_stabilize_reference (gnu_expr
, true, &stable
);
1000 /* ??? No DECL_EXPR is created so we need to mark
1001 the expression manually lest it is shared. */
1002 if ((!definition
&& kind
== E_Constant
)
1003 || global_bindings_p ())
1004 MARK_VISITED (maybe_stable_expr
);
1005 gnu_decl
= maybe_stable_expr
;
1006 save_gnu_tree (gnat_entity
, gnu_decl
, true);
1008 annotate_object (gnat_entity
, gnu_type
, NULL_TREE
,
1013 /* The stabilization failed. Keep maybe_stable_expr
1014 untouched here to let the pointer case below know
1015 about that failure. */
1018 /* Case 3: If this is a constant renaming and creating a
1019 new object is allowed and cheap, treat it as a normal
1020 object whose initial value is what is being renamed. */
1022 && !Is_Composite_Type
1023 (Underlying_Type (Etype (gnat_entity
))))
1026 /* Case 4: Make this into a constant pointer to the object we
1027 are to rename and attach the object to the pointer if it is
1028 something we can stabilize.
1030 From the proper scope, attached objects will be referenced
1031 directly instead of indirectly via the pointer to avoid
1032 subtle aliasing problems with non-addressable entities.
1033 They have to be stable because we must not evaluate the
1034 variables in the expression every time the renaming is used.
1035 The pointer is called a "renaming" pointer in this case.
1037 In the rare cases where we cannot stabilize the renamed
1038 object, we just make a "bare" pointer, and the renamed
1039 entity is always accessed indirectly through it. */
1042 gnu_type
= build_reference_type (gnu_type
);
1043 inner_const_flag
= TREE_READONLY (gnu_expr
);
1046 /* If the previous attempt at stabilizing failed, there
1047 is no point in trying again and we reuse the result
1048 without attaching it to the pointer. In this case it
1049 will only be used as the initializing expression of
1050 the pointer and thus needs no special treatment with
1051 regard to multiple evaluations. */
1052 if (maybe_stable_expr
)
1055 /* Otherwise, try to stabilize and attach the expression
1056 to the pointer if the stabilization succeeds.
1058 Note that this might introduce SAVE_EXPRs and we don't
1059 check whether we're at the global level or not. This
1060 is fine since we are building a pointer initializer and
1061 neither the pointer nor the initializing expression can
1062 be accessed before the pointer elaboration has taken
1063 place in a correct program.
1065 These SAVE_EXPRs will be evaluated at the right place
1066 by either the evaluation of the initializer for the
1067 non-global case or the elaboration code for the global
1068 case, and will be attached to the elaboration procedure
1069 in the latter case. */
1073 = gnat_stabilize_reference (gnu_expr
, true, &stable
);
1076 renamed_obj
= maybe_stable_expr
;
1078 /* Attaching is actually performed downstream, as soon
1079 as we have a VAR_DECL for the pointer we make. */
1082 gnu_expr
= build_unary_op (ADDR_EXPR
, gnu_type
,
1085 gnu_size
= NULL_TREE
;
1091 /* Make a volatile version of this object's type if we are to make
1092 the object volatile. We also interpret 13.3(19) conservatively
1093 and disallow any optimizations for such a non-constant object. */
1094 if ((Treat_As_Volatile (gnat_entity
)
1096 && gnu_type
!= except_type_node
1097 && (Is_Exported (gnat_entity
)
1099 || Present (Address_Clause (gnat_entity
)))))
1100 && !TYPE_VOLATILE (gnu_type
))
1101 gnu_type
= build_qualified_type (gnu_type
,
1102 (TYPE_QUALS (gnu_type
)
1103 | TYPE_QUAL_VOLATILE
));
1105 /* If we are defining an aliased object whose nominal subtype is
1106 unconstrained, the object is a record that contains both the
1107 template and the object. If there is an initializer, it will
1108 have already been converted to the right type, but we need to
1109 create the template if there is no initializer. */
1112 && TREE_CODE (gnu_type
) == RECORD_TYPE
1113 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
1114 /* Beware that padding might have been introduced above. */
1115 || (TYPE_PADDING_P (gnu_type
)
1116 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
1118 && TYPE_CONTAINS_TEMPLATE_P
1119 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))))
1122 = TYPE_PADDING_P (gnu_type
)
1123 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
1124 : TYPE_FIELDS (gnu_type
);
1125 VEC(constructor_elt
,gc
) *v
= VEC_alloc (constructor_elt
, gc
, 1);
1126 tree t
= build_template (TREE_TYPE (template_field
),
1127 TREE_TYPE (DECL_CHAIN (template_field
)),
1129 CONSTRUCTOR_APPEND_ELT (v
, template_field
, t
);
1130 gnu_expr
= gnat_build_constructor (gnu_type
, v
);
1133 /* Convert the expression to the type of the object except in the
1134 case where the object's type is unconstrained or the object's type
1135 is a padded record whose field is of self-referential size. In
1136 the former case, converting will generate unnecessary evaluations
1137 of the CONSTRUCTOR to compute the size and in the latter case, we
1138 want to only copy the actual data. Also don't convert to a record
1139 type with a variant part from a record type without one, to keep
1140 the object simpler. */
1142 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1143 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1144 && !(TYPE_IS_PADDING_P (gnu_type
)
1145 && CONTAINS_PLACEHOLDER_P
1146 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))
1147 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1148 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
1149 && get_variant_part (gnu_type
) != NULL_TREE
1150 && get_variant_part (TREE_TYPE (gnu_expr
)) == NULL_TREE
))
1151 gnu_expr
= convert (gnu_type
, gnu_expr
);
1153 /* If this is a pointer that doesn't have an initializing expression,
1154 initialize it to NULL, unless the object is imported. */
1156 && (POINTER_TYPE_P (gnu_type
) || TYPE_IS_FAT_POINTER_P (gnu_type
))
1158 && !Is_Imported (gnat_entity
))
1159 gnu_expr
= integer_zero_node
;
1161 /* If we are defining the object and it has an Address clause, we must
1162 either get the address expression from the saved GCC tree for the
1163 object if it has a Freeze node, or elaborate the address expression
1164 here since the front-end has guaranteed that the elaboration has no
1165 effects in this case. */
1166 if (definition
&& Present (Address_Clause (gnat_entity
)))
1168 Node_Id gnat_expr
= Expression (Address_Clause (gnat_entity
));
1170 = present_gnu_tree (gnat_entity
)
1171 ? get_gnu_tree (gnat_entity
) : gnat_to_gnu (gnat_expr
);
1173 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
1175 /* Ignore the size. It's either meaningless or was handled
1177 gnu_size
= NULL_TREE
;
1178 /* Convert the type of the object to a reference type that can
1179 alias everything as per 13.3(19). */
1181 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1182 gnu_address
= convert (gnu_type
, gnu_address
);
1185 = !Is_Public (gnat_entity
)
1186 || compile_time_known_address_p (gnat_expr
);
1188 /* If this is a deferred constant, the initializer is attached to
1190 if (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
1193 (Expression (Declaration_Node (Full_View (gnat_entity
))));
1195 /* If we don't have an initializing expression for the underlying
1196 variable, the initializing expression for the pointer is the
1197 specified address. Otherwise, we have to make a COMPOUND_EXPR
1198 to assign both the address and the initial value. */
1200 gnu_expr
= gnu_address
;
1203 = build2 (COMPOUND_EXPR
, gnu_type
,
1205 (MODIFY_EXPR
, NULL_TREE
,
1206 build_unary_op (INDIRECT_REF
, NULL_TREE
,
1212 /* If it has an address clause and we are not defining it, mark it
1213 as an indirect object. Likewise for Stdcall objects that are
1215 if ((!definition
&& Present (Address_Clause (gnat_entity
)))
1216 || (Is_Imported (gnat_entity
)
1217 && Has_Stdcall_Convention (gnat_entity
)))
1219 /* Convert the type of the object to a reference type that can
1220 alias everything as per 13.3(19). */
1222 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1223 gnu_size
= NULL_TREE
;
1225 /* No point in taking the address of an initializing expression
1226 that isn't going to be used. */
1227 gnu_expr
= NULL_TREE
;
1229 /* If it has an address clause whose value is known at compile
1230 time, make the object a CONST_DECL. This will avoid a
1231 useless dereference. */
1232 if (Present (Address_Clause (gnat_entity
)))
1234 Node_Id gnat_address
1235 = Expression (Address_Clause (gnat_entity
));
1237 if (compile_time_known_address_p (gnat_address
))
1239 gnu_expr
= gnat_to_gnu (gnat_address
);
1247 /* If we are at top level and this object is of variable size,
1248 make the actual type a hidden pointer to the real type and
1249 make the initializer be a memory allocation and initialization.
1250 Likewise for objects we aren't defining (presumed to be
1251 external references from other packages), but there we do
1252 not set up an initialization.
1254 If the object's size overflows, make an allocator too, so that
1255 Storage_Error gets raised. Note that we will never free
1256 such memory, so we presume it never will get allocated. */
1257 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type
),
1258 global_bindings_p ()
1261 || (gnu_size
&& !allocatable_size_p (gnu_size
,
1262 global_bindings_p ()
1266 gnu_type
= build_reference_type (gnu_type
);
1267 gnu_size
= NULL_TREE
;
1270 /* In case this was a aliased object whose nominal subtype is
1271 unconstrained, the pointer above will be a thin pointer and
1272 build_allocator will automatically make the template.
1274 If we have a template initializer only (that we made above),
1275 pretend there is none and rely on what build_allocator creates
1276 again anyway. Otherwise (if we have a full initializer), get
1277 the data part and feed that to build_allocator.
1279 If we are elaborating a mutable object, tell build_allocator to
1280 ignore a possibly simpler size from the initializer, if any, as
1281 we must allocate the maximum possible size in this case. */
1282 if (definition
&& !imported_p
)
1284 tree gnu_alloc_type
= TREE_TYPE (gnu_type
);
1286 if (TREE_CODE (gnu_alloc_type
) == RECORD_TYPE
1287 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type
))
1290 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type
)));
1292 if (TREE_CODE (gnu_expr
) == CONSTRUCTOR
1293 && 1 == VEC_length (constructor_elt
,
1294 CONSTRUCTOR_ELTS (gnu_expr
)))
1298 = build_component_ref
1299 (gnu_expr
, NULL_TREE
,
1300 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr
))),
1304 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type
)) == INTEGER_CST
1305 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type
)))
1306 post_error ("?`Storage_Error` will be raised at run time!",
1310 = build_allocator (gnu_alloc_type
, gnu_expr
, gnu_type
,
1311 Empty
, Empty
, gnat_entity
, mutable_p
);
1316 gnu_expr
= NULL_TREE
;
1321 /* If this object would go into the stack and has an alignment larger
1322 than the largest stack alignment the back-end can honor, resort to
1323 a variable of "aligning type". */
1324 if (!global_bindings_p () && !static_p
&& definition
1325 && !imported_p
&& TYPE_ALIGN (gnu_type
) > BIGGEST_ALIGNMENT
)
1327 /* Create the new variable. No need for extra room before the
1328 aligned field as this is in automatic storage. */
1330 = make_aligning_type (gnu_type
, TYPE_ALIGN (gnu_type
),
1331 TYPE_SIZE_UNIT (gnu_type
),
1332 BIGGEST_ALIGNMENT
, 0);
1334 = create_var_decl (create_concat_name (gnat_entity
, "ALIGN"),
1335 NULL_TREE
, gnu_new_type
, NULL_TREE
, false,
1336 false, false, false, NULL
, gnat_entity
);
1338 /* Initialize the aligned field if we have an initializer. */
1341 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
1343 (gnu_new_var
, NULL_TREE
,
1344 TYPE_FIELDS (gnu_new_type
), false),
1348 /* And setup this entity as a reference to the aligned field. */
1349 gnu_type
= build_reference_type (gnu_type
);
1352 (ADDR_EXPR
, gnu_type
,
1353 build_component_ref (gnu_new_var
, NULL_TREE
,
1354 TYPE_FIELDS (gnu_new_type
), false));
1356 gnu_size
= NULL_TREE
;
1362 gnu_type
= build_qualified_type (gnu_type
, (TYPE_QUALS (gnu_type
)
1363 | TYPE_QUAL_CONST
));
1365 /* Convert the expression to the type of the object except in the
1366 case where the object's type is unconstrained or the object's type
1367 is a padded record whose field is of self-referential size. In
1368 the former case, converting will generate unnecessary evaluations
1369 of the CONSTRUCTOR to compute the size and in the latter case, we
1370 want to only copy the actual data. Also don't convert to a record
1371 type with a variant part from a record type without one, to keep
1372 the object simpler. */
1374 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1375 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1376 && !(TYPE_IS_PADDING_P (gnu_type
)
1377 && CONTAINS_PLACEHOLDER_P
1378 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))
1379 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1380 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
1381 && get_variant_part (gnu_type
) != NULL_TREE
1382 && get_variant_part (TREE_TYPE (gnu_expr
)) == NULL_TREE
))
1383 gnu_expr
= convert (gnu_type
, gnu_expr
);
1385 /* If this name is external or there was a name specified, use it,
1386 unless this is a VMS exception object since this would conflict
1387 with the symbol we need to export in addition. Don't use the
1388 Interface_Name if there is an address clause (see CD30005). */
1389 if (!Is_VMS_Exception (gnat_entity
)
1390 && ((Present (Interface_Name (gnat_entity
))
1391 && No (Address_Clause (gnat_entity
)))
1392 || (Is_Public (gnat_entity
)
1393 && (!Is_Imported (gnat_entity
)
1394 || Is_Exported (gnat_entity
)))))
1395 gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
1397 /* If this is an aggregate constant initialized to a constant, force it
1398 to be statically allocated. This saves an initialization copy. */
1401 && gnu_expr
&& TREE_CONSTANT (gnu_expr
)
1402 && AGGREGATE_TYPE_P (gnu_type
)
1403 && host_integerp (TYPE_SIZE_UNIT (gnu_type
), 1)
1404 && !(TYPE_IS_PADDING_P (gnu_type
)
1405 && !host_integerp (TYPE_SIZE_UNIT
1406 (TREE_TYPE (TYPE_FIELDS (gnu_type
))), 1)))
1409 /* Now create the variable or the constant and set various flags. */
1411 = create_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
1412 gnu_expr
, const_flag
, Is_Public (gnat_entity
),
1413 imported_p
|| !definition
, static_p
, attr_list
,
1415 DECL_BY_REF_P (gnu_decl
) = used_by_ref
;
1416 DECL_POINTS_TO_READONLY_P (gnu_decl
) = used_by_ref
&& inner_const_flag
;
1417 DECL_CAN_NEVER_BE_NULL_P (gnu_decl
) = Can_Never_Be_Null (gnat_entity
);
1419 /* If we are defining an Out parameter and optimization isn't enabled,
1420 create a fake PARM_DECL for debugging purposes and make it point to
1421 the VAR_DECL. Suppress debug info for the latter but make sure it
1422 will live on the stack so that it can be accessed from within the
1423 debugger through the PARM_DECL. */
1424 if (kind
== E_Out_Parameter
&& definition
&& !optimize
&& debug_info_p
)
1426 tree param
= create_param_decl (gnu_entity_name
, gnu_type
, false);
1427 gnat_pushdecl (param
, gnat_entity
);
1428 SET_DECL_VALUE_EXPR (param
, gnu_decl
);
1429 DECL_HAS_VALUE_EXPR_P (param
) = 1;
1430 DECL_IGNORED_P (gnu_decl
) = 1;
1431 TREE_ADDRESSABLE (gnu_decl
) = 1;
1434 /* If this is a loop parameter, set the corresponding flag. */
1435 else if (kind
== E_Loop_Parameter
)
1436 DECL_LOOP_PARM_P (gnu_decl
) = 1;
1438 /* If this is a renaming pointer, attach the renamed object to it and
1439 register it if we are at the global level. Note that an external
1440 constant is at the global level. */
1441 else if (TREE_CODE (gnu_decl
) == VAR_DECL
&& renamed_obj
)
1443 SET_DECL_RENAMED_OBJECT (gnu_decl
, renamed_obj
);
1444 if ((!definition
&& kind
== E_Constant
) || global_bindings_p ())
1446 DECL_RENAMING_GLOBAL_P (gnu_decl
) = 1;
1447 record_global_renaming_pointer (gnu_decl
);
1451 /* If this is a constant and we are defining it or it generates a real
1452 symbol at the object level and we are referencing it, we may want
1453 or need to have a true variable to represent it:
1454 - if optimization isn't enabled, for debugging purposes,
1455 - if the constant is public and not overlaid on something else,
1456 - if its address is taken,
1457 - if either itself or its type is aliased. */
1458 if (TREE_CODE (gnu_decl
) == CONST_DECL
1459 && (definition
|| Sloc (gnat_entity
) > Standard_Location
)
1460 && ((!optimize
&& debug_info_p
)
1461 || (Is_Public (gnat_entity
)
1462 && No (Address_Clause (gnat_entity
)))
1463 || Address_Taken (gnat_entity
)
1464 || Is_Aliased (gnat_entity
)
1465 || Is_Aliased (Etype (gnat_entity
))))
1468 = create_true_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
1469 gnu_expr
, true, Is_Public (gnat_entity
),
1470 !definition
, static_p
, attr_list
,
1473 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl
, gnu_corr_var
);
1475 /* As debugging information will be generated for the variable,
1476 do not generate debugging information for the constant. */
1478 DECL_IGNORED_P (gnu_decl
) = 1;
1480 DECL_IGNORED_P (gnu_corr_var
) = 1;
1483 /* If this is a constant, even if we don't need a true variable, we
1484 may need to avoid returning the initializer in every case. That
1485 can happen for the address of a (constant) constructor because,
1486 upon dereferencing it, the constructor will be reinjected in the
1487 tree, which may not be valid in every case; see lvalue_required_p
1488 for more details. */
1489 if (TREE_CODE (gnu_decl
) == CONST_DECL
)
1490 DECL_CONST_ADDRESS_P (gnu_decl
) = constructor_address_p (gnu_expr
);
1492 /* If this object is declared in a block that contains a block with an
1493 exception handler, and we aren't using the GCC exception mechanism,
1494 we must force this variable in memory in order to avoid an invalid
1496 if (Exception_Mechanism
!= Back_End_Exceptions
1497 && Has_Nested_Block_With_Handler (Scope (gnat_entity
)))
1498 TREE_ADDRESSABLE (gnu_decl
) = 1;
1500 /* If we are defining an object with variable size or an object with
1501 fixed size that will be dynamically allocated, and we are using the
1502 setjmp/longjmp exception mechanism, update the setjmp buffer. */
1504 && Exception_Mechanism
== Setjmp_Longjmp
1505 && get_block_jmpbuf_decl ()
1506 && DECL_SIZE_UNIT (gnu_decl
)
1507 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl
)) != INTEGER_CST
1508 || (flag_stack_check
== GENERIC_STACK_CHECK
1509 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl
),
1510 STACK_CHECK_MAX_VAR_SIZE
) > 0)))
1511 add_stmt_with_node (build_call_n_expr
1512 (update_setjmp_buf_decl
, 1,
1513 build_unary_op (ADDR_EXPR
, NULL_TREE
,
1514 get_block_jmpbuf_decl ())),
1517 /* Back-annotate Esize and Alignment of the object if not already
1518 known. Note that we pick the values of the type, not those of
1519 the object, to shield ourselves from low-level platform-dependent
1520 adjustments like alignment promotion. This is both consistent with
1521 all the treatment above, where alignment and size are set on the
1522 type of the object and not on the object directly, and makes it
1523 possible to support all confirming representation clauses. */
1524 annotate_object (gnat_entity
, TREE_TYPE (gnu_decl
), gnu_object_size
,
1525 used_by_ref
, false);
1530 /* Return a TYPE_DECL for "void" that we previously made. */
1531 gnu_decl
= TYPE_NAME (void_type_node
);
1534 case E_Enumeration_Type
:
1535 /* A special case: for the types Character and Wide_Character in
1536 Standard, we do not list all the literals. So if the literals
1537 are not specified, make this an unsigned type. */
1538 if (No (First_Literal (gnat_entity
)))
1540 gnu_type
= make_unsigned_type (esize
);
1541 TYPE_NAME (gnu_type
) = gnu_entity_name
;
1543 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1544 This is needed by the DWARF-2 back-end to distinguish between
1545 unsigned integer types and character types. */
1546 TYPE_STRING_FLAG (gnu_type
) = 1;
1551 /* We have a list of enumeral constants in First_Literal. We make a
1552 CONST_DECL for each one and build into GNU_LITERAL_LIST the list to
1553 be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST
1554 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1555 value of the literal. But when we have a regular boolean type, we
1556 simplify this a little by using a BOOLEAN_TYPE. */
1557 bool is_boolean
= Is_Boolean_Type (gnat_entity
)
1558 && !Has_Non_Standard_Rep (gnat_entity
);
1559 tree gnu_literal_list
= NULL_TREE
;
1560 Entity_Id gnat_literal
;
1562 if (Is_Unsigned_Type (gnat_entity
))
1563 gnu_type
= make_unsigned_type (esize
);
1565 gnu_type
= make_signed_type (esize
);
1567 TREE_SET_CODE (gnu_type
, is_boolean
? BOOLEAN_TYPE
: ENUMERAL_TYPE
);
1569 for (gnat_literal
= First_Literal (gnat_entity
);
1570 Present (gnat_literal
);
1571 gnat_literal
= Next_Literal (gnat_literal
))
1574 = UI_To_gnu (Enumeration_Rep (gnat_literal
), gnu_type
);
1576 = create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
1577 gnu_type
, gnu_value
, true, false, false,
1578 false, NULL
, gnat_literal
);
1579 /* Do not generate debug info for individual enumerators. */
1580 DECL_IGNORED_P (gnu_literal
) = 1;
1581 save_gnu_tree (gnat_literal
, gnu_literal
, false);
1582 gnu_literal_list
= tree_cons (DECL_NAME (gnu_literal
),
1583 gnu_value
, gnu_literal_list
);
1587 TYPE_VALUES (gnu_type
) = nreverse (gnu_literal_list
);
1589 /* Note that the bounds are updated at the end of this function
1590 to avoid an infinite recursion since they refer to the type. */
1594 case E_Signed_Integer_Type
:
1595 case E_Ordinary_Fixed_Point_Type
:
1596 case E_Decimal_Fixed_Point_Type
:
1597 /* For integer types, just make a signed type the appropriate number
1599 gnu_type
= make_signed_type (esize
);
1602 case E_Modular_Integer_Type
:
1604 /* For modular types, make the unsigned type of the proper number
1605 of bits and then set up the modulus, if required. */
1606 tree gnu_modulus
, gnu_high
= NULL_TREE
;
1608 /* Packed array types are supposed to be subtypes only. */
1609 gcc_assert (!Is_Packed_Array_Type (gnat_entity
));
1611 gnu_type
= make_unsigned_type (esize
);
1613 /* Get the modulus in this type. If it overflows, assume it is because
1614 it is equal to 2**Esize. Note that there is no overflow checking
1615 done on unsigned type, so we detect the overflow by looking for
1616 a modulus of zero, which is otherwise invalid. */
1617 gnu_modulus
= UI_To_gnu (Modulus (gnat_entity
), gnu_type
);
1619 if (!integer_zerop (gnu_modulus
))
1621 TYPE_MODULAR_P (gnu_type
) = 1;
1622 SET_TYPE_MODULUS (gnu_type
, gnu_modulus
);
1623 gnu_high
= fold_build2 (MINUS_EXPR
, gnu_type
, gnu_modulus
,
1624 convert (gnu_type
, integer_one_node
));
1627 /* If the upper bound is not maximal, make an extra subtype. */
1629 && !tree_int_cst_equal (gnu_high
, TYPE_MAX_VALUE (gnu_type
)))
1631 tree gnu_subtype
= make_unsigned_type (esize
);
1632 SET_TYPE_RM_MAX_VALUE (gnu_subtype
, gnu_high
);
1633 TREE_TYPE (gnu_subtype
) = gnu_type
;
1634 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
1635 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "UMT");
1636 gnu_type
= gnu_subtype
;
1641 case E_Signed_Integer_Subtype
:
1642 case E_Enumeration_Subtype
:
1643 case E_Modular_Integer_Subtype
:
1644 case E_Ordinary_Fixed_Point_Subtype
:
1645 case E_Decimal_Fixed_Point_Subtype
:
1647 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1648 not want to call create_range_type since we would like each subtype
1649 node to be distinct. ??? Historically this was in preparation for
1650 when memory aliasing is implemented, but that's obsolete now given
1651 the call to relate_alias_sets below.
1653 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1654 this fact is used by the arithmetic conversion functions.
1656 We elaborate the Ancestor_Subtype if it is not in the current unit
1657 and one of our bounds is non-static. We do this to ensure consistent
1658 naming in the case where several subtypes share the same bounds, by
1659 elaborating the first such subtype first, thus using its name. */
1662 && Present (Ancestor_Subtype (gnat_entity
))
1663 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1664 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1665 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1666 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
), gnu_expr
, 0);
1668 /* Set the precision to the Esize except for bit-packed arrays. */
1669 if (Is_Packed_Array_Type (gnat_entity
)
1670 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1671 esize
= UI_To_Int (RM_Size (gnat_entity
));
1673 /* This should be an unsigned type if the base type is unsigned or
1674 if the lower bound is constant and non-negative or if the type
1676 if (Is_Unsigned_Type (Etype (gnat_entity
))
1677 || Is_Unsigned_Type (gnat_entity
)
1678 || Has_Biased_Representation (gnat_entity
))
1679 gnu_type
= make_unsigned_type (esize
);
1681 gnu_type
= make_signed_type (esize
);
1682 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1684 SET_TYPE_RM_MIN_VALUE
1686 convert (TREE_TYPE (gnu_type
),
1687 elaborate_expression (Type_Low_Bound (gnat_entity
),
1688 gnat_entity
, get_identifier ("L"),
1690 Needs_Debug_Info (gnat_entity
))));
1692 SET_TYPE_RM_MAX_VALUE
1694 convert (TREE_TYPE (gnu_type
),
1695 elaborate_expression (Type_High_Bound (gnat_entity
),
1696 gnat_entity
, get_identifier ("U"),
1698 Needs_Debug_Info (gnat_entity
))));
1700 /* One of the above calls might have caused us to be elaborated,
1701 so don't blow up if so. */
1702 if (present_gnu_tree (gnat_entity
))
1704 maybe_present
= true;
1708 TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1709 = Has_Biased_Representation (gnat_entity
);
1711 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1712 TYPE_STUB_DECL (gnu_type
)
1713 = create_type_stub_decl (gnu_entity_name
, gnu_type
);
1715 /* Inherit our alias set from what we're a subtype of. Subtypes
1716 are not different types and a pointer can designate any instance
1717 within a subtype hierarchy. */
1718 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
1720 /* For a packed array, make the original array type a parallel type. */
1722 && Is_Packed_Array_Type (gnat_entity
)
1723 && present_gnu_tree (Original_Array_Type (gnat_entity
)))
1724 add_parallel_type (TYPE_STUB_DECL (gnu_type
),
1726 (Original_Array_Type (gnat_entity
)));
1730 /* We have to handle clauses that under-align the type specially. */
1731 if ((Present (Alignment_Clause (gnat_entity
))
1732 || (Is_Packed_Array_Type (gnat_entity
)
1734 (Alignment_Clause (Original_Array_Type (gnat_entity
)))))
1735 && UI_Is_In_Int_Range (Alignment (gnat_entity
)))
1737 align
= UI_To_Int (Alignment (gnat_entity
)) * BITS_PER_UNIT
;
1738 if (align
>= TYPE_ALIGN (gnu_type
))
1742 /* If the type we are dealing with represents a bit-packed array,
1743 we need to have the bits left justified on big-endian targets
1744 and right justified on little-endian targets. We also need to
1745 ensure that when the value is read (e.g. for comparison of two
1746 such values), we only get the good bits, since the unused bits
1747 are uninitialized. Both goals are accomplished by wrapping up
1748 the modular type in an enclosing record type. */
1749 if (Is_Packed_Array_Type (gnat_entity
)
1750 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1752 tree gnu_field_type
, gnu_field
;
1754 /* Set the RM size before wrapping up the original type. */
1755 SET_TYPE_RM_SIZE (gnu_type
,
1756 UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
));
1757 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
) = 1;
1759 /* Create a stripped-down declaration, mainly for debugging. */
1760 create_type_decl (gnu_entity_name
, gnu_type
, NULL
, true,
1761 debug_info_p
, gnat_entity
);
1763 /* Now save it and build the enclosing record type. */
1764 gnu_field_type
= gnu_type
;
1766 gnu_type
= make_node (RECORD_TYPE
);
1767 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "JM");
1768 TYPE_PACKED (gnu_type
) = 1;
1769 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_field_type
);
1770 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_field_type
);
1771 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_RM_SIZE (gnu_field_type
));
1773 /* Propagate the alignment of the modular type to the record type,
1774 unless there is an alignment clause that under-aligns the type.
1775 This means that bit-packed arrays are given "ceil" alignment for
1776 their size by default, which may seem counter-intuitive but makes
1777 it possible to overlay them on modular types easily. */
1778 TYPE_ALIGN (gnu_type
)
1779 = align
> 0 ? align
: TYPE_ALIGN (gnu_field_type
);
1781 relate_alias_sets (gnu_type
, gnu_field_type
, ALIAS_SET_COPY
);
1783 /* Don't declare the field as addressable since we won't be taking
1784 its address and this would prevent create_field_decl from making
1787 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type
,
1788 gnu_type
, NULL_TREE
, bitsize_zero_node
, 1, 0);
1790 /* Do not emit debug info until after the parallel type is added. */
1791 finish_record_type (gnu_type
, gnu_field
, 2, false);
1792 compute_record_mode (gnu_type
);
1793 TYPE_JUSTIFIED_MODULAR_P (gnu_type
) = 1;
1797 /* Make the original array type a parallel type. */
1798 if (present_gnu_tree (Original_Array_Type (gnat_entity
)))
1799 add_parallel_type (TYPE_STUB_DECL (gnu_type
),
1801 (Original_Array_Type (gnat_entity
)));
1803 rest_of_record_type_compilation (gnu_type
);
1807 /* If the type we are dealing with has got a smaller alignment than the
1808 natural one, we need to wrap it up in a record type and under-align
1809 the latter. We reuse the padding machinery for this purpose. */
1812 tree gnu_field_type
, gnu_field
;
1814 /* Set the RM size before wrapping up the type. */
1815 SET_TYPE_RM_SIZE (gnu_type
,
1816 UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
));
1818 /* Create a stripped-down declaration, mainly for debugging. */
1819 create_type_decl (gnu_entity_name
, gnu_type
, NULL
, true,
1820 debug_info_p
, gnat_entity
);
1822 /* Now save it and build the enclosing record type. */
1823 gnu_field_type
= gnu_type
;
1825 gnu_type
= make_node (RECORD_TYPE
);
1826 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "PAD");
1827 TYPE_PACKED (gnu_type
) = 1;
1828 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_field_type
);
1829 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_field_type
);
1830 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_RM_SIZE (gnu_field_type
));
1831 TYPE_ALIGN (gnu_type
) = align
;
1832 relate_alias_sets (gnu_type
, gnu_field_type
, ALIAS_SET_COPY
);
1834 /* Don't declare the field as addressable since we won't be taking
1835 its address and this would prevent create_field_decl from making
1838 = create_field_decl (get_identifier ("F"), gnu_field_type
,
1839 gnu_type
, NULL_TREE
, bitsize_zero_node
, 1, 0);
1841 finish_record_type (gnu_type
, gnu_field
, 2, debug_info_p
);
1842 compute_record_mode (gnu_type
);
1843 TYPE_PADDING_P (gnu_type
) = 1;
1848 case E_Floating_Point_Type
:
1849 /* If this is a VAX floating-point type, use an integer of the proper
1850 size. All the operations will be handled with ASM statements. */
1851 if (Vax_Float (gnat_entity
))
1853 gnu_type
= make_signed_type (esize
);
1854 TYPE_VAX_FLOATING_POINT_P (gnu_type
) = 1;
1855 SET_TYPE_DIGITS_VALUE (gnu_type
,
1856 UI_To_gnu (Digits_Value (gnat_entity
),
1861 /* The type of the Low and High bounds can be our type if this is
1862 a type from Standard, so set them at the end of the function. */
1863 gnu_type
= make_node (REAL_TYPE
);
1864 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1865 layout_type (gnu_type
);
1868 case E_Floating_Point_Subtype
:
1869 if (Vax_Float (gnat_entity
))
1871 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1877 && Present (Ancestor_Subtype (gnat_entity
))
1878 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1879 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1880 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1881 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1884 gnu_type
= make_node (REAL_TYPE
);
1885 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1886 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1887 TYPE_GCC_MIN_VALUE (gnu_type
)
1888 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type
));
1889 TYPE_GCC_MAX_VALUE (gnu_type
)
1890 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type
));
1891 layout_type (gnu_type
);
1893 SET_TYPE_RM_MIN_VALUE
1895 convert (TREE_TYPE (gnu_type
),
1896 elaborate_expression (Type_Low_Bound (gnat_entity
),
1897 gnat_entity
, get_identifier ("L"),
1899 Needs_Debug_Info (gnat_entity
))));
1901 SET_TYPE_RM_MAX_VALUE
1903 convert (TREE_TYPE (gnu_type
),
1904 elaborate_expression (Type_High_Bound (gnat_entity
),
1905 gnat_entity
, get_identifier ("U"),
1907 Needs_Debug_Info (gnat_entity
))));
1909 /* One of the above calls might have caused us to be elaborated,
1910 so don't blow up if so. */
1911 if (present_gnu_tree (gnat_entity
))
1913 maybe_present
= true;
1917 /* Inherit our alias set from what we're a subtype of, as for
1918 integer subtypes. */
1919 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
1923 /* Array and String Types and Subtypes
1925 Unconstrained array types are represented by E_Array_Type and
1926 constrained array types are represented by E_Array_Subtype. There
1927 are no actual objects of an unconstrained array type; all we have
1928 are pointers to that type.
1930 The following fields are defined on array types and subtypes:
1932 Component_Type Component type of the array.
1933 Number_Dimensions Number of dimensions (an int).
1934 First_Index Type of first index. */
1939 const bool convention_fortran_p
1940 = (Convention (gnat_entity
) == Convention_Fortran
);
1941 const int ndim
= Number_Dimensions (gnat_entity
);
1942 tree gnu_template_type
= make_node (RECORD_TYPE
);
1943 tree gnu_ptr_template
= build_pointer_type (gnu_template_type
);
1944 tree gnu_template_reference
, gnu_template_fields
, gnu_fat_type
;
1945 tree
*gnu_index_types
= XALLOCAVEC (tree
, ndim
);
1946 tree
*gnu_temp_fields
= XALLOCAVEC (tree
, ndim
);
1947 tree gnu_max_size
= size_one_node
, gnu_max_size_unit
, tem
, t
;
1948 Entity_Id gnat_index
, gnat_name
;
1951 /* We complete an existing dummy fat pointer type in place. This both
1952 avoids further complex adjustments in update_pointer_to and yields
1953 better debugging information in DWARF by leveraging the support for
1954 incomplete declarations of "tagged" types in the DWARF back-end. */
1955 gnu_type
= get_dummy_type (gnat_entity
);
1956 if (gnu_type
&& TYPE_POINTER_TO (gnu_type
))
1958 gnu_fat_type
= TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type
));
1959 TYPE_NAME (gnu_fat_type
) = NULL_TREE
;
1960 /* Save the contents of the dummy type for update_pointer_to. */
1961 TYPE_POINTER_TO (gnu_type
) = copy_type (gnu_fat_type
);
1964 gnu_fat_type
= make_node (RECORD_TYPE
);
1966 /* Make a node for the array. If we are not defining the array
1967 suppress expanding incomplete types. */
1968 gnu_type
= make_node (UNCONSTRAINED_ARRAY_TYPE
);
1972 defer_incomplete_level
++;
1973 this_deferred
= true;
1976 /* Build the fat pointer type. Use a "void *" object instead of
1977 a pointer to the array type since we don't have the array type
1978 yet (it will reference the fat pointer via the bounds). */
1980 = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node
,
1981 gnu_fat_type
, NULL_TREE
, NULL_TREE
, 0, 0);
1983 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template
,
1984 gnu_fat_type
, NULL_TREE
, NULL_TREE
, 0, 0);
1986 if (COMPLETE_TYPE_P (gnu_fat_type
))
1988 /* We are going to lay it out again so reset the alias set. */
1989 alias_set_type alias_set
= TYPE_ALIAS_SET (gnu_fat_type
);
1990 TYPE_ALIAS_SET (gnu_fat_type
) = -1;
1991 finish_fat_pointer_type (gnu_fat_type
, tem
);
1992 TYPE_ALIAS_SET (gnu_fat_type
) = alias_set
;
1993 for (t
= gnu_fat_type
; t
; t
= TYPE_NEXT_VARIANT (t
))
1995 TYPE_FIELDS (t
) = tem
;
1996 SET_TYPE_UNCONSTRAINED_ARRAY (t
, gnu_type
);
2001 finish_fat_pointer_type (gnu_fat_type
, tem
);
2002 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type
, gnu_type
);
2005 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2006 is the fat pointer. This will be used to access the individual
2007 fields once we build them. */
2008 tem
= build3 (COMPONENT_REF
, gnu_ptr_template
,
2009 build0 (PLACEHOLDER_EXPR
, gnu_fat_type
),
2010 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type
)), NULL_TREE
);
2011 gnu_template_reference
2012 = build_unary_op (INDIRECT_REF
, gnu_template_type
, tem
);
2013 TREE_READONLY (gnu_template_reference
) = 1;
2014 TREE_THIS_NOTRAP (gnu_template_reference
) = 1;
2016 /* Now create the GCC type for each index and add the fields for that
2017 index to the template. */
2018 for (index
= (convention_fortran_p
? ndim
- 1 : 0),
2019 gnat_index
= First_Index (gnat_entity
);
2020 0 <= index
&& index
< ndim
;
2021 index
+= (convention_fortran_p
? - 1 : 1),
2022 gnat_index
= Next_Index (gnat_index
))
2024 char field_name
[16];
2025 tree gnu_index_base_type
2026 = get_unpadded_type (Base_Type (Etype (gnat_index
)));
2027 tree gnu_lb_field
, gnu_hb_field
, gnu_orig_min
, gnu_orig_max
;
2028 tree gnu_min
, gnu_max
, gnu_high
;
2030 /* Make the FIELD_DECLs for the low and high bounds of this
2031 type and then make extractions of these fields from the
2033 sprintf (field_name
, "LB%d", index
);
2034 gnu_lb_field
= create_field_decl (get_identifier (field_name
),
2035 gnu_index_base_type
,
2036 gnu_template_type
, NULL_TREE
,
2038 Sloc_to_locus (Sloc (gnat_entity
),
2039 &DECL_SOURCE_LOCATION (gnu_lb_field
));
2041 field_name
[0] = 'U';
2042 gnu_hb_field
= create_field_decl (get_identifier (field_name
),
2043 gnu_index_base_type
,
2044 gnu_template_type
, NULL_TREE
,
2046 Sloc_to_locus (Sloc (gnat_entity
),
2047 &DECL_SOURCE_LOCATION (gnu_hb_field
));
2049 gnu_temp_fields
[index
] = chainon (gnu_lb_field
, gnu_hb_field
);
2051 /* We can't use build_component_ref here since the template type
2052 isn't complete yet. */
2053 gnu_orig_min
= build3 (COMPONENT_REF
, gnu_index_base_type
,
2054 gnu_template_reference
, gnu_lb_field
,
2056 gnu_orig_max
= build3 (COMPONENT_REF
, gnu_index_base_type
,
2057 gnu_template_reference
, gnu_hb_field
,
2059 TREE_READONLY (gnu_orig_min
) = TREE_READONLY (gnu_orig_max
) = 1;
2061 gnu_min
= convert (sizetype
, gnu_orig_min
);
2062 gnu_max
= convert (sizetype
, gnu_orig_max
);
2064 /* Compute the size of this dimension. See the E_Array_Subtype
2065 case below for the rationale. */
2067 = build3 (COND_EXPR
, sizetype
,
2068 build2 (GE_EXPR
, boolean_type_node
,
2069 gnu_orig_max
, gnu_orig_min
),
2071 size_binop (MINUS_EXPR
, gnu_min
, size_one_node
));
2073 /* Make a range type with the new range in the Ada base type.
2074 Then make an index type with the size range in sizetype. */
2075 gnu_index_types
[index
]
2076 = create_index_type (gnu_min
, gnu_high
,
2077 create_range_type (gnu_index_base_type
,
2082 /* Update the maximum size of the array in elements. */
2085 tree gnu_index_type
= get_unpadded_type (Etype (gnat_index
));
2087 = convert (sizetype
, TYPE_MIN_VALUE (gnu_index_type
));
2089 = convert (sizetype
, TYPE_MAX_VALUE (gnu_index_type
));
2091 = size_binop (MAX_EXPR
,
2092 size_binop (PLUS_EXPR
, size_one_node
,
2093 size_binop (MINUS_EXPR
,
2097 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2098 && TREE_OVERFLOW (gnu_this_max
))
2099 gnu_max_size
= NULL_TREE
;
2102 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2105 TYPE_NAME (gnu_index_types
[index
])
2106 = create_concat_name (gnat_entity
, field_name
);
2109 /* Install all the fields into the template. */
2110 TYPE_NAME (gnu_template_type
)
2111 = create_concat_name (gnat_entity
, "XUB");
2112 gnu_template_fields
= NULL_TREE
;
2113 for (index
= 0; index
< ndim
; index
++)
2115 = chainon (gnu_template_fields
, gnu_temp_fields
[index
]);
2116 finish_record_type (gnu_template_type
, gnu_template_fields
, 0,
2118 TYPE_READONLY (gnu_template_type
) = 1;
2120 /* Now make the array of arrays and update the pointer to the array
2121 in the fat pointer. Note that it is the first field. */
2123 = gnat_to_gnu_component_type (gnat_entity
, definition
, debug_info_p
);
2125 /* If Component_Size is not already specified, annotate it with the
2126 size of the component. */
2127 if (Unknown_Component_Size (gnat_entity
))
2128 Set_Component_Size (gnat_entity
, annotate_value (TYPE_SIZE (tem
)));
2130 /* Compute the maximum size of the array in units and bits. */
2133 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2134 TYPE_SIZE_UNIT (tem
));
2135 gnu_max_size
= size_binop (MULT_EXPR
,
2136 convert (bitsizetype
, gnu_max_size
),
2140 gnu_max_size_unit
= NULL_TREE
;
2142 /* Now build the array type. */
2143 for (index
= ndim
- 1; index
>= 0; index
--)
2145 tem
= build_nonshared_array_type (tem
, gnu_index_types
[index
]);
2146 TYPE_MULTI_ARRAY_P (tem
) = (index
> 0);
2147 if (array_type_has_nonaliased_component (tem
, gnat_entity
))
2148 TYPE_NONALIASED_COMPONENT (tem
) = 1;
2151 /* If an alignment is specified, use it if valid. But ignore it
2152 for the original type of packed array types. If the alignment
2153 was requested with an explicit alignment clause, state so. */
2154 if (No (Packed_Array_Type (gnat_entity
))
2155 && Known_Alignment (gnat_entity
))
2158 = validate_alignment (Alignment (gnat_entity
), gnat_entity
,
2160 if (Present (Alignment_Clause (gnat_entity
)))
2161 TYPE_USER_ALIGN (tem
) = 1;
2164 TYPE_CONVENTION_FORTRAN_P (tem
) = convention_fortran_p
;
2166 /* Adjust the type of the pointer-to-array field of the fat pointer
2167 and record the aliasing relationships if necessary. */
2168 TREE_TYPE (TYPE_FIELDS (gnu_fat_type
)) = build_pointer_type (tem
);
2169 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type
))
2170 record_component_aliases (gnu_fat_type
);
2172 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2173 corresponding fat pointer. */
2174 TREE_TYPE (gnu_type
) = gnu_fat_type
;
2175 TYPE_POINTER_TO (gnu_type
) = gnu_fat_type
;
2176 TYPE_REFERENCE_TO (gnu_type
) = gnu_fat_type
;
2177 SET_TYPE_MODE (gnu_type
, BLKmode
);
2178 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (tem
);
2180 /* If the maximum size doesn't overflow, use it. */
2182 && TREE_CODE (gnu_max_size
) == INTEGER_CST
2183 && !TREE_OVERFLOW (gnu_max_size
)
2184 && TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2185 && !TREE_OVERFLOW (gnu_max_size_unit
))
2187 TYPE_SIZE (tem
) = size_binop (MIN_EXPR
, gnu_max_size
,
2189 TYPE_SIZE_UNIT (tem
) = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2190 TYPE_SIZE_UNIT (tem
));
2193 create_type_decl (create_concat_name (gnat_entity
, "XUA"),
2194 tem
, NULL
, !Comes_From_Source (gnat_entity
),
2195 debug_info_p
, gnat_entity
);
2197 /* Give the fat pointer type a name. If this is a packed type, tell
2198 the debugger how to interpret the underlying bits. */
2199 if (Present (Packed_Array_Type (gnat_entity
)))
2200 gnat_name
= Packed_Array_Type (gnat_entity
);
2202 gnat_name
= gnat_entity
;
2203 create_type_decl (create_concat_name (gnat_name
, "XUP"),
2204 gnu_fat_type
, NULL
, !Comes_From_Source (gnat_entity
),
2205 debug_info_p
, gnat_entity
);
2207 /* Create the type to be used as what a thin pointer designates:
2208 a record type for the object and its template with the fields
2209 shifted to have the template at a negative offset. */
2210 tem
= build_unc_object_type (gnu_template_type
, tem
,
2211 create_concat_name (gnat_name
, "XUT"),
2213 shift_unc_components_for_thin_pointers (tem
);
2215 SET_TYPE_UNCONSTRAINED_ARRAY (tem
, gnu_type
);
2216 TYPE_OBJECT_RECORD_TYPE (gnu_type
) = tem
;
2220 case E_String_Subtype
:
2221 case E_Array_Subtype
:
2223 /* This is the actual data type for array variables. Multidimensional
2224 arrays are implemented as arrays of arrays. Note that arrays which
2225 have sparse enumeration subtypes as index components create sparse
2226 arrays, which is obviously space inefficient but so much easier to
2229 Also note that the subtype never refers to the unconstrained array
2230 type, which is somewhat at variance with Ada semantics.
2232 First check to see if this is simply a renaming of the array type.
2233 If so, the result is the array type. */
2235 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
2236 if (!Is_Constrained (gnat_entity
))
2240 Entity_Id gnat_index
, gnat_base_index
;
2241 const bool convention_fortran_p
2242 = (Convention (gnat_entity
) == Convention_Fortran
);
2243 const int ndim
= Number_Dimensions (gnat_entity
);
2244 tree gnu_base_type
= gnu_type
;
2245 tree
*gnu_index_types
= XALLOCAVEC (tree
, ndim
);
2246 tree gnu_max_size
= size_one_node
, gnu_max_size_unit
;
2247 bool need_index_type_struct
= false;
2250 /* First create the GCC type for each index and find out whether
2251 special types are needed for debugging information. */
2252 for (index
= (convention_fortran_p
? ndim
- 1 : 0),
2253 gnat_index
= First_Index (gnat_entity
),
2255 = First_Index (Implementation_Base_Type (gnat_entity
));
2256 0 <= index
&& index
< ndim
;
2257 index
+= (convention_fortran_p
? - 1 : 1),
2258 gnat_index
= Next_Index (gnat_index
),
2259 gnat_base_index
= Next_Index (gnat_base_index
))
2261 tree gnu_index_type
= get_unpadded_type (Etype (gnat_index
));
2262 tree gnu_orig_min
= TYPE_MIN_VALUE (gnu_index_type
);
2263 tree gnu_orig_max
= TYPE_MAX_VALUE (gnu_index_type
);
2264 tree gnu_min
= convert (sizetype
, gnu_orig_min
);
2265 tree gnu_max
= convert (sizetype
, gnu_orig_max
);
2266 tree gnu_base_index_type
2267 = get_unpadded_type (Etype (gnat_base_index
));
2268 tree gnu_base_orig_min
= TYPE_MIN_VALUE (gnu_base_index_type
);
2269 tree gnu_base_orig_max
= TYPE_MAX_VALUE (gnu_base_index_type
);
2272 /* See if the base array type is already flat. If it is, we
2273 are probably compiling an ACATS test but it will cause the
2274 code below to malfunction if we don't handle it specially. */
2275 if (TREE_CODE (gnu_base_orig_min
) == INTEGER_CST
2276 && TREE_CODE (gnu_base_orig_max
) == INTEGER_CST
2277 && tree_int_cst_lt (gnu_base_orig_max
, gnu_base_orig_min
))
2279 gnu_min
= size_one_node
;
2280 gnu_max
= size_zero_node
;
2284 /* Similarly, if one of the values overflows in sizetype and the
2285 range is null, use 1..0 for the sizetype bounds. */
2286 else if (TREE_CODE (gnu_min
) == INTEGER_CST
2287 && TREE_CODE (gnu_max
) == INTEGER_CST
2288 && (TREE_OVERFLOW (gnu_min
) || TREE_OVERFLOW (gnu_max
))
2289 && tree_int_cst_lt (gnu_orig_max
, gnu_orig_min
))
2291 gnu_min
= size_one_node
;
2292 gnu_max
= size_zero_node
;
2296 /* If the minimum and maximum values both overflow in sizetype,
2297 but the difference in the original type does not overflow in
2298 sizetype, ignore the overflow indication. */
2299 else if (TREE_CODE (gnu_min
) == INTEGER_CST
2300 && TREE_CODE (gnu_max
) == INTEGER_CST
2301 && TREE_OVERFLOW (gnu_min
) && TREE_OVERFLOW (gnu_max
)
2304 fold_build2 (MINUS_EXPR
, gnu_index_type
,
2308 TREE_OVERFLOW (gnu_min
) = 0;
2309 TREE_OVERFLOW (gnu_max
) = 0;
2313 /* Compute the size of this dimension in the general case. We
2314 need to provide GCC with an upper bound to use but have to
2315 deal with the "superflat" case. There are three ways to do
2316 this. If we can prove that the array can never be superflat,
2317 we can just use the high bound of the index type. */
2318 else if ((Nkind (gnat_index
) == N_Range
2319 && cannot_be_superflat_p (gnat_index
))
2320 /* Packed Array Types are never superflat. */
2321 || Is_Packed_Array_Type (gnat_entity
))
2324 /* Otherwise, if the high bound is constant but the low bound is
2325 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2326 lower bound. Note that the comparison must be done in the
2327 original type to avoid any overflow during the conversion. */
2328 else if (TREE_CODE (gnu_max
) == INTEGER_CST
2329 && TREE_CODE (gnu_min
) != INTEGER_CST
)
2333 = build_cond_expr (sizetype
,
2334 build_binary_op (GE_EXPR
,
2339 size_binop (PLUS_EXPR
, gnu_max
,
2343 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2344 in all the other cases. Note that, here as well as above,
2345 the condition used in the comparison must be equivalent to
2346 the condition (length != 0). This is relied upon in order
2347 to optimize array comparisons in compare_arrays. */
2350 = build_cond_expr (sizetype
,
2351 build_binary_op (GE_EXPR
,
2356 size_binop (MINUS_EXPR
, gnu_min
,
2359 /* Reuse the index type for the range type. Then make an index
2360 type with the size range in sizetype. */
2361 gnu_index_types
[index
]
2362 = create_index_type (gnu_min
, gnu_high
, gnu_index_type
,
2365 /* Update the maximum size of the array in elements. Here we
2366 see if any constraint on the index type of the base type
2367 can be used in the case of self-referential bound on the
2368 index type of the subtype. We look for a non-"infinite"
2369 and non-self-referential bound from any type involved and
2370 handle each bound separately. */
2373 tree gnu_base_min
= convert (sizetype
, gnu_base_orig_min
);
2374 tree gnu_base_max
= convert (sizetype
, gnu_base_orig_max
);
2375 tree gnu_base_index_base_type
2376 = get_base_type (gnu_base_index_type
);
2377 tree gnu_base_base_min
2378 = convert (sizetype
,
2379 TYPE_MIN_VALUE (gnu_base_index_base_type
));
2380 tree gnu_base_base_max
2381 = convert (sizetype
,
2382 TYPE_MAX_VALUE (gnu_base_index_base_type
));
2384 if (!CONTAINS_PLACEHOLDER_P (gnu_min
)
2385 || !(TREE_CODE (gnu_base_min
) == INTEGER_CST
2386 && !TREE_OVERFLOW (gnu_base_min
)))
2387 gnu_base_min
= gnu_min
;
2389 if (!CONTAINS_PLACEHOLDER_P (gnu_max
)
2390 || !(TREE_CODE (gnu_base_max
) == INTEGER_CST
2391 && !TREE_OVERFLOW (gnu_base_max
)))
2392 gnu_base_max
= gnu_max
;
2394 if ((TREE_CODE (gnu_base_min
) == INTEGER_CST
2395 && TREE_OVERFLOW (gnu_base_min
))
2396 || operand_equal_p (gnu_base_min
, gnu_base_base_min
, 0)
2397 || (TREE_CODE (gnu_base_max
) == INTEGER_CST
2398 && TREE_OVERFLOW (gnu_base_max
))
2399 || operand_equal_p (gnu_base_max
, gnu_base_base_max
, 0))
2400 gnu_max_size
= NULL_TREE
;
2404 = size_binop (MAX_EXPR
,
2405 size_binop (PLUS_EXPR
, size_one_node
,
2406 size_binop (MINUS_EXPR
,
2411 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2412 && TREE_OVERFLOW (gnu_this_max
))
2413 gnu_max_size
= NULL_TREE
;
2416 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2420 /* We need special types for debugging information to point to
2421 the index types if they have variable bounds, are not integer
2422 types, are biased or are wider than sizetype. */
2423 if (!integer_onep (gnu_orig_min
)
2424 || TREE_CODE (gnu_orig_max
) != INTEGER_CST
2425 || TREE_CODE (gnu_index_type
) != INTEGER_TYPE
2426 || (TREE_TYPE (gnu_index_type
)
2427 && TREE_CODE (TREE_TYPE (gnu_index_type
))
2429 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type
)
2430 || compare_tree_int (rm_size (gnu_index_type
),
2431 TYPE_PRECISION (sizetype
)) > 0)
2432 need_index_type_struct
= true;
2435 /* Then flatten: create the array of arrays. For an array type
2436 used to implement a packed array, get the component type from
2437 the original array type since the representation clauses that
2438 can affect it are on the latter. */
2439 if (Is_Packed_Array_Type (gnat_entity
)
2440 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
2442 gnu_type
= gnat_to_gnu_type (Original_Array_Type (gnat_entity
));
2443 for (index
= ndim
- 1; index
>= 0; index
--)
2444 gnu_type
= TREE_TYPE (gnu_type
);
2446 /* One of the above calls might have caused us to be elaborated,
2447 so don't blow up if so. */
2448 if (present_gnu_tree (gnat_entity
))
2450 maybe_present
= true;
2456 gnu_type
= gnat_to_gnu_component_type (gnat_entity
, definition
,
2459 /* One of the above calls might have caused us to be elaborated,
2460 so don't blow up if so. */
2461 if (present_gnu_tree (gnat_entity
))
2463 maybe_present
= true;
2468 /* Compute the maximum size of the array in units and bits. */
2471 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2472 TYPE_SIZE_UNIT (gnu_type
));
2473 gnu_max_size
= size_binop (MULT_EXPR
,
2474 convert (bitsizetype
, gnu_max_size
),
2475 TYPE_SIZE (gnu_type
));
2478 gnu_max_size_unit
= NULL_TREE
;
2480 /* Now build the array type. */
2481 for (index
= ndim
- 1; index
>= 0; index
--)
2483 gnu_type
= build_nonshared_array_type (gnu_type
,
2484 gnu_index_types
[index
]);
2485 TYPE_MULTI_ARRAY_P (gnu_type
) = (index
> 0);
2486 if (array_type_has_nonaliased_component (gnu_type
, gnat_entity
))
2487 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2490 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2491 TYPE_STUB_DECL (gnu_type
)
2492 = create_type_stub_decl (gnu_entity_name
, gnu_type
);
2494 /* If we are at file level and this is a multi-dimensional array,
2495 we need to make a variable corresponding to the stride of the
2496 inner dimensions. */
2497 if (global_bindings_p () && ndim
> 1)
2499 tree gnu_st_name
= get_identifier ("ST");
2502 for (gnu_arr_type
= TREE_TYPE (gnu_type
);
2503 TREE_CODE (gnu_arr_type
) == ARRAY_TYPE
;
2504 gnu_arr_type
= TREE_TYPE (gnu_arr_type
),
2505 gnu_st_name
= concat_name (gnu_st_name
, "ST"))
2507 tree eltype
= TREE_TYPE (gnu_arr_type
);
2509 TYPE_SIZE (gnu_arr_type
)
2510 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type
),
2511 gnat_entity
, gnu_st_name
,
2514 /* ??? For now, store the size as a multiple of the
2515 alignment of the element type in bytes so that we
2516 can see the alignment from the tree. */
2517 TYPE_SIZE_UNIT (gnu_arr_type
)
2518 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type
),
2520 concat_name (gnu_st_name
, "A_U"),
2522 TYPE_ALIGN (eltype
));
2524 /* ??? create_type_decl is not invoked on the inner types so
2525 the MULT_EXPR node built above will never be marked. */
2526 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type
));
2530 /* If we need to write out a record type giving the names of the
2531 bounds for debugging purposes, do it now and make the record
2532 type a parallel type. This is not needed for a packed array
2533 since the bounds are conveyed by the original array type. */
2534 if (need_index_type_struct
2536 && !Is_Packed_Array_Type (gnat_entity
))
2538 tree gnu_bound_rec
= make_node (RECORD_TYPE
);
2539 tree gnu_field_list
= NULL_TREE
;
2542 TYPE_NAME (gnu_bound_rec
)
2543 = create_concat_name (gnat_entity
, "XA");
2545 for (index
= ndim
- 1; index
>= 0; index
--)
2547 tree gnu_index
= TYPE_INDEX_TYPE (gnu_index_types
[index
]);
2548 tree gnu_index_name
= TYPE_NAME (gnu_index
);
2550 if (TREE_CODE (gnu_index_name
) == TYPE_DECL
)
2551 gnu_index_name
= DECL_NAME (gnu_index_name
);
2553 /* Make sure to reference the types themselves, and not just
2554 their names, as the debugger may fall back on them. */
2555 gnu_field
= create_field_decl (gnu_index_name
, gnu_index
,
2556 gnu_bound_rec
, NULL_TREE
,
2558 DECL_CHAIN (gnu_field
) = gnu_field_list
;
2559 gnu_field_list
= gnu_field
;
2562 finish_record_type (gnu_bound_rec
, gnu_field_list
, 0, true);
2563 add_parallel_type (TYPE_STUB_DECL (gnu_type
), gnu_bound_rec
);
2566 /* If this is a packed array type, make the original array type a
2567 parallel type. Otherwise, do it for the base array type if it
2568 isn't artificial to make sure it is kept in the debug info. */
2571 if (Is_Packed_Array_Type (gnat_entity
)
2572 && present_gnu_tree (Original_Array_Type (gnat_entity
)))
2573 add_parallel_type (TYPE_STUB_DECL (gnu_type
),
2575 (Original_Array_Type (gnat_entity
)));
2579 = gnat_to_gnu_entity (Etype (gnat_entity
), NULL_TREE
, 0);
2580 if (!DECL_ARTIFICIAL (gnu_base_decl
))
2581 add_parallel_type (TYPE_STUB_DECL (gnu_type
),
2582 TREE_TYPE (TREE_TYPE (gnu_base_decl
)));
2586 TYPE_CONVENTION_FORTRAN_P (gnu_type
) = convention_fortran_p
;
2587 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
2588 = (Is_Packed_Array_Type (gnat_entity
)
2589 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
2591 /* If the size is self-referential and the maximum size doesn't
2592 overflow, use it. */
2593 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
2595 && !(TREE_CODE (gnu_max_size
) == INTEGER_CST
2596 && TREE_OVERFLOW (gnu_max_size
))
2597 && !(TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2598 && TREE_OVERFLOW (gnu_max_size_unit
)))
2600 TYPE_SIZE (gnu_type
) = size_binop (MIN_EXPR
, gnu_max_size
,
2601 TYPE_SIZE (gnu_type
));
2602 TYPE_SIZE_UNIT (gnu_type
)
2603 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2604 TYPE_SIZE_UNIT (gnu_type
));
2607 /* Set our alias set to that of our base type. This gives all
2608 array subtypes the same alias set. */
2609 relate_alias_sets (gnu_type
, gnu_base_type
, ALIAS_SET_COPY
);
2611 /* If this is a packed type, make this type the same as the packed
2612 array type, but do some adjusting in the type first. */
2613 if (Present (Packed_Array_Type (gnat_entity
)))
2615 Entity_Id gnat_index
;
2618 /* First finish the type we had been making so that we output
2619 debugging information for it. */
2620 if (Treat_As_Volatile (gnat_entity
))
2622 = build_qualified_type (gnu_type
,
2623 TYPE_QUALS (gnu_type
)
2624 | TYPE_QUAL_VOLATILE
);
2626 /* Make it artificial only if the base type was artificial too.
2627 That's sort of "morally" true and will make it possible for
2628 the debugger to look it up by name in DWARF, which is needed
2629 in order to decode the packed array type. */
2631 = create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
2632 !Comes_From_Source (Etype (gnat_entity
))
2633 && !Comes_From_Source (gnat_entity
),
2634 debug_info_p
, gnat_entity
);
2636 /* Save it as our equivalent in case the call below elaborates
2638 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2640 gnu_decl
= gnat_to_gnu_entity (Packed_Array_Type (gnat_entity
),
2642 this_made_decl
= true;
2643 gnu_type
= TREE_TYPE (gnu_decl
);
2644 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
2646 gnu_inner
= gnu_type
;
2647 while (TREE_CODE (gnu_inner
) == RECORD_TYPE
2648 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner
)
2649 || TYPE_PADDING_P (gnu_inner
)))
2650 gnu_inner
= TREE_TYPE (TYPE_FIELDS (gnu_inner
));
2652 /* We need to attach the index type to the type we just made so
2653 that the actual bounds can later be put into a template. */
2654 if ((TREE_CODE (gnu_inner
) == ARRAY_TYPE
2655 && !TYPE_ACTUAL_BOUNDS (gnu_inner
))
2656 || (TREE_CODE (gnu_inner
) == INTEGER_TYPE
2657 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner
)))
2659 if (TREE_CODE (gnu_inner
) == INTEGER_TYPE
)
2661 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2662 TYPE_MODULUS for modular types so we make an extra
2663 subtype if necessary. */
2664 if (TYPE_MODULAR_P (gnu_inner
))
2667 = make_unsigned_type (TYPE_PRECISION (gnu_inner
));
2668 TREE_TYPE (gnu_subtype
) = gnu_inner
;
2669 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
2670 SET_TYPE_RM_MIN_VALUE (gnu_subtype
,
2671 TYPE_MIN_VALUE (gnu_inner
));
2672 SET_TYPE_RM_MAX_VALUE (gnu_subtype
,
2673 TYPE_MAX_VALUE (gnu_inner
));
2674 gnu_inner
= gnu_subtype
;
2677 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner
) = 1;
2679 #ifdef ENABLE_CHECKING
2680 /* Check for other cases of overloading. */
2681 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner
));
2685 for (gnat_index
= First_Index (gnat_entity
);
2686 Present (gnat_index
);
2687 gnat_index
= Next_Index (gnat_index
))
2688 SET_TYPE_ACTUAL_BOUNDS
2690 tree_cons (NULL_TREE
,
2691 get_unpadded_type (Etype (gnat_index
)),
2692 TYPE_ACTUAL_BOUNDS (gnu_inner
)));
2694 if (Convention (gnat_entity
) != Convention_Fortran
)
2695 SET_TYPE_ACTUAL_BOUNDS
2696 (gnu_inner
, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner
)));
2698 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2699 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
2700 TREE_TYPE (TYPE_FIELDS (gnu_type
)) = gnu_inner
;
2705 /* Abort if packed array with no Packed_Array_Type field set. */
2706 gcc_assert (!Is_Packed (gnat_entity
));
2710 case E_String_Literal_Subtype
:
2711 /* Create the type for a string literal. */
2713 Entity_Id gnat_full_type
2714 = (IN (Ekind (Etype (gnat_entity
)), Private_Kind
)
2715 && Present (Full_View (Etype (gnat_entity
)))
2716 ? Full_View (Etype (gnat_entity
)) : Etype (gnat_entity
));
2717 tree gnu_string_type
= get_unpadded_type (gnat_full_type
);
2718 tree gnu_string_array_type
2719 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type
))));
2720 tree gnu_string_index_type
2721 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2722 (TYPE_DOMAIN (gnu_string_array_type
))));
2723 tree gnu_lower_bound
2724 = convert (gnu_string_index_type
,
2725 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity
)));
2726 int length
= UI_To_Int (String_Literal_Length (gnat_entity
));
2727 tree gnu_length
= ssize_int (length
- 1);
2728 tree gnu_upper_bound
2729 = build_binary_op (PLUS_EXPR
, gnu_string_index_type
,
2731 convert (gnu_string_index_type
, gnu_length
));
2733 = create_index_type (convert (sizetype
, gnu_lower_bound
),
2734 convert (sizetype
, gnu_upper_bound
),
2735 create_range_type (gnu_string_index_type
,
2741 = build_nonshared_array_type (gnat_to_gnu_type
2742 (Component_Type (gnat_entity
)),
2744 if (array_type_has_nonaliased_component (gnu_type
, gnat_entity
))
2745 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2746 relate_alias_sets (gnu_type
, gnu_string_type
, ALIAS_SET_COPY
);
2750 /* Record Types and Subtypes
2752 The following fields are defined on record types:
2754 Has_Discriminants True if the record has discriminants
2755 First_Discriminant Points to head of list of discriminants
2756 First_Entity Points to head of list of fields
2757 Is_Tagged_Type True if the record is tagged
2759 Implementation of Ada records and discriminated records:
2761 A record type definition is transformed into the equivalent of a C
2762 struct definition. The fields that are the discriminants which are
2763 found in the Full_Type_Declaration node and the elements of the
2764 Component_List found in the Record_Type_Definition node. The
2765 Component_List can be a recursive structure since each Variant of
2766 the Variant_Part of the Component_List has a Component_List.
2768 Processing of a record type definition comprises starting the list of
2769 field declarations here from the discriminants and the calling the
2770 function components_to_record to add the rest of the fields from the
2771 component list and return the gnu type node. The function
2772 components_to_record will call itself recursively as it traverses
2776 if (Has_Complex_Representation (gnat_entity
))
2779 = build_complex_type
2781 (Etype (Defining_Entity
2782 (First (Component_Items
2785 (Declaration_Node (gnat_entity
)))))))));
2791 Node_Id full_definition
= Declaration_Node (gnat_entity
);
2792 Node_Id record_definition
= Type_Definition (full_definition
);
2793 Entity_Id gnat_field
;
2794 tree gnu_field
, gnu_field_list
= NULL_TREE
, gnu_get_parent
;
2795 /* Set PACKED in keeping with gnat_to_gnu_field. */
2797 = Is_Packed (gnat_entity
)
2799 : Component_Alignment (gnat_entity
) == Calign_Storage_Unit
2801 : (Known_Alignment (gnat_entity
)
2802 || (Strict_Alignment (gnat_entity
)
2803 && Known_RM_Size (gnat_entity
)))
2806 bool has_discr
= Has_Discriminants (gnat_entity
);
2807 bool has_rep
= Has_Specified_Layout (gnat_entity
);
2808 bool all_rep
= has_rep
;
2810 = (Is_Tagged_Type (gnat_entity
)
2811 && Nkind (record_definition
) == N_Derived_Type_Definition
);
2812 bool is_unchecked_union
= Is_Unchecked_Union (gnat_entity
);
2814 /* See if all fields have a rep clause. Stop when we find one
2817 for (gnat_field
= First_Entity (gnat_entity
);
2818 Present (gnat_field
);
2819 gnat_field
= Next_Entity (gnat_field
))
2820 if ((Ekind (gnat_field
) == E_Component
2821 || Ekind (gnat_field
) == E_Discriminant
)
2822 && No (Component_Clause (gnat_field
)))
2828 /* If this is a record extension, go a level further to find the
2829 record definition. Also, verify we have a Parent_Subtype. */
2832 if (!type_annotate_only
2833 || Present (Record_Extension_Part (record_definition
)))
2834 record_definition
= Record_Extension_Part (record_definition
);
2836 gcc_assert (type_annotate_only
2837 || Present (Parent_Subtype (gnat_entity
)));
2840 /* Make a node for the record. If we are not defining the record,
2841 suppress expanding incomplete types. */
2842 gnu_type
= make_node (tree_code_for_record_type (gnat_entity
));
2843 TYPE_NAME (gnu_type
) = gnu_entity_name
;
2844 TYPE_PACKED (gnu_type
) = (packed
!= 0) || has_rep
;
2848 defer_incomplete_level
++;
2849 this_deferred
= true;
2852 /* If both a size and rep clause was specified, put the size in
2853 the record type now so that it can get the proper mode. */
2854 if (has_rep
&& Known_RM_Size (gnat_entity
))
2855 TYPE_SIZE (gnu_type
)
2856 = UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
);
2858 /* Always set the alignment here so that it can be used to
2859 set the mode, if it is making the alignment stricter. If
2860 it is invalid, it will be checked again below. If this is to
2861 be Atomic, choose a default alignment of a word unless we know
2862 the size and it's smaller. */
2863 if (Known_Alignment (gnat_entity
))
2864 TYPE_ALIGN (gnu_type
)
2865 = validate_alignment (Alignment (gnat_entity
), gnat_entity
, 0);
2866 else if (Is_Atomic (gnat_entity
))
2867 TYPE_ALIGN (gnu_type
)
2868 = esize
>= BITS_PER_WORD
? BITS_PER_WORD
: ceil_alignment (esize
);
2869 /* If a type needs strict alignment, the minimum size will be the
2870 type size instead of the RM size (see validate_size). Cap the
2871 alignment, lest it causes this type size to become too large. */
2872 else if (Strict_Alignment (gnat_entity
)
2873 && Known_RM_Size (gnat_entity
))
2875 unsigned int raw_size
= UI_To_Int (RM_Size (gnat_entity
));
2876 unsigned int raw_align
= raw_size
& -raw_size
;
2877 if (raw_align
< BIGGEST_ALIGNMENT
)
2878 TYPE_ALIGN (gnu_type
) = raw_align
;
2881 TYPE_ALIGN (gnu_type
) = 0;
2883 /* If we have a Parent_Subtype, make a field for the parent. If
2884 this record has rep clauses, force the position to zero. */
2885 if (Present (Parent_Subtype (gnat_entity
)))
2887 Entity_Id gnat_parent
= Parent_Subtype (gnat_entity
);
2890 /* A major complexity here is that the parent subtype will
2891 reference our discriminants in its Discriminant_Constraint
2892 list. But those must reference the parent component of this
2893 record which is of the parent subtype we have not built yet!
2894 To break the circle we first build a dummy COMPONENT_REF which
2895 represents the "get to the parent" operation and initialize
2896 each of those discriminants to a COMPONENT_REF of the above
2897 dummy parent referencing the corresponding discriminant of the
2898 base type of the parent subtype. */
2899 gnu_get_parent
= build3 (COMPONENT_REF
, void_type_node
,
2900 build0 (PLACEHOLDER_EXPR
, gnu_type
),
2901 build_decl (input_location
,
2902 FIELD_DECL
, NULL_TREE
,
2907 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2908 Present (gnat_field
);
2909 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2910 if (Present (Corresponding_Discriminant (gnat_field
)))
2913 = gnat_to_gnu_field_decl (Corresponding_Discriminant
2917 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
2918 gnu_get_parent
, gnu_field
, NULL_TREE
),
2922 /* Then we build the parent subtype. If it has discriminants but
2923 the type itself has unknown discriminants, this means that it
2924 doesn't contain information about how the discriminants are
2925 derived from those of the ancestor type, so it cannot be used
2926 directly. Instead it is built by cloning the parent subtype
2927 of the underlying record view of the type, for which the above
2928 derivation of discriminants has been made explicit. */
2929 if (Has_Discriminants (gnat_parent
)
2930 && Has_Unknown_Discriminants (gnat_entity
))
2932 Entity_Id gnat_uview
= Underlying_Record_View (gnat_entity
);
2934 /* If we are defining the type, the underlying record
2935 view must already have been elaborated at this point.
2936 Otherwise do it now as its parent subtype cannot be
2937 technically elaborated on its own. */
2939 gcc_assert (present_gnu_tree (gnat_uview
));
2941 gnat_to_gnu_entity (gnat_uview
, NULL_TREE
, 0);
2943 gnu_parent
= gnat_to_gnu_type (Parent_Subtype (gnat_uview
));
2945 /* Substitute the "get to the parent" of the type for that
2946 of its underlying record view in the cloned type. */
2947 for (gnat_field
= First_Stored_Discriminant (gnat_uview
);
2948 Present (gnat_field
);
2949 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2950 if (Present (Corresponding_Discriminant (gnat_field
)))
2952 tree gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
2954 = build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
2955 gnu_get_parent
, gnu_field
, NULL_TREE
);
2957 = substitute_in_type (gnu_parent
, gnu_field
, gnu_ref
);
2961 gnu_parent
= gnat_to_gnu_type (gnat_parent
);
2963 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2964 initially built. The discriminants must reference the fields
2965 of the parent subtype and not those of its base type for the
2966 placeholder machinery to properly work. */
2969 /* The actual parent subtype is the full view. */
2970 if (IN (Ekind (gnat_parent
), Private_Kind
))
2972 if (Present (Full_View (gnat_parent
)))
2973 gnat_parent
= Full_View (gnat_parent
);
2975 gnat_parent
= Underlying_Full_View (gnat_parent
);
2978 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2979 Present (gnat_field
);
2980 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2981 if (Present (Corresponding_Discriminant (gnat_field
)))
2983 Entity_Id field
= Empty
;
2984 for (field
= First_Stored_Discriminant (gnat_parent
);
2986 field
= Next_Stored_Discriminant (field
))
2987 if (same_discriminant_p (gnat_field
, field
))
2989 gcc_assert (Present (field
));
2990 TREE_OPERAND (get_gnu_tree (gnat_field
), 1)
2991 = gnat_to_gnu_field_decl (field
);
2995 /* The "get to the parent" COMPONENT_REF must be given its
2997 TREE_TYPE (gnu_get_parent
) = gnu_parent
;
2999 /* ...and reference the _Parent field of this record. */
3001 = create_field_decl (parent_name_id
,
3002 gnu_parent
, gnu_type
,
3004 ? TYPE_SIZE (gnu_parent
) : NULL_TREE
,
3006 ? bitsize_zero_node
: NULL_TREE
,
3008 DECL_INTERNAL_P (gnu_field
) = 1;
3009 TREE_OPERAND (gnu_get_parent
, 1) = gnu_field
;
3010 TYPE_FIELDS (gnu_type
) = gnu_field
;
3013 /* Make the fields for the discriminants and put them into the record
3014 unless it's an Unchecked_Union. */
3016 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3017 Present (gnat_field
);
3018 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3020 /* If this is a record extension and this discriminant is the
3021 renaming of another discriminant, we've handled it above. */
3022 if (Present (Parent_Subtype (gnat_entity
))
3023 && Present (Corresponding_Discriminant (gnat_field
)))
3027 = gnat_to_gnu_field (gnat_field
, gnu_type
, packed
, definition
,
3030 /* Make an expression using a PLACEHOLDER_EXPR from the
3031 FIELD_DECL node just created and link that with the
3032 corresponding GNAT defining identifier. */
3033 save_gnu_tree (gnat_field
,
3034 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3035 build0 (PLACEHOLDER_EXPR
, gnu_type
),
3036 gnu_field
, NULL_TREE
),
3039 if (!is_unchecked_union
)
3041 DECL_CHAIN (gnu_field
) = gnu_field_list
;
3042 gnu_field_list
= gnu_field
;
3046 /* Add the fields into the record type and finish it up. */
3047 components_to_record (gnu_type
, Component_List (record_definition
),
3048 gnu_field_list
, packed
, definition
, false,
3049 all_rep
, is_unchecked_union
, debug_info_p
,
3050 false, OK_To_Reorder_Components (gnat_entity
),
3053 /* If it is passed by reference, force BLKmode to ensure that objects
3054 of this type will always be put in memory. */
3055 if (Is_By_Reference_Type (gnat_entity
))
3056 SET_TYPE_MODE (gnu_type
, BLKmode
);
3058 /* We used to remove the associations of the discriminants and _Parent
3059 for validity checking but we may need them if there's a Freeze_Node
3060 for a subtype used in this record. */
3061 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
3063 /* Fill in locations of fields. */
3064 annotate_rep (gnat_entity
, gnu_type
);
3066 /* If there are any entities in the chain corresponding to components
3067 that we did not elaborate, ensure we elaborate their types if they
3069 for (gnat_temp
= First_Entity (gnat_entity
);
3070 Present (gnat_temp
);
3071 gnat_temp
= Next_Entity (gnat_temp
))
3072 if ((Ekind (gnat_temp
) == E_Component
3073 || Ekind (gnat_temp
) == E_Discriminant
)
3074 && Is_Itype (Etype (gnat_temp
))
3075 && !present_gnu_tree (gnat_temp
))
3076 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
3078 /* If this is a record type associated with an exception definition,
3079 equate its fields to those of the standard exception type. This
3080 will make it possible to convert between them. */
3081 if (gnu_entity_name
== exception_data_name_id
)
3084 for (gnu_field
= TYPE_FIELDS (gnu_type
),
3085 gnu_std_field
= TYPE_FIELDS (except_type_node
);
3087 gnu_field
= DECL_CHAIN (gnu_field
),
3088 gnu_std_field
= DECL_CHAIN (gnu_std_field
))
3089 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field
, gnu_std_field
);
3090 gcc_assert (!gnu_std_field
);
3095 case E_Class_Wide_Subtype
:
3096 /* If an equivalent type is present, that is what we should use.
3097 Otherwise, fall through to handle this like a record subtype
3098 since it may have constraints. */
3099 if (gnat_equiv_type
!= gnat_entity
)
3101 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
3102 maybe_present
= true;
3106 /* ... fall through ... */
3108 case E_Record_Subtype
:
3109 /* If Cloned_Subtype is Present it means this record subtype has
3110 identical layout to that type or subtype and we should use
3111 that GCC type for this one. The front end guarantees that
3112 the component list is shared. */
3113 if (Present (Cloned_Subtype (gnat_entity
)))
3115 gnu_decl
= gnat_to_gnu_entity (Cloned_Subtype (gnat_entity
),
3117 maybe_present
= true;
3121 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3122 changing the type, make a new type with each field having the type of
3123 the field in the new subtype but the position computed by transforming
3124 every discriminant reference according to the constraints. We don't
3125 see any difference between private and non-private type here since
3126 derivations from types should have been deferred until the completion
3127 of the private type. */
3130 Entity_Id gnat_base_type
= Implementation_Base_Type (gnat_entity
);
3135 defer_incomplete_level
++;
3136 this_deferred
= true;
3139 gnu_base_type
= gnat_to_gnu_type (gnat_base_type
);
3141 if (present_gnu_tree (gnat_entity
))
3143 maybe_present
= true;
3147 /* If this is a record subtype associated with a dispatch table,
3148 strip the suffix. This is necessary to make sure 2 different
3149 subtypes associated with the imported and exported views of a
3150 dispatch table are properly merged in LTO mode. */
3151 if (Is_Dispatch_Table_Entity (gnat_entity
))
3154 Get_Encoded_Name (gnat_entity
);
3155 p
= strchr (Name_Buffer
, '_');
3157 strcpy (p
+2, "dtS");
3158 gnu_entity_name
= get_identifier (Name_Buffer
);
3161 /* When the subtype has discriminants and these discriminants affect
3162 the initial shape it has inherited, factor them in. But for an
3163 Unchecked_Union (it must be an Itype), just return the type.
3164 We can't just test Is_Constrained because private subtypes without
3165 discriminants of types with discriminants with default expressions
3166 are Is_Constrained but aren't constrained! */
3167 if (IN (Ekind (gnat_base_type
), Record_Kind
)
3168 && !Is_Unchecked_Union (gnat_base_type
)
3169 && !Is_For_Access_Subtype (gnat_entity
)
3170 && Is_Constrained (gnat_entity
)
3171 && Has_Discriminants (gnat_entity
)
3172 && Present (Discriminant_Constraint (gnat_entity
))
3173 && Stored_Constraint (gnat_entity
) != No_Elist
)
3175 VEC(subst_pair
,heap
) *gnu_subst_list
3176 = build_subst_list (gnat_entity
, gnat_base_type
, definition
);
3177 tree gnu_unpad_base_type
, gnu_rep_part
, gnu_variant_part
, t
;
3178 tree gnu_pos_list
, gnu_field_list
= NULL_TREE
;
3179 bool selected_variant
= false;
3180 Entity_Id gnat_field
;
3181 VEC(variant_desc
,heap
) *gnu_variant_list
;
3183 gnu_type
= make_node (RECORD_TYPE
);
3184 TYPE_NAME (gnu_type
) = gnu_entity_name
;
3186 /* Set the size, alignment and alias set of the new type to
3187 match that of the old one, doing required substitutions. */
3188 copy_and_substitute_in_size (gnu_type
, gnu_base_type
,
3191 if (TYPE_IS_PADDING_P (gnu_base_type
))
3192 gnu_unpad_base_type
= TREE_TYPE (TYPE_FIELDS (gnu_base_type
));
3194 gnu_unpad_base_type
= gnu_base_type
;
3196 /* Look for a REP part in the base type. */
3197 gnu_rep_part
= get_rep_part (gnu_unpad_base_type
);
3199 /* Look for a variant part in the base type. */
3200 gnu_variant_part
= get_variant_part (gnu_unpad_base_type
);
3202 /* If there is a variant part, we must compute whether the
3203 constraints statically select a particular variant. If
3204 so, we simply drop the qualified union and flatten the
3205 list of fields. Otherwise we'll build a new qualified
3206 union for the variants that are still relevant. */
3207 if (gnu_variant_part
)
3213 = build_variant_list (TREE_TYPE (gnu_variant_part
),
3214 gnu_subst_list
, NULL
);
3216 /* If all the qualifiers are unconditionally true, the
3217 innermost variant is statically selected. */
3218 selected_variant
= true;
3219 FOR_EACH_VEC_ELT_REVERSE (variant_desc
, gnu_variant_list
,
3221 if (!integer_onep (v
->qual
))
3223 selected_variant
= false;
3227 /* Otherwise, create the new variants. */
3228 if (!selected_variant
)
3229 FOR_EACH_VEC_ELT_REVERSE (variant_desc
, gnu_variant_list
,
3232 tree old_variant
= v
->type
;
3233 tree new_variant
= make_node (RECORD_TYPE
);
3234 TYPE_NAME (new_variant
)
3235 = DECL_NAME (TYPE_NAME (old_variant
));
3236 copy_and_substitute_in_size (new_variant
, old_variant
,
3238 v
->record
= new_variant
;
3243 gnu_variant_list
= NULL
;
3244 selected_variant
= false;
3248 = build_position_list (gnu_unpad_base_type
,
3249 gnu_variant_list
&& !selected_variant
,
3250 size_zero_node
, bitsize_zero_node
,
3251 BIGGEST_ALIGNMENT
, NULL_TREE
);
3253 for (gnat_field
= First_Entity (gnat_entity
);
3254 Present (gnat_field
);
3255 gnat_field
= Next_Entity (gnat_field
))
3256 if ((Ekind (gnat_field
) == E_Component
3257 || Ekind (gnat_field
) == E_Discriminant
)
3258 && !(Present (Corresponding_Discriminant (gnat_field
))
3259 && Is_Tagged_Type (gnat_base_type
))
3260 && Underlying_Type (Scope (Original_Record_Component
3264 Name_Id gnat_name
= Chars (gnat_field
);
3265 Entity_Id gnat_old_field
3266 = Original_Record_Component (gnat_field
);
3268 = gnat_to_gnu_field_decl (gnat_old_field
);
3269 tree gnu_context
= DECL_CONTEXT (gnu_old_field
);
3270 tree gnu_field
, gnu_field_type
, gnu_size
;
3271 tree gnu_cont_type
, gnu_last
= NULL_TREE
;
3273 /* If the type is the same, retrieve the GCC type from the
3274 old field to take into account possible adjustments. */
3275 if (Etype (gnat_field
) == Etype (gnat_old_field
))
3276 gnu_field_type
= TREE_TYPE (gnu_old_field
);
3278 gnu_field_type
= gnat_to_gnu_type (Etype (gnat_field
));
3280 /* If there was a component clause, the field types must be
3281 the same for the type and subtype, so copy the data from
3282 the old field to avoid recomputation here. Also if the
3283 field is justified modular and the optimization in
3284 gnat_to_gnu_field was applied. */
3285 if (Present (Component_Clause (gnat_old_field
))
3286 || (TREE_CODE (gnu_field_type
) == RECORD_TYPE
3287 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
3288 && TREE_TYPE (TYPE_FIELDS (gnu_field_type
))
3289 == TREE_TYPE (gnu_old_field
)))
3291 gnu_size
= DECL_SIZE (gnu_old_field
);
3292 gnu_field_type
= TREE_TYPE (gnu_old_field
);
3295 /* If the old field was packed and of constant size, we
3296 have to get the old size here, as it might differ from
3297 what the Etype conveys and the latter might overlap
3298 onto the following field. Try to arrange the type for
3299 possible better packing along the way. */
3300 else if (DECL_PACKED (gnu_old_field
)
3301 && TREE_CODE (DECL_SIZE (gnu_old_field
))
3304 gnu_size
= DECL_SIZE (gnu_old_field
);
3305 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
3306 && !TYPE_FAT_POINTER_P (gnu_field_type
)
3307 && host_integerp (TYPE_SIZE (gnu_field_type
), 1))
3309 = make_packable_type (gnu_field_type
, true);
3313 gnu_size
= TYPE_SIZE (gnu_field_type
);
3315 /* If the context of the old field is the base type or its
3316 REP part (if any), put the field directly in the new
3317 type; otherwise look up the context in the variant list
3318 and put the field either in the new type if there is a
3319 selected variant or in one of the new variants. */
3320 if (gnu_context
== gnu_unpad_base_type
3322 && gnu_context
== TREE_TYPE (gnu_rep_part
)))
3323 gnu_cont_type
= gnu_type
;
3330 FOR_EACH_VEC_ELT_REVERSE (variant_desc
,
3331 gnu_variant_list
, ix
, v
)
3332 if (v
->type
== gnu_context
)
3339 if (selected_variant
)
3340 gnu_cont_type
= gnu_type
;
3342 gnu_cont_type
= v
->record
;
3345 /* The front-end may pass us "ghost" components if
3346 it fails to recognize that a constrained subtype
3347 is statically constrained. Discard them. */
3351 /* Now create the new field modeled on the old one. */
3353 = create_field_decl_from (gnu_old_field
, gnu_field_type
,
3354 gnu_cont_type
, gnu_size
,
3355 gnu_pos_list
, gnu_subst_list
);
3357 /* Put it in one of the new variants directly. */
3358 if (gnu_cont_type
!= gnu_type
)
3360 DECL_CHAIN (gnu_field
) = TYPE_FIELDS (gnu_cont_type
);
3361 TYPE_FIELDS (gnu_cont_type
) = gnu_field
;
3364 /* To match the layout crafted in components_to_record,
3365 if this is the _Tag or _Parent field, put it before
3366 any other fields. */
3367 else if (gnat_name
== Name_uTag
3368 || gnat_name
== Name_uParent
)
3369 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
3371 /* Similarly, if this is the _Controller field, put
3372 it before the other fields except for the _Tag or
3374 else if (gnat_name
== Name_uController
&& gnu_last
)
3376 DECL_CHAIN (gnu_field
) = DECL_CHAIN (gnu_last
);
3377 DECL_CHAIN (gnu_last
) = gnu_field
;
3380 /* Otherwise, if this is a regular field, put it after
3381 the other fields. */
3384 DECL_CHAIN (gnu_field
) = gnu_field_list
;
3385 gnu_field_list
= gnu_field
;
3387 gnu_last
= gnu_field
;
3390 save_gnu_tree (gnat_field
, gnu_field
, false);
3393 /* If there is a variant list and no selected variant, we need
3394 to create the nest of variant parts from the old nest. */
3395 if (gnu_variant_list
&& !selected_variant
)
3397 tree new_variant_part
3398 = create_variant_part_from (gnu_variant_part
,
3399 gnu_variant_list
, gnu_type
,
3400 gnu_pos_list
, gnu_subst_list
);
3401 DECL_CHAIN (new_variant_part
) = gnu_field_list
;
3402 gnu_field_list
= new_variant_part
;
3405 /* Now go through the entities again looking for Itypes that
3406 we have not elaborated but should (e.g., Etypes of fields
3407 that have Original_Components). */
3408 for (gnat_field
= First_Entity (gnat_entity
);
3409 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
3410 if ((Ekind (gnat_field
) == E_Discriminant
3411 || Ekind (gnat_field
) == E_Component
)
3412 && !present_gnu_tree (Etype (gnat_field
)))
3413 gnat_to_gnu_entity (Etype (gnat_field
), NULL_TREE
, 0);
3415 /* Do not emit debug info for the type yet since we're going to
3417 gnu_field_list
= nreverse (gnu_field_list
);
3418 finish_record_type (gnu_type
, gnu_field_list
, 2, false);
3420 /* See the E_Record_Type case for the rationale. */
3421 if (Is_By_Reference_Type (gnat_entity
))
3422 SET_TYPE_MODE (gnu_type
, BLKmode
);
3424 compute_record_mode (gnu_type
);
3426 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
3428 /* Fill in locations of fields. */
3429 annotate_rep (gnat_entity
, gnu_type
);
3431 /* If debugging information is being written for the type, write
3432 a record that shows what we are a subtype of and also make a
3433 variable that indicates our size, if still variable. */
3436 tree gnu_subtype_marker
= make_node (RECORD_TYPE
);
3437 tree gnu_unpad_base_name
= TYPE_NAME (gnu_unpad_base_type
);
3438 tree gnu_size_unit
= TYPE_SIZE_UNIT (gnu_type
);
3440 if (TREE_CODE (gnu_unpad_base_name
) == TYPE_DECL
)
3441 gnu_unpad_base_name
= DECL_NAME (gnu_unpad_base_name
);
3443 TYPE_NAME (gnu_subtype_marker
)
3444 = create_concat_name (gnat_entity
, "XVS");
3445 finish_record_type (gnu_subtype_marker
,
3446 create_field_decl (gnu_unpad_base_name
,
3447 build_reference_type
3448 (gnu_unpad_base_type
),
3450 NULL_TREE
, NULL_TREE
,
3454 add_parallel_type (TYPE_STUB_DECL (gnu_type
),
3455 gnu_subtype_marker
);
3458 && TREE_CODE (gnu_size_unit
) != INTEGER_CST
3459 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit
))
3460 TYPE_SIZE_UNIT (gnu_subtype_marker
)
3461 = create_var_decl (create_concat_name (gnat_entity
,
3463 NULL_TREE
, sizetype
, gnu_size_unit
,
3464 false, false, false, false, NULL
,
3468 VEC_free (variant_desc
, heap
, gnu_variant_list
);
3469 VEC_free (subst_pair
, heap
, gnu_subst_list
);
3471 /* Now we can finalize it. */
3472 rest_of_record_type_compilation (gnu_type
);
3475 /* Otherwise, go down all the components in the new type and make
3476 them equivalent to those in the base type. */
3479 gnu_type
= gnu_base_type
;
3481 for (gnat_temp
= First_Entity (gnat_entity
);
3482 Present (gnat_temp
);
3483 gnat_temp
= Next_Entity (gnat_temp
))
3484 if ((Ekind (gnat_temp
) == E_Discriminant
3485 && !Is_Unchecked_Union (gnat_base_type
))
3486 || Ekind (gnat_temp
) == E_Component
)
3487 save_gnu_tree (gnat_temp
,
3488 gnat_to_gnu_field_decl
3489 (Original_Record_Component (gnat_temp
)),
3495 case E_Access_Subprogram_Type
:
3496 /* Use the special descriptor type for dispatch tables if needed,
3497 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3498 Note that we are only required to do so for static tables in
3499 order to be compatible with the C++ ABI, but Ada 2005 allows
3500 to extend library level tagged types at the local level so
3501 we do it in the non-static case as well. */
3502 if (TARGET_VTABLE_USES_DESCRIPTORS
3503 && Is_Dispatch_Table_Entity (gnat_entity
))
3505 gnu_type
= fdesc_type_node
;
3506 gnu_size
= TYPE_SIZE (gnu_type
);
3510 /* ... fall through ... */
3512 case E_Anonymous_Access_Subprogram_Type
:
3513 /* If we are not defining this entity, and we have incomplete
3514 entities being processed above us, make a dummy type and
3515 fill it in later. */
3516 if (!definition
&& defer_incomplete_level
!= 0)
3518 struct incomplete
*p
= XNEW (struct incomplete
);
3521 = build_pointer_type
3522 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
3523 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
3524 !Comes_From_Source (gnat_entity
),
3525 debug_info_p
, gnat_entity
);
3526 this_made_decl
= true;
3527 gnu_type
= TREE_TYPE (gnu_decl
);
3528 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3531 p
->old_type
= TREE_TYPE (gnu_type
);
3532 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3533 p
->next
= defer_incomplete_list
;
3534 defer_incomplete_list
= p
;
3538 /* ... fall through ... */
3540 case E_Allocator_Type
:
3542 case E_Access_Attribute_Type
:
3543 case E_Anonymous_Access_Type
:
3544 case E_General_Access_Type
:
3546 /* The designated type and its equivalent type for gigi. */
3547 Entity_Id gnat_desig_type
= Directly_Designated_Type (gnat_entity
);
3548 Entity_Id gnat_desig_equiv
= Gigi_Equivalent_Type (gnat_desig_type
);
3549 /* Whether it comes from a limited with. */
3550 bool is_from_limited_with
3551 = (IN (Ekind (gnat_desig_equiv
), Incomplete_Kind
)
3552 && From_With_Type (gnat_desig_equiv
));
3553 /* The "full view" of the designated type. If this is an incomplete
3554 entity from a limited with, treat its non-limited view as the full
3555 view. Otherwise, if this is an incomplete or private type, use the
3556 full view. In the former case, we might point to a private type,
3557 in which case, we need its full view. Also, we want to look at the
3558 actual type used for the representation, so this takes a total of
3560 Entity_Id gnat_desig_full_direct_first
3561 = (is_from_limited_with
3562 ? Non_Limited_View (gnat_desig_equiv
)
3563 : (IN (Ekind (gnat_desig_equiv
), Incomplete_Or_Private_Kind
)
3564 ? Full_View (gnat_desig_equiv
) : Empty
));
3565 Entity_Id gnat_desig_full_direct
3566 = ((is_from_limited_with
3567 && Present (gnat_desig_full_direct_first
)
3568 && IN (Ekind (gnat_desig_full_direct_first
), Private_Kind
))
3569 ? Full_View (gnat_desig_full_direct_first
)
3570 : gnat_desig_full_direct_first
);
3571 Entity_Id gnat_desig_full
3572 = Gigi_Equivalent_Type (gnat_desig_full_direct
);
3573 /* The type actually used to represent the designated type, either
3574 gnat_desig_full or gnat_desig_equiv. */
3575 Entity_Id gnat_desig_rep
;
3576 /* True if this is a pointer to an unconstrained array. */
3577 bool is_unconstrained_array
;
3578 /* We want to know if we'll be seeing the freeze node for any
3579 incomplete type we may be pointing to. */
3581 = (Present (gnat_desig_full
)
3582 ? In_Extended_Main_Code_Unit (gnat_desig_full
)
3583 : In_Extended_Main_Code_Unit (gnat_desig_type
));
3584 /* True if we make a dummy type here. */
3585 bool made_dummy
= false;
3586 /* The mode to be used for the pointer type. */
3587 enum machine_mode p_mode
= mode_for_size (esize
, MODE_INT
, 0);
3588 /* The GCC type used for the designated type. */
3589 tree gnu_desig_type
= NULL_TREE
;
3591 if (!targetm
.valid_pointer_mode (p_mode
))
3594 /* If either the designated type or its full view is an unconstrained
3595 array subtype, replace it with the type it's a subtype of. This
3596 avoids problems with multiple copies of unconstrained array types.
3597 Likewise, if the designated type is a subtype of an incomplete
3598 record type, use the parent type to avoid order of elaboration
3599 issues. This can lose some code efficiency, but there is no
3601 if (Ekind (gnat_desig_equiv
) == E_Array_Subtype
3602 && !Is_Constrained (gnat_desig_equiv
))
3603 gnat_desig_equiv
= Etype (gnat_desig_equiv
);
3604 if (Present (gnat_desig_full
)
3605 && ((Ekind (gnat_desig_full
) == E_Array_Subtype
3606 && !Is_Constrained (gnat_desig_full
))
3607 || (Ekind (gnat_desig_full
) == E_Record_Subtype
3608 && Ekind (Etype (gnat_desig_full
)) == E_Record_Type
)))
3609 gnat_desig_full
= Etype (gnat_desig_full
);
3611 /* Set the type that's actually the representation of the designated
3612 type and also flag whether we have a unconstrained array. */
3614 = Present (gnat_desig_full
) ? gnat_desig_full
: gnat_desig_equiv
;
3615 is_unconstrained_array
3616 = Is_Array_Type (gnat_desig_rep
) && !Is_Constrained (gnat_desig_rep
);
3618 /* If we are pointing to an incomplete type whose completion is an
3619 unconstrained array, make dummy fat and thin pointer types to it.
3620 Likewise if the type itself is dummy or an unconstrained array. */
3621 if (is_unconstrained_array
3622 && (Present (gnat_desig_full
)
3623 || (present_gnu_tree (gnat_desig_equiv
)
3625 (TREE_TYPE (get_gnu_tree (gnat_desig_equiv
))))
3627 && defer_incomplete_level
!= 0
3628 && !present_gnu_tree (gnat_desig_equiv
))
3630 && is_from_limited_with
3631 && Present (Freeze_Node (gnat_desig_equiv
)))))
3633 if (present_gnu_tree (gnat_desig_rep
))
3634 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_rep
));
3637 gnu_desig_type
= make_dummy_type (gnat_desig_rep
);
3641 /* If the call above got something that has a pointer, the pointer
3642 is our type. This could have happened either because the type
3643 was elaborated or because somebody else executed the code. */
3644 if (!TYPE_POINTER_TO (gnu_desig_type
))
3645 build_dummy_unc_pointer_types (gnat_desig_equiv
, gnu_desig_type
);
3646 gnu_type
= TYPE_POINTER_TO (gnu_desig_type
);
3649 /* If we already know what the full type is, use it. */
3650 else if (Present (gnat_desig_full
)
3651 && present_gnu_tree (gnat_desig_full
))
3652 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_full
));
3654 /* Get the type of the thing we are to point to and build a pointer to
3655 it. If it is a reference to an incomplete or private type with a
3656 full view that is a record, make a dummy type node and get the
3657 actual type later when we have verified it is safe. */
3658 else if ((!in_main_unit
3659 && !present_gnu_tree (gnat_desig_equiv
)
3660 && Present (gnat_desig_full
)
3661 && !present_gnu_tree (gnat_desig_full
)
3662 && Is_Record_Type (gnat_desig_full
))
3663 /* Likewise if we are pointing to a record or array and we are
3664 to defer elaborating incomplete types. We do this as this
3665 access type may be the full view of a private type. Note
3666 that the unconstrained array case is handled above. */
3667 || ((!in_main_unit
|| imported_p
)
3668 && defer_incomplete_level
!= 0
3669 && !present_gnu_tree (gnat_desig_equiv
)
3670 && (Is_Record_Type (gnat_desig_rep
)
3671 || Is_Array_Type (gnat_desig_rep
)))
3672 /* If this is a reference from a limited_with type back to our
3673 main unit and there's a freeze node for it, either we have
3674 already processed the declaration and made the dummy type,
3675 in which case we just reuse the latter, or we have not yet,
3676 in which case we make the dummy type and it will be reused
3677 when the declaration is finally processed. In both cases,
3678 the pointer eventually created below will be automatically
3679 adjusted when the freeze node is processed. Note that the
3680 unconstrained array case is handled above. */
3682 && is_from_limited_with
3683 && Present (Freeze_Node (gnat_desig_rep
))))
3685 gnu_desig_type
= make_dummy_type (gnat_desig_equiv
);
3689 /* Otherwise handle the case of a pointer to itself. */
3690 else if (gnat_desig_equiv
== gnat_entity
)
3693 = build_pointer_type_for_mode (void_type_node
, p_mode
,
3694 No_Strict_Aliasing (gnat_entity
));
3695 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
) = gnu_type
;
3698 /* If expansion is disabled, the equivalent type of a concurrent type
3699 is absent, so build a dummy pointer type. */
3700 else if (type_annotate_only
&& No (gnat_desig_equiv
))
3701 gnu_type
= ptr_void_type_node
;
3703 /* Finally, handle the default case where we can just elaborate our
3706 gnu_desig_type
= gnat_to_gnu_type (gnat_desig_equiv
);
3708 /* It is possible that a call to gnat_to_gnu_type above resolved our
3709 type. If so, just return it. */
3710 if (present_gnu_tree (gnat_entity
))
3712 maybe_present
= true;
3716 /* If we have not done it yet, build the pointer type the usual way. */
3719 /* Modify the designated type if we are pointing only to constant
3720 objects, but don't do it for unconstrained arrays. */
3721 if (Is_Access_Constant (gnat_entity
)
3722 && TREE_CODE (gnu_desig_type
) != UNCONSTRAINED_ARRAY_TYPE
)
3725 = build_qualified_type
3727 TYPE_QUALS (gnu_desig_type
) | TYPE_QUAL_CONST
);
3729 /* Some extra processing is required if we are building a
3730 pointer to an incomplete type (in the GCC sense). We might
3731 have such a type if we just made a dummy, or directly out
3732 of the call to gnat_to_gnu_type above if we are processing
3733 an access type for a record component designating the
3734 record type itself. */
3735 if (TYPE_MODE (gnu_desig_type
) == VOIDmode
)
3737 /* We must ensure that the pointer to variant we make will
3738 be processed by update_pointer_to when the initial type
3739 is completed. Pretend we made a dummy and let further
3740 processing act as usual. */
3743 /* We must ensure that update_pointer_to will not retrieve
3744 the dummy variant when building a properly qualified
3745 version of the complete type. We take advantage of the
3746 fact that get_qualified_type is requiring TYPE_NAMEs to
3747 match to influence build_qualified_type and then also
3748 update_pointer_to here. */
3749 TYPE_NAME (gnu_desig_type
)
3750 = create_concat_name (gnat_desig_type
, "INCOMPLETE_CST");
3755 = build_pointer_type_for_mode (gnu_desig_type
, p_mode
,
3756 No_Strict_Aliasing (gnat_entity
));
3759 /* If we are not defining this object and we have made a dummy pointer,
3760 save our current definition, evaluate the actual type, and replace
3761 the tentative type we made with the actual one. If we are to defer
3762 actually looking up the actual type, make an entry in the deferred
3763 list. If this is from a limited with, we may have to defer to the
3764 end of the current unit. */
3765 if ((!in_main_unit
|| is_from_limited_with
) && made_dummy
)
3767 tree gnu_old_desig_type
;
3769 if (TYPE_IS_FAT_POINTER_P (gnu_type
))
3771 gnu_old_desig_type
= TYPE_UNCONSTRAINED_ARRAY (gnu_type
);
3772 if (esize
== POINTER_SIZE
)
3773 gnu_type
= build_pointer_type
3774 (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type
));
3777 gnu_old_desig_type
= TREE_TYPE (gnu_type
);
3779 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
3780 !Comes_From_Source (gnat_entity
),
3781 debug_info_p
, gnat_entity
);
3782 this_made_decl
= true;
3783 gnu_type
= TREE_TYPE (gnu_decl
);
3784 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3787 /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
3788 update gnu_old_desig_type directly, in which case it will not be
3789 a dummy type any more when we get into update_pointer_to.
3791 This can happen e.g. when the designated type is a record type,
3792 because their elaboration starts with an initial node from
3793 make_dummy_type, which may be the same node as the one we got.
3795 Besides, variants of this non-dummy type might have been created
3796 along the way. update_pointer_to is expected to properly take
3797 care of those situations. */
3798 if (defer_incomplete_level
== 0 && !is_from_limited_with
)
3800 defer_finalize_level
++;
3801 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type
),
3802 gnat_to_gnu_type (gnat_desig_equiv
));
3803 defer_finalize_level
--;
3807 struct incomplete
*p
= XNEW (struct incomplete
);
3808 struct incomplete
**head
3809 = (is_from_limited_with
3810 ? &defer_limited_with
: &defer_incomplete_list
);
3811 p
->old_type
= gnu_old_desig_type
;
3812 p
->full_type
= gnat_desig_equiv
;
3820 case E_Access_Protected_Subprogram_Type
:
3821 case E_Anonymous_Access_Protected_Subprogram_Type
:
3822 if (type_annotate_only
&& No (gnat_equiv_type
))
3823 gnu_type
= ptr_void_type_node
;
3826 /* The run-time representation is the equivalent type. */
3827 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
3828 maybe_present
= true;
3831 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3832 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3833 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
)))
3834 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity
))))
3835 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3840 case E_Access_Subtype
:
3842 /* We treat this as identical to its base type; any constraint is
3843 meaningful only to the front-end.
3845 The designated type must be elaborated as well, if it does
3846 not have its own freeze node. Designated (sub)types created
3847 for constrained components of records with discriminants are
3848 not frozen by the front-end and thus not elaborated by gigi,
3849 because their use may appear before the base type is frozen,
3850 and because it is not clear that they are needed anywhere in
3851 gigi. With the current model, there is no correct place where
3852 they could be elaborated. */
3854 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3855 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3856 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3857 && Is_Frozen (Directly_Designated_Type (gnat_entity
))
3858 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
))))
3860 /* If we are not defining this entity, and we have incomplete
3861 entities being processed above us, make a dummy type and
3862 elaborate it later. */
3863 if (!definition
&& defer_incomplete_level
!= 0)
3865 struct incomplete
*p
= XNEW (struct incomplete
);
3868 = make_dummy_type (Directly_Designated_Type (gnat_entity
));
3869 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3870 p
->next
= defer_incomplete_list
;
3871 defer_incomplete_list
= p
;
3873 else if (!IN (Ekind (Base_Type
3874 (Directly_Designated_Type (gnat_entity
))),
3875 Incomplete_Or_Private_Kind
))
3876 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3880 maybe_present
= true;
3883 /* Subprogram Entities
3885 The following access functions are defined for subprograms:
3887 Etype Return type or Standard_Void_Type.
3888 First_Formal The first formal parameter.
3889 Is_Imported Indicates that the subprogram has appeared in
3890 an INTERFACE or IMPORT pragma. For now we
3891 assume that the external language is C.
3892 Is_Exported Likewise but for an EXPORT pragma.
3893 Is_Inlined True if the subprogram is to be inlined.
3895 Each parameter is first checked by calling must_pass_by_ref on its
3896 type to determine if it is passed by reference. For parameters which
3897 are copied in, if they are Ada In Out or Out parameters, their return
3898 value becomes part of a record which becomes the return type of the
3899 function (C function - note that this applies only to Ada procedures
3900 so there is no Ada return type). Additional code to store back the
3901 parameters will be generated on the caller side. This transformation
3902 is done here, not in the front-end.
3904 The intended result of the transformation can be seen from the
3905 equivalent source rewritings that follow:
3907 struct temp {int a,b};
3908 procedure P (A,B: In Out ...) is temp P (int A,B)
3911 end P; return {A,B};
3918 For subprogram types we need to perform mainly the same conversions to
3919 GCC form that are needed for procedures and function declarations. The
3920 only difference is that at the end, we make a type declaration instead
3921 of a function declaration. */
3923 case E_Subprogram_Type
:
3927 /* The type returned by a function or else Standard_Void_Type for a
3929 Entity_Id gnat_return_type
= Etype (gnat_entity
);
3930 tree gnu_return_type
;
3931 /* The first GCC parameter declaration (a PARM_DECL node). The
3932 PARM_DECL nodes are chained through the DECL_CHAIN field, so this
3933 actually is the head of this parameter list. */
3934 tree gnu_param_list
= NULL_TREE
;
3935 /* Likewise for the stub associated with an exported procedure. */
3936 tree gnu_stub_param_list
= NULL_TREE
;
3937 /* Non-null for subprograms containing parameters passed by copy-in
3938 copy-out (Ada In Out or Out parameters not passed by reference),
3939 in which case it is the list of nodes used to specify the values
3940 of the In Out/Out parameters that are returned as a record upon
3941 procedure return. The TREE_PURPOSE of an element of this list is
3942 a field of the record and the TREE_VALUE is the PARM_DECL
3943 corresponding to that field. This list will be saved in the
3944 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3945 tree gnu_cico_list
= NULL_TREE
;
3946 /* List of fields in return type of procedure with copy-in copy-out
3948 tree gnu_field_list
= NULL_TREE
;
3949 /* If an import pragma asks to map this subprogram to a GCC builtin,
3950 this is the builtin DECL node. */
3951 tree gnu_builtin_decl
= NULL_TREE
;
3952 /* For the stub associated with an exported procedure. */
3953 tree gnu_stub_type
= NULL_TREE
, gnu_stub_name
= NULL_TREE
;
3954 tree gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
3955 Entity_Id gnat_param
;
3956 bool inline_flag
= Is_Inlined (gnat_entity
);
3957 bool public_flag
= Is_Public (gnat_entity
) || imported_p
;
3959 = (Is_Public (gnat_entity
) && !definition
) || imported_p
;
3960 bool artificial_flag
= !Comes_From_Source (gnat_entity
);
3961 /* The semantics of "pure" in Ada essentially matches that of "const"
3962 in the back-end. In particular, both properties are orthogonal to
3963 the "nothrow" property if the EH circuitry is explicit in the
3964 internal representation of the back-end. If we are to completely
3965 hide the EH circuitry from it, we need to declare that calls to pure
3966 Ada subprograms that can throw have side effects since they can
3967 trigger an "abnormal" transfer of control flow; thus they can be
3968 neither "const" nor "pure" in the back-end sense. */
3970 = (Exception_Mechanism
== Back_End_Exceptions
3971 && Is_Pure (gnat_entity
));
3972 bool volatile_flag
= No_Return (gnat_entity
);
3973 bool return_by_direct_ref_p
= false;
3974 bool return_by_invisi_ref_p
= false;
3975 bool return_unconstrained_p
= false;
3976 bool has_stub
= false;
3979 /* A parameter may refer to this type, so defer completion of any
3980 incomplete types. */
3981 if (kind
== E_Subprogram_Type
&& !definition
)
3983 defer_incomplete_level
++;
3984 this_deferred
= true;
3987 /* If the subprogram has an alias, it is probably inherited, so
3988 we can use the original one. If the original "subprogram"
3989 is actually an enumeration literal, it may be the first use
3990 of its type, so we must elaborate that type now. */
3991 if (Present (Alias (gnat_entity
)))
3993 if (Ekind (Alias (gnat_entity
)) == E_Enumeration_Literal
)
3994 gnat_to_gnu_entity (Etype (Alias (gnat_entity
)), NULL_TREE
, 0);
3996 gnu_decl
= gnat_to_gnu_entity (Alias (gnat_entity
), gnu_expr
, 0);
3998 /* Elaborate any Itypes in the parameters of this entity. */
3999 for (gnat_temp
= First_Formal_With_Extras (gnat_entity
);
4000 Present (gnat_temp
);
4001 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
4002 if (Is_Itype (Etype (gnat_temp
)))
4003 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
4008 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
4009 corresponding DECL node. Proper generation of calls later on need
4010 proper parameter associations so we don't "break;" here. */
4011 if (Convention (gnat_entity
) == Convention_Intrinsic
4012 && Present (Interface_Name (gnat_entity
)))
4014 gnu_builtin_decl
= builtin_decl_for (gnu_ext_name
);
4016 /* Inability to find the builtin decl most often indicates a
4017 genuine mistake, but imports of unregistered intrinsics are
4018 sometimes issued on purpose to allow hooking in alternate
4019 bodies. We post a warning conditioned on Wshadow in this case,
4020 to let developers be notified on demand without risking false
4021 positives with common default sets of options. */
4023 if (gnu_builtin_decl
== NULL_TREE
&& warn_shadow
)
4024 post_error ("?gcc intrinsic not found for&!", gnat_entity
);
4027 /* ??? What if we don't find the builtin node above ? warn ? err ?
4028 In the current state we neither warn nor err, and calls will just
4029 be handled as for regular subprograms. */
4031 /* Look into the return type and get its associated GCC tree. If it
4032 is not void, compute various flags for the subprogram type. */
4033 if (Ekind (gnat_return_type
) == E_Void
)
4034 gnu_return_type
= void_type_node
;
4037 gnu_return_type
= gnat_to_gnu_type (gnat_return_type
);
4039 /* If this function returns by reference, make the actual return
4040 type the pointer type and make a note of that. */
4041 if (Returns_By_Ref (gnat_entity
))
4043 gnu_return_type
= build_pointer_type (gnu_return_type
);
4044 return_by_direct_ref_p
= true;
4047 /* If we are supposed to return an unconstrained array type, make
4048 the actual return type the fat pointer type. */
4049 else if (TREE_CODE (gnu_return_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4051 gnu_return_type
= TREE_TYPE (gnu_return_type
);
4052 return_unconstrained_p
= true;
4055 /* Likewise, if the return type requires a transient scope, the
4056 return value will be allocated on the secondary stack so the
4057 actual return type is the pointer type. */
4058 else if (Requires_Transient_Scope (gnat_return_type
))
4060 gnu_return_type
= build_pointer_type (gnu_return_type
);
4061 return_unconstrained_p
= true;
4064 /* If the Mechanism is By_Reference, ensure this function uses the
4065 target's by-invisible-reference mechanism, which may not be the
4066 same as above (e.g. it might be passing an extra parameter). */
4067 else if (kind
== E_Function
4068 && Mechanism (gnat_entity
) == By_Reference
)
4069 return_by_invisi_ref_p
= true;
4071 /* Likewise, if the return type is itself By_Reference. */
4072 else if (TREE_ADDRESSABLE (gnu_return_type
))
4073 return_by_invisi_ref_p
= true;
4075 /* If the type is a padded type and the underlying type would not
4076 be passed by reference or the function has a foreign convention,
4077 return the underlying type. */
4078 else if (TYPE_IS_PADDING_P (gnu_return_type
)
4079 && (!default_pass_by_ref
4080 (TREE_TYPE (TYPE_FIELDS (gnu_return_type
)))
4081 || Has_Foreign_Convention (gnat_entity
)))
4082 gnu_return_type
= TREE_TYPE (TYPE_FIELDS (gnu_return_type
));
4084 /* If the return type is unconstrained, that means it must have a
4085 maximum size. Use the padded type as the effective return type.
4086 And ensure the function uses the target's by-invisible-reference
4087 mechanism to avoid copying too much data when it returns. */
4088 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type
)))
4091 = maybe_pad_type (gnu_return_type
,
4092 max_size (TYPE_SIZE (gnu_return_type
),
4094 0, gnat_entity
, false, false, false, true);
4096 /* Declare it now since it will never be declared otherwise.
4097 This is necessary to ensure that its subtrees are properly
4099 create_type_decl (TYPE_NAME (gnu_return_type
), gnu_return_type
,
4100 NULL
, true, debug_info_p
, gnat_entity
);
4102 return_by_invisi_ref_p
= true;
4105 /* If the return type has a size that overflows, we cannot have
4106 a function that returns that type. This usage doesn't make
4107 sense anyway, so give an error here. */
4108 if (TYPE_SIZE_UNIT (gnu_return_type
)
4109 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type
))
4110 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type
)))
4112 post_error ("cannot return type whose size overflows",
4114 gnu_return_type
= copy_node (gnu_return_type
);
4115 TYPE_SIZE (gnu_return_type
) = bitsize_zero_node
;
4116 TYPE_SIZE_UNIT (gnu_return_type
) = size_zero_node
;
4117 TYPE_MAIN_VARIANT (gnu_return_type
) = gnu_return_type
;
4118 TYPE_NEXT_VARIANT (gnu_return_type
) = NULL_TREE
;
4122 /* Loop over the parameters and get their associated GCC tree. While
4123 doing this, build a copy-in copy-out structure if we need one. */
4124 for (gnat_param
= First_Formal_With_Extras (gnat_entity
), parmnum
= 0;
4125 Present (gnat_param
);
4126 gnat_param
= Next_Formal_With_Extras (gnat_param
), parmnum
++)
4128 tree gnu_param_name
= get_entity_name (gnat_param
);
4129 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
4130 tree gnu_param
, gnu_field
;
4131 bool copy_in_copy_out
= false;
4132 Mechanism_Type mech
= Mechanism (gnat_param
);
4134 /* Builtins are expanded inline and there is no real call sequence
4135 involved. So the type expected by the underlying expander is
4136 always the type of each argument "as is". */
4137 if (gnu_builtin_decl
)
4139 /* Handle the first parameter of a valued procedure specially. */
4140 else if (Is_Valued_Procedure (gnat_entity
) && parmnum
== 0)
4141 mech
= By_Copy_Return
;
4142 /* Otherwise, see if a Mechanism was supplied that forced this
4143 parameter to be passed one way or another. */
4144 else if (mech
== Default
4145 || mech
== By_Copy
|| mech
== By_Reference
)
4147 else if (By_Descriptor_Last
<= mech
&& mech
<= By_Descriptor
)
4148 mech
= By_Descriptor
;
4150 else if (By_Short_Descriptor_Last
<= mech
&&
4151 mech
<= By_Short_Descriptor
)
4152 mech
= By_Short_Descriptor
;
4156 if (TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
4157 || TREE_CODE (TYPE_SIZE (gnu_param_type
)) != INTEGER_CST
4158 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type
),
4160 mech
= By_Reference
;
4166 post_error ("unsupported mechanism for&", gnat_param
);
4171 = gnat_to_gnu_param (gnat_param
, mech
, gnat_entity
,
4172 Has_Foreign_Convention (gnat_entity
),
4175 /* We are returned either a PARM_DECL or a type if no parameter
4176 needs to be passed; in either case, adjust the type. */
4177 if (DECL_P (gnu_param
))
4178 gnu_param_type
= TREE_TYPE (gnu_param
);
4181 gnu_param_type
= gnu_param
;
4182 gnu_param
= NULL_TREE
;
4185 /* The failure of this assertion will very likely come from an
4186 order of elaboration issue for the type of the parameter. */
4187 gcc_assert (kind
== E_Subprogram_Type
4188 || !TYPE_IS_DUMMY_P (gnu_param_type
));
4192 /* If it's an exported subprogram, we build a parameter list
4193 in parallel, in case we need to emit a stub for it. */
4194 if (Is_Exported (gnat_entity
))
4197 = chainon (gnu_param
, gnu_stub_param_list
);
4198 /* Change By_Descriptor parameter to By_Reference for
4199 the internal version of an exported subprogram. */
4200 if (mech
== By_Descriptor
|| mech
== By_Short_Descriptor
)
4203 = gnat_to_gnu_param (gnat_param
, By_Reference
,
4209 gnu_param
= copy_node (gnu_param
);
4212 gnu_param_list
= chainon (gnu_param
, gnu_param_list
);
4213 Sloc_to_locus (Sloc (gnat_param
),
4214 &DECL_SOURCE_LOCATION (gnu_param
));
4215 save_gnu_tree (gnat_param
, gnu_param
, false);
4217 /* If a parameter is a pointer, this function may modify
4218 memory through it and thus shouldn't be considered
4219 a const function. Also, the memory may be modified
4220 between two calls, so they can't be CSE'ed. The latter
4221 case also handles by-ref parameters. */
4222 if (POINTER_TYPE_P (gnu_param_type
)
4223 || TYPE_IS_FAT_POINTER_P (gnu_param_type
))
4227 if (copy_in_copy_out
)
4231 tree gnu_new_ret_type
= make_node (RECORD_TYPE
);
4233 /* If this is a function, we also need a field for the
4234 return value to be placed. */
4235 if (TREE_CODE (gnu_return_type
) != VOID_TYPE
)
4238 = create_field_decl (get_identifier ("RETVAL"),
4240 gnu_new_ret_type
, NULL_TREE
,
4242 Sloc_to_locus (Sloc (gnat_entity
),
4243 &DECL_SOURCE_LOCATION (gnu_field
));
4244 gnu_field_list
= gnu_field
;
4246 = tree_cons (gnu_field
, void_type_node
, NULL_TREE
);
4249 gnu_return_type
= gnu_new_ret_type
;
4250 TYPE_NAME (gnu_return_type
) = get_identifier ("RETURN");
4251 /* Set a default alignment to speed up accesses. */
4252 TYPE_ALIGN (gnu_return_type
)
4253 = get_mode_alignment (ptr_mode
);
4257 = create_field_decl (gnu_param_name
, gnu_param_type
,
4258 gnu_return_type
, NULL_TREE
, NULL_TREE
,
4260 /* Set a minimum alignment to speed up accesses. */
4261 if (DECL_ALIGN (gnu_field
) < TYPE_ALIGN (gnu_return_type
))
4262 DECL_ALIGN (gnu_field
) = TYPE_ALIGN (gnu_return_type
);
4263 Sloc_to_locus (Sloc (gnat_param
),
4264 &DECL_SOURCE_LOCATION (gnu_field
));
4265 DECL_CHAIN (gnu_field
) = gnu_field_list
;
4266 gnu_field_list
= gnu_field
;
4268 = tree_cons (gnu_field
, gnu_param
, gnu_cico_list
);
4274 /* If we have a CICO list but it has only one entry, we convert
4275 this function into a function that returns this object. */
4276 if (list_length (gnu_cico_list
) == 1)
4277 gnu_return_type
= TREE_TYPE (TREE_PURPOSE (gnu_cico_list
));
4279 /* Do not finalize the return type if the subprogram is stubbed
4280 since structures are incomplete for the back-end. */
4281 else if (Convention (gnat_entity
) != Convention_Stubbed
)
4283 finish_record_type (gnu_return_type
, nreverse (gnu_field_list
),
4286 /* Try to promote the mode of the return type if it is passed
4287 in registers, again to speed up accesses. */
4288 if (TYPE_MODE (gnu_return_type
) == BLKmode
4289 && !targetm
.calls
.return_in_memory (gnu_return_type
,
4293 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type
));
4294 unsigned int i
= BITS_PER_UNIT
;
4295 enum machine_mode mode
;
4299 mode
= mode_for_size (i
, MODE_INT
, 0);
4300 if (mode
!= BLKmode
)
4302 SET_TYPE_MODE (gnu_return_type
, mode
);
4303 TYPE_ALIGN (gnu_return_type
)
4304 = GET_MODE_ALIGNMENT (mode
);
4305 TYPE_SIZE (gnu_return_type
)
4306 = bitsize_int (GET_MODE_BITSIZE (mode
));
4307 TYPE_SIZE_UNIT (gnu_return_type
)
4308 = size_int (GET_MODE_SIZE (mode
));
4313 rest_of_record_type_compilation (gnu_return_type
);
4317 if (Has_Stdcall_Convention (gnat_entity
))
4318 prepend_one_attribute_to
4319 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4320 get_identifier ("stdcall"), NULL_TREE
,
4323 /* If we should request stack realignment for a foreign convention
4324 subprogram, do so. Note that this applies to task entry points in
4326 if (FOREIGN_FORCE_REALIGN_STACK
4327 && Has_Foreign_Convention (gnat_entity
))
4328 prepend_one_attribute_to
4329 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4330 get_identifier ("force_align_arg_pointer"), NULL_TREE
,
4333 /* The lists have been built in reverse. */
4334 gnu_param_list
= nreverse (gnu_param_list
);
4336 gnu_stub_param_list
= nreverse (gnu_stub_param_list
);
4337 gnu_cico_list
= nreverse (gnu_cico_list
);
4339 if (kind
== E_Function
)
4340 Set_Mechanism (gnat_entity
, return_unconstrained_p
4341 || return_by_direct_ref_p
4342 || return_by_invisi_ref_p
4343 ? By_Reference
: By_Copy
);
4345 = create_subprog_type (gnu_return_type
, gnu_param_list
,
4346 gnu_cico_list
, return_unconstrained_p
,
4347 return_by_direct_ref_p
,
4348 return_by_invisi_ref_p
);
4352 = create_subprog_type (gnu_return_type
, gnu_stub_param_list
,
4353 gnu_cico_list
, return_unconstrained_p
,
4354 return_by_direct_ref_p
,
4355 return_by_invisi_ref_p
);
4357 /* A subprogram (something that doesn't return anything) shouldn't
4358 be considered const since there would be no reason for such a
4359 subprogram. Note that procedures with Out (or In Out) parameters
4360 have already been converted into a function with a return type. */
4361 if (TREE_CODE (gnu_return_type
) == VOID_TYPE
)
4365 = build_qualified_type (gnu_type
,
4366 TYPE_QUALS (gnu_type
)
4367 | (TYPE_QUAL_CONST
* const_flag
)
4368 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
4372 = build_qualified_type (gnu_stub_type
,
4373 TYPE_QUALS (gnu_stub_type
)
4374 | (TYPE_QUAL_CONST
* const_flag
)
4375 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
4377 /* If we have a builtin decl for that function, use it. Check if the
4378 profiles are compatible and warn if they are not. The checker is
4379 expected to post extra diagnostics in this case. */
4380 if (gnu_builtin_decl
)
4382 intrin_binding_t inb
;
4384 inb
.gnat_entity
= gnat_entity
;
4385 inb
.ada_fntype
= gnu_type
;
4386 inb
.btin_fntype
= TREE_TYPE (gnu_builtin_decl
);
4388 if (!intrin_profiles_compatible_p (&inb
))
4390 ("?profile of& doesn''t match the builtin it binds!",
4393 gnu_decl
= gnu_builtin_decl
;
4394 gnu_type
= TREE_TYPE (gnu_builtin_decl
);
4398 /* If there was no specified Interface_Name and the external and
4399 internal names of the subprogram are the same, only use the
4400 internal name to allow disambiguation of nested subprograms. */
4401 if (No (Interface_Name (gnat_entity
))
4402 && gnu_ext_name
== gnu_entity_name
)
4403 gnu_ext_name
= NULL_TREE
;
4405 /* If we are defining the subprogram and it has an Address clause
4406 we must get the address expression from the saved GCC tree for the
4407 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4408 the address expression here since the front-end has guaranteed
4409 in that case that the elaboration has no effects. If there is
4410 an Address clause and we are not defining the object, just
4411 make it a constant. */
4412 if (Present (Address_Clause (gnat_entity
)))
4414 tree gnu_address
= NULL_TREE
;
4418 = (present_gnu_tree (gnat_entity
)
4419 ? get_gnu_tree (gnat_entity
)
4420 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
4422 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
4424 /* Convert the type of the object to a reference type that can
4425 alias everything as per 13.3(19). */
4427 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
4429 gnu_address
= convert (gnu_type
, gnu_address
);
4432 = create_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
4433 gnu_address
, false, Is_Public (gnat_entity
),
4434 extern_flag
, false, NULL
, gnat_entity
);
4435 DECL_BY_REF_P (gnu_decl
) = 1;
4438 else if (kind
== E_Subprogram_Type
)
4440 = create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
4441 artificial_flag
, debug_info_p
, gnat_entity
);
4446 gnu_stub_name
= gnu_ext_name
;
4447 gnu_ext_name
= create_concat_name (gnat_entity
, "internal");
4448 public_flag
= false;
4449 artificial_flag
= true;
4453 = create_subprog_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
4454 gnu_param_list
, inline_flag
, public_flag
,
4455 extern_flag
, artificial_flag
, attr_list
,
4460 = create_subprog_decl (gnu_entity_name
, gnu_stub_name
,
4461 gnu_stub_type
, gnu_stub_param_list
,
4462 inline_flag
, true, extern_flag
,
4463 false, attr_list
, gnat_entity
);
4464 SET_DECL_FUNCTION_STUB (gnu_decl
, gnu_stub_decl
);
4467 /* This is unrelated to the stub built right above. */
4468 DECL_STUBBED_P (gnu_decl
)
4469 = Convention (gnat_entity
) == Convention_Stubbed
;
4474 case E_Incomplete_Type
:
4475 case E_Incomplete_Subtype
:
4476 case E_Private_Type
:
4477 case E_Private_Subtype
:
4478 case E_Limited_Private_Type
:
4479 case E_Limited_Private_Subtype
:
4480 case E_Record_Type_With_Private
:
4481 case E_Record_Subtype_With_Private
:
4483 /* Get the "full view" of this entity. If this is an incomplete
4484 entity from a limited with, treat its non-limited view as the
4485 full view. Otherwise, use either the full view or the underlying
4486 full view, whichever is present. This is used in all the tests
4489 = (IN (kind
, Incomplete_Kind
) && From_With_Type (gnat_entity
))
4490 ? Non_Limited_View (gnat_entity
)
4491 : Present (Full_View (gnat_entity
))
4492 ? Full_View (gnat_entity
)
4493 : Underlying_Full_View (gnat_entity
);
4495 /* If this is an incomplete type with no full view, it must be a Taft
4496 Amendment type, in which case we return a dummy type. Otherwise,
4497 just get the type from its Etype. */
4500 if (kind
== E_Incomplete_Type
)
4502 gnu_type
= make_dummy_type (gnat_entity
);
4503 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4507 gnu_decl
= gnat_to_gnu_entity (Etype (gnat_entity
),
4509 maybe_present
= true;
4514 /* If we already made a type for the full view, reuse it. */
4515 else if (present_gnu_tree (full_view
))
4517 gnu_decl
= get_gnu_tree (full_view
);
4521 /* Otherwise, if we are not defining the type now, get the type
4522 from the full view. But always get the type from the full view
4523 for define on use types, since otherwise we won't see them! */
4524 else if (!definition
4525 || (Is_Itype (full_view
)
4526 && No (Freeze_Node (gnat_entity
)))
4527 || (Is_Itype (gnat_entity
)
4528 && No (Freeze_Node (full_view
))))
4530 gnu_decl
= gnat_to_gnu_entity (full_view
, NULL_TREE
, 0);
4531 maybe_present
= true;
4535 /* For incomplete types, make a dummy type entry which will be
4536 replaced later. Save it as the full declaration's type so
4537 we can do any needed updates when we see it. */
4538 gnu_type
= make_dummy_type (gnat_entity
);
4539 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4540 if (Has_Completion_In_Body (gnat_entity
))
4541 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
4542 save_gnu_tree (full_view
, gnu_decl
, 0);
4546 case E_Class_Wide_Type
:
4547 /* Class-wide types are always transformed into their root type. */
4548 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
4549 maybe_present
= true;
4553 case E_Task_Subtype
:
4554 case E_Protected_Type
:
4555 case E_Protected_Subtype
:
4556 /* Concurrent types are always transformed into their record type. */
4557 if (type_annotate_only
&& No (gnat_equiv_type
))
4558 gnu_type
= void_type_node
;
4560 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
4561 maybe_present
= true;
4565 gnu_decl
= create_label_decl (gnu_entity_name
);
4570 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4571 we've already saved it, so we don't try to. */
4572 gnu_decl
= error_mark_node
;
4580 /* If we had a case where we evaluated another type and it might have
4581 defined this one, handle it here. */
4582 if (maybe_present
&& present_gnu_tree (gnat_entity
))
4584 gnu_decl
= get_gnu_tree (gnat_entity
);
4588 /* If we are processing a type and there is either no decl for it or
4589 we just made one, do some common processing for the type, such as
4590 handling alignment and possible padding. */
4591 if (is_type
&& (!gnu_decl
|| this_made_decl
))
4593 /* Tell the middle-end that objects of tagged types are guaranteed to
4594 be properly aligned. This is necessary because conversions to the
4595 class-wide type are translated into conversions to the root type,
4596 which can be less aligned than some of its derived types. */
4597 if (Is_Tagged_Type (gnat_entity
)
4598 || Is_Class_Wide_Equivalent_Type (gnat_entity
))
4599 TYPE_ALIGN_OK (gnu_type
) = 1;
4601 /* If the type is passed by reference, objects of this type must be
4602 fully addressable and cannot be copied. */
4603 if (Is_By_Reference_Type (gnat_entity
))
4604 TREE_ADDRESSABLE (gnu_type
) = 1;
4606 /* ??? Don't set the size for a String_Literal since it is either
4607 confirming or we don't handle it properly (if the low bound is
4609 if (!gnu_size
&& kind
!= E_String_Literal_Subtype
)
4611 Uint gnat_size
= Known_Esize (gnat_entity
)
4612 ? Esize (gnat_entity
) : RM_Size (gnat_entity
);
4614 = validate_size (gnat_size
, gnu_type
, gnat_entity
, TYPE_DECL
,
4615 false, Has_Size_Clause (gnat_entity
));
4618 /* If a size was specified, see if we can make a new type of that size
4619 by rearranging the type, for example from a fat to a thin pointer. */
4623 = make_type_from_size (gnu_type
, gnu_size
,
4624 Has_Biased_Representation (gnat_entity
));
4626 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0)
4627 && operand_equal_p (rm_size (gnu_type
), gnu_size
, 0))
4631 /* If the alignment hasn't already been processed and this is
4632 not an unconstrained array, see if an alignment is specified.
4633 If not, we pick a default alignment for atomic objects. */
4634 if (align
!= 0 || TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4636 else if (Known_Alignment (gnat_entity
))
4638 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
4639 TYPE_ALIGN (gnu_type
));
4641 /* Warn on suspiciously large alignments. This should catch
4642 errors about the (alignment,byte)/(size,bit) discrepancy. */
4643 if (align
> BIGGEST_ALIGNMENT
&& Has_Alignment_Clause (gnat_entity
))
4647 /* If a size was specified, take it into account. Otherwise
4648 use the RM size for records as the type size has already
4649 been adjusted to the alignment. */
4652 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
4653 || TREE_CODE (gnu_type
) == UNION_TYPE
4654 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
4655 && !TYPE_FAT_POINTER_P (gnu_type
))
4656 size
= rm_size (gnu_type
);
4658 size
= TYPE_SIZE (gnu_type
);
4660 /* Consider an alignment as suspicious if the alignment/size
4661 ratio is greater or equal to the byte/bit ratio. */
4662 if (host_integerp (size
, 1)
4663 && align
>= TREE_INT_CST_LOW (size
) * BITS_PER_UNIT
)
4664 post_error_ne ("?suspiciously large alignment specified for&",
4665 Expression (Alignment_Clause (gnat_entity
)),
4669 else if (Is_Atomic (gnat_entity
) && !gnu_size
4670 && host_integerp (TYPE_SIZE (gnu_type
), 1)
4671 && integer_pow2p (TYPE_SIZE (gnu_type
)))
4672 align
= MIN (BIGGEST_ALIGNMENT
,
4673 tree_low_cst (TYPE_SIZE (gnu_type
), 1));
4674 else if (Is_Atomic (gnat_entity
) && gnu_size
4675 && host_integerp (gnu_size
, 1)
4676 && integer_pow2p (gnu_size
))
4677 align
= MIN (BIGGEST_ALIGNMENT
, tree_low_cst (gnu_size
, 1));
4679 /* See if we need to pad the type. If we did, and made a record,
4680 the name of the new type may be changed. So get it back for
4681 us when we make the new TYPE_DECL below. */
4682 if (gnu_size
|| align
> 0)
4683 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
4684 false, !gnu_decl
, definition
, false);
4686 if (TYPE_IS_PADDING_P (gnu_type
))
4688 gnu_entity_name
= TYPE_NAME (gnu_type
);
4689 if (TREE_CODE (gnu_entity_name
) == TYPE_DECL
)
4690 gnu_entity_name
= DECL_NAME (gnu_entity_name
);
4693 set_rm_size (RM_Size (gnat_entity
), gnu_type
, gnat_entity
);
4695 /* If we are at global level, GCC will have applied variable_size to
4696 the type, but that won't have done anything. So, if it's not
4697 a constant or self-referential, call elaborate_expression_1 to
4698 make a variable for the size rather than calculating it each time.
4699 Handle both the RM size and the actual size. */
4700 if (global_bindings_p ()
4701 && TYPE_SIZE (gnu_type
)
4702 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
))
4703 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
4705 tree size
= TYPE_SIZE (gnu_type
);
4707 TYPE_SIZE (gnu_type
)
4708 = elaborate_expression_1 (size
, gnat_entity
,
4709 get_identifier ("SIZE"),
4712 /* ??? For now, store the size as a multiple of the alignment in
4713 bytes so that we can see the alignment from the tree. */
4714 TYPE_SIZE_UNIT (gnu_type
)
4715 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type
), gnat_entity
,
4716 get_identifier ("SIZE_A_UNIT"),
4718 TYPE_ALIGN (gnu_type
));
4720 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4721 may not be marked by the call to create_type_decl below. */
4722 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type
));
4724 if (TREE_CODE (gnu_type
) == RECORD_TYPE
)
4726 tree variant_part
= get_variant_part (gnu_type
);
4727 tree ada_size
= TYPE_ADA_SIZE (gnu_type
);
4731 tree union_type
= TREE_TYPE (variant_part
);
4732 tree offset
= DECL_FIELD_OFFSET (variant_part
);
4734 /* If the position of the variant part is constant, subtract
4735 it from the size of the type of the parent to get the new
4736 size. This manual CSE reduces the data size. */
4737 if (TREE_CODE (offset
) == INTEGER_CST
)
4739 tree bitpos
= DECL_FIELD_BIT_OFFSET (variant_part
);
4740 TYPE_SIZE (union_type
)
4741 = size_binop (MINUS_EXPR
, TYPE_SIZE (gnu_type
),
4742 bit_from_pos (offset
, bitpos
));
4743 TYPE_SIZE_UNIT (union_type
)
4744 = size_binop (MINUS_EXPR
, TYPE_SIZE_UNIT (gnu_type
),
4745 byte_from_pos (offset
, bitpos
));
4749 TYPE_SIZE (union_type
)
4750 = elaborate_expression_1 (TYPE_SIZE (union_type
),
4752 get_identifier ("VSIZE"),
4755 /* ??? For now, store the size as a multiple of the
4756 alignment in bytes so that we can see the alignment
4758 TYPE_SIZE_UNIT (union_type
)
4759 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type
),
4764 TYPE_ALIGN (union_type
));
4766 /* ??? For now, store the offset as a multiple of the
4767 alignment in bytes so that we can see the alignment
4769 DECL_FIELD_OFFSET (variant_part
)
4770 = elaborate_expression_2 (offset
,
4772 get_identifier ("VOFFSET"),
4778 DECL_SIZE (variant_part
) = TYPE_SIZE (union_type
);
4779 DECL_SIZE_UNIT (variant_part
) = TYPE_SIZE_UNIT (union_type
);
4782 if (operand_equal_p (ada_size
, size
, 0))
4783 ada_size
= TYPE_SIZE (gnu_type
);
4786 = elaborate_expression_1 (ada_size
, gnat_entity
,
4787 get_identifier ("RM_SIZE"),
4789 SET_TYPE_ADA_SIZE (gnu_type
, ada_size
);
4793 /* If this is a record type or subtype, call elaborate_expression_1 on
4794 any field position. Do this for both global and local types.
4795 Skip any fields that we haven't made trees for to avoid problems with
4796 class wide types. */
4797 if (IN (kind
, Record_Kind
))
4798 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
4799 gnat_temp
= Next_Entity (gnat_temp
))
4800 if (Ekind (gnat_temp
) == E_Component
&& present_gnu_tree (gnat_temp
))
4802 tree gnu_field
= get_gnu_tree (gnat_temp
);
4804 /* ??? For now, store the offset as a multiple of the alignment
4805 in bytes so that we can see the alignment from the tree. */
4806 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field
)))
4808 DECL_FIELD_OFFSET (gnu_field
)
4809 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field
),
4811 get_identifier ("OFFSET"),
4813 DECL_OFFSET_ALIGN (gnu_field
));
4815 /* ??? The context of gnu_field is not necessarily gnu_type
4816 so the MULT_EXPR node built above may not be marked by
4817 the call to create_type_decl below. */
4818 if (global_bindings_p ())
4819 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field
));
4823 if (Treat_As_Volatile (gnat_entity
))
4825 = build_qualified_type (gnu_type
,
4826 TYPE_QUALS (gnu_type
) | TYPE_QUAL_VOLATILE
);
4828 if (Is_Atomic (gnat_entity
))
4829 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
4831 if (Present (Alignment_Clause (gnat_entity
)))
4832 TYPE_USER_ALIGN (gnu_type
) = 1;
4834 if (Universal_Aliasing (gnat_entity
))
4835 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type
)) = 1;
4838 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
4839 !Comes_From_Source (gnat_entity
),
4840 debug_info_p
, gnat_entity
);
4843 TREE_TYPE (gnu_decl
) = gnu_type
;
4844 TYPE_STUB_DECL (gnu_type
) = gnu_decl
;
4848 if (is_type
&& !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
)))
4850 gnu_type
= TREE_TYPE (gnu_decl
);
4852 /* If this is a derived type, relate its alias set to that of its parent
4853 to avoid troubles when a call to an inherited primitive is inlined in
4854 a context where a derived object is accessed. The inlined code works
4855 on the parent view so the resulting code may access the same object
4856 using both the parent and the derived alias sets, which thus have to
4857 conflict. As the same issue arises with component references, the
4858 parent alias set also has to conflict with composite types enclosing
4859 derived components. For instance, if we have:
4866 we want T to conflict with both D and R, in addition to R being a
4867 superset of D by record/component construction.
4869 One way to achieve this is to perform an alias set copy from the
4870 parent to the derived type. This is not quite appropriate, though,
4871 as we don't want separate derived types to conflict with each other:
4873 type I1 is new Integer;
4874 type I2 is new Integer;
4876 We want I1 and I2 to both conflict with Integer but we do not want
4877 I1 to conflict with I2, and an alias set copy on derivation would
4880 The option chosen is to make the alias set of the derived type a
4881 superset of that of its parent type. It trivially fulfills the
4882 simple requirement for the Integer derivation example above, and
4883 the component case as well by superset transitivity:
4886 R ----------> D ----------> T
4888 However, for composite types, conversions between derived types are
4889 translated into VIEW_CONVERT_EXPRs so a sequence like:
4891 type Comp1 is new Comp;
4892 type Comp2 is new Comp;
4893 procedure Proc (C : Comp1);
4901 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4903 and gimplified into:
4910 i.e. generates code involving type punning. Therefore, Comp1 needs
4911 to conflict with Comp2 and an alias set copy is required.
4913 The language rules ensure the parent type is already frozen here. */
4914 if (Is_Derived_Type (gnat_entity
))
4916 tree gnu_parent_type
= gnat_to_gnu_type (Etype (gnat_entity
));
4917 relate_alias_sets (gnu_type
, gnu_parent_type
,
4918 Is_Composite_Type (gnat_entity
)
4919 ? ALIAS_SET_COPY
: ALIAS_SET_SUPERSET
);
4922 /* Back-annotate the Alignment of the type if not already in the
4923 tree. Likewise for sizes. */
4924 if (Unknown_Alignment (gnat_entity
))
4926 unsigned int double_align
, align
;
4927 bool is_capped_double
, align_clause
;
4929 /* If the default alignment of "double" or larger scalar types is
4930 specifically capped and this is not an array with an alignment
4931 clause on the component type, return the cap. */
4932 if ((double_align
= double_float_alignment
) > 0)
4934 = is_double_float_or_array (gnat_entity
, &align_clause
);
4935 else if ((double_align
= double_scalar_alignment
) > 0)
4937 = is_double_scalar_or_array (gnat_entity
, &align_clause
);
4939 is_capped_double
= align_clause
= false;
4941 if (is_capped_double
&& !align_clause
)
4942 align
= double_align
;
4944 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
4946 Set_Alignment (gnat_entity
, UI_From_Int (align
));
4949 if (Unknown_Esize (gnat_entity
) && TYPE_SIZE (gnu_type
))
4951 tree gnu_size
= TYPE_SIZE (gnu_type
);
4953 /* If the size is self-referential, annotate the maximum value. */
4954 if (CONTAINS_PLACEHOLDER_P (gnu_size
))
4955 gnu_size
= max_size (gnu_size
, true);
4957 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
4959 /* In this mode, the tag and the parent components are not
4960 generated by the front-end so the sizes must be adjusted. */
4961 tree pointer_size
= bitsize_int (POINTER_SIZE
), offset
;
4964 if (Is_Derived_Type (gnat_entity
))
4966 offset
= UI_To_gnu (Esize (Etype (Base_Type (gnat_entity
))),
4968 Set_Alignment (gnat_entity
,
4969 Alignment (Etype (Base_Type (gnat_entity
))));
4972 offset
= pointer_size
;
4974 gnu_size
= size_binop (PLUS_EXPR
, gnu_size
, offset
);
4975 gnu_size
= size_binop (MULT_EXPR
, pointer_size
,
4976 size_binop (CEIL_DIV_EXPR
,
4979 uint_size
= annotate_value (gnu_size
);
4980 Set_Esize (gnat_entity
, uint_size
);
4981 Set_RM_Size (gnat_entity
, uint_size
);
4984 Set_Esize (gnat_entity
, annotate_value (gnu_size
));
4987 if (Unknown_RM_Size (gnat_entity
) && rm_size (gnu_type
))
4988 Set_RM_Size (gnat_entity
, annotate_value (rm_size (gnu_type
)));
4991 /* If we really have a ..._DECL node, set a couple of flags on it. But we
4992 cannot do so if we are reusing the ..._DECL node made for an alias or a
4993 renamed object as the predicates don't apply to it but to GNAT_ENTITY. */
4994 if (DECL_P (gnu_decl
)
4995 && !Present (Alias (gnat_entity
))
4996 && !(Present (Renamed_Object (gnat_entity
)) && saved
))
4998 if (!Comes_From_Source (gnat_entity
))
4999 DECL_ARTIFICIAL (gnu_decl
) = 1;
5002 DECL_IGNORED_P (gnu_decl
) = 1;
5005 /* If we haven't already, associate the ..._DECL node that we just made with
5006 the input GNAT entity node. */
5008 save_gnu_tree (gnat_entity
, gnu_decl
, false);
5010 /* If this is an enumeration or floating-point type, we were not able to set
5011 the bounds since they refer to the type. These are always static. */
5012 if ((kind
== E_Enumeration_Type
&& Present (First_Literal (gnat_entity
)))
5013 || (kind
== E_Floating_Point_Type
&& !Vax_Float (gnat_entity
)))
5015 tree gnu_scalar_type
= gnu_type
;
5016 tree gnu_low_bound
, gnu_high_bound
;
5018 /* If this is a padded type, we need to use the underlying type. */
5019 if (TYPE_IS_PADDING_P (gnu_scalar_type
))
5020 gnu_scalar_type
= TREE_TYPE (TYPE_FIELDS (gnu_scalar_type
));
5022 /* If this is a floating point type and we haven't set a floating
5023 point type yet, use this in the evaluation of the bounds. */
5024 if (!longest_float_type_node
&& kind
== E_Floating_Point_Type
)
5025 longest_float_type_node
= gnu_scalar_type
;
5027 gnu_low_bound
= gnat_to_gnu (Type_Low_Bound (gnat_entity
));
5028 gnu_high_bound
= gnat_to_gnu (Type_High_Bound (gnat_entity
));
5030 if (kind
== E_Enumeration_Type
)
5032 /* Enumeration types have specific RM bounds. */
5033 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type
, gnu_low_bound
);
5034 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type
, gnu_high_bound
);
5036 /* Write full debugging information. */
5037 rest_of_type_decl_compilation (gnu_decl
);
5042 /* Floating-point types don't have specific RM bounds. */
5043 TYPE_GCC_MIN_VALUE (gnu_scalar_type
) = gnu_low_bound
;
5044 TYPE_GCC_MAX_VALUE (gnu_scalar_type
) = gnu_high_bound
;
5048 /* If we deferred processing of incomplete types, re-enable it. If there
5049 were no other disables and we have deferred types to process, do so. */
5051 && --defer_incomplete_level
== 0
5052 && defer_incomplete_list
)
5054 struct incomplete
*p
, *next
;
5056 /* We are back to level 0 for the deferring of incomplete types.
5057 But processing these incomplete types below may itself require
5058 deferring, so preserve what we have and restart from scratch. */
5059 p
= defer_incomplete_list
;
5060 defer_incomplete_list
= NULL
;
5062 /* For finalization, however, all types must be complete so we
5063 cannot do the same because deferred incomplete types may end up
5064 referencing each other. Process them all recursively first. */
5065 defer_finalize_level
++;
5072 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5073 gnat_to_gnu_type (p
->full_type
));
5077 defer_finalize_level
--;
5080 /* If all the deferred incomplete types have been processed, we can proceed
5081 with the finalization of the deferred types. */
5082 if (defer_incomplete_level
== 0
5083 && defer_finalize_level
== 0
5084 && defer_finalize_list
)
5089 FOR_EACH_VEC_ELT (tree
, defer_finalize_list
, i
, t
)
5090 rest_of_type_decl_compilation_no_defer (t
);
5092 VEC_free (tree
, heap
, defer_finalize_list
);
5095 /* If we are not defining this type, see if it's on one of the lists of
5096 incomplete types. If so, handle the list entry now. */
5097 if (is_type
&& !definition
)
5099 struct incomplete
*p
;
5101 for (p
= defer_incomplete_list
; p
; p
= p
->next
)
5102 if (p
->old_type
&& p
->full_type
== gnat_entity
)
5104 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5105 TREE_TYPE (gnu_decl
));
5106 p
->old_type
= NULL_TREE
;
5109 for (p
= defer_limited_with
; p
; p
= p
->next
)
5110 if (p
->old_type
&& Non_Limited_View (p
->full_type
) == gnat_entity
)
5112 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5113 TREE_TYPE (gnu_decl
));
5114 p
->old_type
= NULL_TREE
;
5121 /* If this is a packed array type whose original array type is itself
5122 an Itype without freeze node, make sure the latter is processed. */
5123 if (Is_Packed_Array_Type (gnat_entity
)
5124 && Is_Itype (Original_Array_Type (gnat_entity
))
5125 && No (Freeze_Node (Original_Array_Type (gnat_entity
)))
5126 && !present_gnu_tree (Original_Array_Type (gnat_entity
)))
5127 gnat_to_gnu_entity (Original_Array_Type (gnat_entity
), NULL_TREE
, 0);
5132 /* Similar, but if the returned value is a COMPONENT_REF, return the
5136 gnat_to_gnu_field_decl (Entity_Id gnat_entity
)
5138 tree gnu_field
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
5140 if (TREE_CODE (gnu_field
) == COMPONENT_REF
)
5141 gnu_field
= TREE_OPERAND (gnu_field
, 1);
5146 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5147 the GCC type corresponding to that entity. */
5150 gnat_to_gnu_type (Entity_Id gnat_entity
)
5154 /* The back end never attempts to annotate generic types. */
5155 if (Is_Generic_Type (gnat_entity
) && type_annotate_only
)
5156 return void_type_node
;
5158 gnu_decl
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
5159 gcc_assert (TREE_CODE (gnu_decl
) == TYPE_DECL
);
5161 return TREE_TYPE (gnu_decl
);
5164 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5165 the unpadded version of the GCC type corresponding to that entity. */
5168 get_unpadded_type (Entity_Id gnat_entity
)
5170 tree type
= gnat_to_gnu_type (gnat_entity
);
5172 if (TYPE_IS_PADDING_P (type
))
5173 type
= TREE_TYPE (TYPE_FIELDS (type
));
5178 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
5179 Every TYPE_DECL generated for a type definition must be passed
5180 to this function once everything else has been done for it. */
5183 rest_of_type_decl_compilation (tree decl
)
5185 /* We need to defer finalizing the type if incomplete types
5186 are being deferred or if they are being processed. */
5187 if (defer_incomplete_level
!= 0 || defer_finalize_level
!= 0)
5188 VEC_safe_push (tree
, heap
, defer_finalize_list
, decl
);
5190 rest_of_type_decl_compilation_no_defer (decl
);
5193 /* Same as above but without deferring the compilation. This
5194 function should not be invoked directly on a TYPE_DECL. */
5197 rest_of_type_decl_compilation_no_defer (tree decl
)
5199 const int toplev
= global_bindings_p ();
5200 tree t
= TREE_TYPE (decl
);
5202 rest_of_decl_compilation (decl
, toplev
, 0);
5204 /* Now process all the variants. This is needed for STABS. */
5205 for (t
= TYPE_MAIN_VARIANT (t
); t
; t
= TYPE_NEXT_VARIANT (t
))
5207 if (t
== TREE_TYPE (decl
))
5210 if (!TYPE_STUB_DECL (t
))
5211 TYPE_STUB_DECL (t
) = create_type_stub_decl (DECL_NAME (decl
), t
);
5213 rest_of_type_compilation (t
, toplev
);
5217 /* Finalize the processing of From_With_Type incomplete types. */
5220 finalize_from_with_types (void)
5222 struct incomplete
*p
, *next
;
5224 p
= defer_limited_with
;
5225 defer_limited_with
= NULL
;
5232 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5233 gnat_to_gnu_type (p
->full_type
));
5238 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
5239 kind of type (such E_Task_Type) that has a different type which Gigi
5240 uses for its representation. If the type does not have a special type
5241 for its representation, return GNAT_ENTITY. If a type is supposed to
5242 exist, but does not, abort unless annotating types, in which case
5243 return Empty. If GNAT_ENTITY is Empty, return Empty. */
5246 Gigi_Equivalent_Type (Entity_Id gnat_entity
)
5248 Entity_Id gnat_equiv
= gnat_entity
;
5250 if (No (gnat_entity
))
5253 switch (Ekind (gnat_entity
))
5255 case E_Class_Wide_Subtype
:
5256 if (Present (Equivalent_Type (gnat_entity
)))
5257 gnat_equiv
= Equivalent_Type (gnat_entity
);
5260 case E_Access_Protected_Subprogram_Type
:
5261 case E_Anonymous_Access_Protected_Subprogram_Type
:
5262 gnat_equiv
= Equivalent_Type (gnat_entity
);
5265 case E_Class_Wide_Type
:
5266 gnat_equiv
= Root_Type (gnat_entity
);
5270 case E_Task_Subtype
:
5271 case E_Protected_Type
:
5272 case E_Protected_Subtype
:
5273 gnat_equiv
= Corresponding_Record_Type (gnat_entity
);
5280 gcc_assert (Present (gnat_equiv
) || type_annotate_only
);
5284 /* Return a GCC tree for a type corresponding to the component type of the
5285 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5286 is for an array being defined. DEBUG_INFO_P is true if we need to write
5287 debug information for other types that we may create in the process. */
5290 gnat_to_gnu_component_type (Entity_Id gnat_array
, bool definition
,
5293 const Entity_Id gnat_type
= Component_Type (gnat_array
);
5294 tree gnu_type
= gnat_to_gnu_type (gnat_type
);
5297 /* Try to get a smaller form of the component if needed. */
5298 if ((Is_Packed (gnat_array
)
5299 || Has_Component_Size_Clause (gnat_array
))
5300 && !Is_Bit_Packed_Array (gnat_array
)
5301 && !Has_Aliased_Components (gnat_array
)
5302 && !Strict_Alignment (gnat_type
)
5303 && TREE_CODE (gnu_type
) == RECORD_TYPE
5304 && !TYPE_FAT_POINTER_P (gnu_type
)
5305 && host_integerp (TYPE_SIZE (gnu_type
), 1))
5306 gnu_type
= make_packable_type (gnu_type
, false);
5308 if (Has_Atomic_Components (gnat_array
))
5309 check_ok_for_atomic (gnu_type
, gnat_array
, true);
5311 /* Get and validate any specified Component_Size. */
5313 = validate_size (Component_Size (gnat_array
), gnu_type
, gnat_array
,
5314 Is_Bit_Packed_Array (gnat_array
) ? TYPE_DECL
: VAR_DECL
,
5315 true, Has_Component_Size_Clause (gnat_array
));
5317 /* If the array has aliased components and the component size can be zero,
5318 force at least unit size to ensure that the components have distinct
5321 && Has_Aliased_Components (gnat_array
)
5322 && (integer_zerop (TYPE_SIZE (gnu_type
))
5323 || (TREE_CODE (gnu_type
) == ARRAY_TYPE
5324 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
)))))
5326 = size_binop (MAX_EXPR
, TYPE_SIZE (gnu_type
), bitsize_unit_node
);
5328 /* If the component type is a RECORD_TYPE that has a self-referential size,
5329 then use the maximum size for the component size. */
5331 && TREE_CODE (gnu_type
) == RECORD_TYPE
5332 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
5333 gnu_comp_size
= max_size (TYPE_SIZE (gnu_type
), true);
5335 /* Honor the component size. This is not needed for bit-packed arrays. */
5336 if (gnu_comp_size
&& !Is_Bit_Packed_Array (gnat_array
))
5338 tree orig_type
= gnu_type
;
5339 unsigned int max_align
;
5341 /* If an alignment is specified, use it as a cap on the component type
5342 so that it can be honored for the whole type. But ignore it for the
5343 original type of packed array types. */
5344 if (No (Packed_Array_Type (gnat_array
)) && Known_Alignment (gnat_array
))
5345 max_align
= validate_alignment (Alignment (gnat_array
), gnat_array
, 0);
5349 gnu_type
= make_type_from_size (gnu_type
, gnu_comp_size
, false);
5350 if (max_align
> 0 && TYPE_ALIGN (gnu_type
) > max_align
)
5351 gnu_type
= orig_type
;
5353 orig_type
= gnu_type
;
5355 gnu_type
= maybe_pad_type (gnu_type
, gnu_comp_size
, 0, gnat_array
,
5356 true, false, definition
, true);
5358 /* If a padding record was made, declare it now since it will never be
5359 declared otherwise. This is necessary to ensure that its subtrees
5360 are properly marked. */
5361 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
5362 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, NULL
, true,
5363 debug_info_p
, gnat_array
);
5366 if (Has_Volatile_Components (gnat_array
))
5368 = build_qualified_type (gnu_type
,
5369 TYPE_QUALS (gnu_type
) | TYPE_QUAL_VOLATILE
);
5374 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5375 using MECH as its passing mechanism, to be placed in the parameter
5376 list built for GNAT_SUBPROG. Assume a foreign convention for the
5377 latter if FOREIGN is true. Also set CICO to true if the parameter
5378 must use the copy-in copy-out implementation mechanism.
5380 The returned tree is a PARM_DECL, except for those cases where no
5381 parameter needs to be actually passed to the subprogram; the type
5382 of this "shadow" parameter is then returned instead. */
5385 gnat_to_gnu_param (Entity_Id gnat_param
, Mechanism_Type mech
,
5386 Entity_Id gnat_subprog
, bool foreign
, bool *cico
)
5388 tree gnu_param_name
= get_entity_name (gnat_param
);
5389 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
5390 tree gnu_param_type_alt
= NULL_TREE
;
5391 bool in_param
= (Ekind (gnat_param
) == E_In_Parameter
);
5392 /* The parameter can be indirectly modified if its address is taken. */
5393 bool ro_param
= in_param
&& !Address_Taken (gnat_param
);
5394 bool by_return
= false, by_component_ptr
= false;
5395 bool by_ref
= false, by_double_ref
= false;
5398 /* Copy-return is used only for the first parameter of a valued procedure.
5399 It's a copy mechanism for which a parameter is never allocated. */
5400 if (mech
== By_Copy_Return
)
5402 gcc_assert (Ekind (gnat_param
) == E_Out_Parameter
);
5407 /* If this is either a foreign function or if the underlying type won't
5408 be passed by reference, strip off possible padding type. */
5409 if (TYPE_IS_PADDING_P (gnu_param_type
))
5411 tree unpadded_type
= TREE_TYPE (TYPE_FIELDS (gnu_param_type
));
5413 if (mech
== By_Reference
5415 || (!must_pass_by_ref (unpadded_type
)
5416 && (mech
== By_Copy
|| !default_pass_by_ref (unpadded_type
))))
5417 gnu_param_type
= unpadded_type
;
5420 /* If this is a read-only parameter, make a variant of the type that is
5421 read-only. ??? However, if this is an unconstrained array, that type
5422 can be very complex, so skip it for now. Likewise for any other
5423 self-referential type. */
5425 && TREE_CODE (gnu_param_type
) != UNCONSTRAINED_ARRAY_TYPE
5426 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type
)))
5427 gnu_param_type
= build_qualified_type (gnu_param_type
,
5428 (TYPE_QUALS (gnu_param_type
)
5429 | TYPE_QUAL_CONST
));
5431 /* For foreign conventions, pass arrays as pointers to the element type.
5432 First check for unconstrained array and get the underlying array. */
5433 if (foreign
&& TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5435 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type
))));
5437 /* For GCC builtins, pass Address integer types as (void *) */
5438 if (Convention (gnat_subprog
) == Convention_Intrinsic
5439 && Present (Interface_Name (gnat_subprog
))
5440 && Is_Descendent_Of_Address (Etype (gnat_param
)))
5441 gnu_param_type
= ptr_void_type_node
;
5443 /* VMS descriptors are themselves passed by reference. */
5444 if (mech
== By_Short_Descriptor
||
5445 (mech
== By_Descriptor
&& TARGET_ABI_OPEN_VMS
&& !TARGET_MALLOC64
))
5447 = build_pointer_type (build_vms_descriptor32 (gnu_param_type
,
5448 Mechanism (gnat_param
),
5450 else if (mech
== By_Descriptor
)
5452 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5453 chosen in fill_vms_descriptor. */
5455 = build_pointer_type (build_vms_descriptor32 (gnu_param_type
,
5456 Mechanism (gnat_param
),
5459 = build_pointer_type (build_vms_descriptor (gnu_param_type
,
5460 Mechanism (gnat_param
),
5464 /* Arrays are passed as pointers to element type for foreign conventions. */
5467 && TREE_CODE (gnu_param_type
) == ARRAY_TYPE
)
5469 /* Strip off any multi-dimensional entries, then strip
5470 off the last array to get the component type. */
5471 while (TREE_CODE (TREE_TYPE (gnu_param_type
)) == ARRAY_TYPE
5472 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type
)))
5473 gnu_param_type
= TREE_TYPE (gnu_param_type
);
5475 by_component_ptr
= true;
5476 gnu_param_type
= TREE_TYPE (gnu_param_type
);
5479 gnu_param_type
= build_qualified_type (gnu_param_type
,
5480 (TYPE_QUALS (gnu_param_type
)
5481 | TYPE_QUAL_CONST
));
5483 gnu_param_type
= build_pointer_type (gnu_param_type
);
5486 /* Fat pointers are passed as thin pointers for foreign conventions. */
5487 else if (foreign
&& TYPE_IS_FAT_POINTER_P (gnu_param_type
))
5489 = make_type_from_size (gnu_param_type
, size_int (POINTER_SIZE
), 0);
5491 /* If we must pass or were requested to pass by reference, do so.
5492 If we were requested to pass by copy, do so.
5493 Otherwise, for foreign conventions, pass In Out or Out parameters
5494 or aggregates by reference. For COBOL and Fortran, pass all
5495 integer and FP types that way too. For Convention Ada, use
5496 the standard Ada default. */
5497 else if (must_pass_by_ref (gnu_param_type
)
5498 || mech
== By_Reference
5501 && (!in_param
|| AGGREGATE_TYPE_P (gnu_param_type
)))
5503 && (Convention (gnat_subprog
) == Convention_Fortran
5504 || Convention (gnat_subprog
) == Convention_COBOL
)
5505 && (INTEGRAL_TYPE_P (gnu_param_type
)
5506 || FLOAT_TYPE_P (gnu_param_type
)))
5508 && default_pass_by_ref (gnu_param_type
)))))
5510 gnu_param_type
= build_reference_type (gnu_param_type
);
5513 /* In some ABIs, e.g. SPARC 32-bit, fat pointer types are themselves
5514 passed by reference. Pass them by explicit reference, this will
5515 generate more debuggable code at -O0. */
5516 if (TYPE_IS_FAT_POINTER_P (gnu_param_type
)
5517 && targetm
.calls
.pass_by_reference (pack_cumulative_args (NULL
),
5518 TYPE_MODE (gnu_param_type
),
5522 gnu_param_type
= build_reference_type (gnu_param_type
);
5523 by_double_ref
= true;
5527 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5531 if (mech
== By_Copy
&& (by_ref
|| by_component_ptr
))
5532 post_error ("?cannot pass & by copy", gnat_param
);
5534 /* If this is an Out parameter that isn't passed by reference and isn't
5535 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5536 it will be a VAR_DECL created when we process the procedure, so just
5537 return its type. For the special parameter of a valued procedure,
5540 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5541 Out parameters with discriminants or implicit initial values to be
5542 handled like In Out parameters. These type are normally built as
5543 aggregates, hence passed by reference, except for some packed arrays
5544 which end up encoded in special integer types.
5546 The exception we need to make is then for packed arrays of records
5547 with discriminants or implicit initial values. We have no light/easy
5548 way to check for the latter case, so we merely check for packed arrays
5549 of records. This may lead to useless copy-in operations, but in very
5550 rare cases only, as these would be exceptions in a set of already
5551 exceptional situations. */
5552 if (Ekind (gnat_param
) == E_Out_Parameter
5555 || (mech
!= By_Descriptor
5556 && mech
!= By_Short_Descriptor
5557 && !POINTER_TYPE_P (gnu_param_type
)
5558 && !AGGREGATE_TYPE_P (gnu_param_type
)))
5559 && !(Is_Array_Type (Etype (gnat_param
))
5560 && Is_Packed (Etype (gnat_param
))
5561 && Is_Composite_Type (Component_Type (Etype (gnat_param
)))))
5562 return gnu_param_type
;
5564 gnu_param
= create_param_decl (gnu_param_name
, gnu_param_type
,
5565 ro_param
|| by_ref
|| by_component_ptr
);
5566 DECL_BY_REF_P (gnu_param
) = by_ref
;
5567 DECL_BY_DOUBLE_REF_P (gnu_param
) = by_double_ref
;
5568 DECL_BY_COMPONENT_PTR_P (gnu_param
) = by_component_ptr
;
5569 DECL_BY_DESCRIPTOR_P (gnu_param
) = (mech
== By_Descriptor
||
5570 mech
== By_Short_Descriptor
);
5571 DECL_POINTS_TO_READONLY_P (gnu_param
)
5572 = (ro_param
&& (by_ref
|| by_component_ptr
));
5573 DECL_CAN_NEVER_BE_NULL_P (gnu_param
) = Can_Never_Be_Null (gnat_param
);
5575 /* Save the alternate descriptor type, if any. */
5576 if (gnu_param_type_alt
)
5577 SET_DECL_PARM_ALT_TYPE (gnu_param
, gnu_param_type_alt
);
5579 /* If no Mechanism was specified, indicate what we're using, then
5580 back-annotate it. */
5581 if (mech
== Default
)
5582 mech
= (by_ref
|| by_component_ptr
) ? By_Reference
: By_Copy
;
5584 Set_Mechanism (gnat_param
, mech
);
5588 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5591 same_discriminant_p (Entity_Id discr1
, Entity_Id discr2
)
5593 while (Present (Corresponding_Discriminant (discr1
)))
5594 discr1
= Corresponding_Discriminant (discr1
);
5596 while (Present (Corresponding_Discriminant (discr2
)))
5597 discr2
= Corresponding_Discriminant (discr2
);
5600 Original_Record_Component (discr1
) == Original_Record_Component (discr2
);
5603 /* Return true if the array type GNU_TYPE, which represents a dimension of
5604 GNAT_TYPE, has a non-aliased component in the back-end sense. */
5607 array_type_has_nonaliased_component (tree gnu_type
, Entity_Id gnat_type
)
5609 /* If the array type is not the innermost dimension of the GNAT type,
5610 then it has a non-aliased component. */
5611 if (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
5612 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
5615 /* If the array type has an aliased component in the front-end sense,
5616 then it also has an aliased component in the back-end sense. */
5617 if (Has_Aliased_Components (gnat_type
))
5620 /* If this is a derived type, then it has a non-aliased component if
5621 and only if its parent type also has one. */
5622 if (Is_Derived_Type (gnat_type
))
5624 tree gnu_parent_type
= gnat_to_gnu_type (Etype (gnat_type
));
5626 if (TREE_CODE (gnu_parent_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5628 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type
))));
5629 for (index
= Number_Dimensions (gnat_type
) - 1; index
> 0; index
--)
5630 gnu_parent_type
= TREE_TYPE (gnu_parent_type
);
5631 return TYPE_NONALIASED_COMPONENT (gnu_parent_type
);
5634 /* Otherwise, rely exclusively on properties of the element type. */
5635 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type
));
5638 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5641 compile_time_known_address_p (Node_Id gnat_address
)
5643 /* Catch System'To_Address. */
5644 if (Nkind (gnat_address
) == N_Unchecked_Type_Conversion
)
5645 gnat_address
= Expression (gnat_address
);
5647 return Compile_Time_Known_Value (gnat_address
);
5650 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
5651 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
5654 cannot_be_superflat_p (Node_Id gnat_range
)
5656 Node_Id gnat_lb
= Low_Bound (gnat_range
), gnat_hb
= High_Bound (gnat_range
);
5657 Node_Id scalar_range
;
5658 tree gnu_lb
, gnu_hb
, gnu_lb_minus_one
;
5660 /* If the low bound is not constant, try to find an upper bound. */
5661 while (Nkind (gnat_lb
) != N_Integer_Literal
5662 && (Ekind (Etype (gnat_lb
)) == E_Signed_Integer_Subtype
5663 || Ekind (Etype (gnat_lb
)) == E_Modular_Integer_Subtype
)
5664 && (scalar_range
= Scalar_Range (Etype (gnat_lb
)))
5665 && (Nkind (scalar_range
) == N_Signed_Integer_Type_Definition
5666 || Nkind (scalar_range
) == N_Range
))
5667 gnat_lb
= High_Bound (scalar_range
);
5669 /* If the high bound is not constant, try to find a lower bound. */
5670 while (Nkind (gnat_hb
) != N_Integer_Literal
5671 && (Ekind (Etype (gnat_hb
)) == E_Signed_Integer_Subtype
5672 || Ekind (Etype (gnat_hb
)) == E_Modular_Integer_Subtype
)
5673 && (scalar_range
= Scalar_Range (Etype (gnat_hb
)))
5674 && (Nkind (scalar_range
) == N_Signed_Integer_Type_Definition
5675 || Nkind (scalar_range
) == N_Range
))
5676 gnat_hb
= Low_Bound (scalar_range
);
5678 /* If we have failed to find constant bounds, punt. */
5679 if (Nkind (gnat_lb
) != N_Integer_Literal
5680 || Nkind (gnat_hb
) != N_Integer_Literal
)
5683 /* We need at least a signed 64-bit type to catch most cases. */
5684 gnu_lb
= UI_To_gnu (Intval (gnat_lb
), sbitsizetype
);
5685 gnu_hb
= UI_To_gnu (Intval (gnat_hb
), sbitsizetype
);
5686 if (TREE_OVERFLOW (gnu_lb
) || TREE_OVERFLOW (gnu_hb
))
5689 /* If the low bound is the smallest integer, nothing can be smaller. */
5690 gnu_lb_minus_one
= size_binop (MINUS_EXPR
, gnu_lb
, sbitsize_one_node
);
5691 if (TREE_OVERFLOW (gnu_lb_minus_one
))
5694 return !tree_int_cst_lt (gnu_hb
, gnu_lb_minus_one
);
5697 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
5700 constructor_address_p (tree gnu_expr
)
5702 while (TREE_CODE (gnu_expr
) == NOP_EXPR
5703 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
5704 || TREE_CODE (gnu_expr
) == NON_LVALUE_EXPR
)
5705 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
5707 return (TREE_CODE (gnu_expr
) == ADDR_EXPR
5708 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == CONSTRUCTOR
);
5711 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5712 be elaborated at the point of its definition, but do nothing else. */
5715 elaborate_entity (Entity_Id gnat_entity
)
5717 switch (Ekind (gnat_entity
))
5719 case E_Signed_Integer_Subtype
:
5720 case E_Modular_Integer_Subtype
:
5721 case E_Enumeration_Subtype
:
5722 case E_Ordinary_Fixed_Point_Subtype
:
5723 case E_Decimal_Fixed_Point_Subtype
:
5724 case E_Floating_Point_Subtype
:
5726 Node_Id gnat_lb
= Type_Low_Bound (gnat_entity
);
5727 Node_Id gnat_hb
= Type_High_Bound (gnat_entity
);
5729 /* ??? Tests to avoid Constraint_Error in static expressions
5730 are needed until after the front stops generating bogus
5731 conversions on bounds of real types. */
5732 if (!Raises_Constraint_Error (gnat_lb
))
5733 elaborate_expression (gnat_lb
, gnat_entity
, get_identifier ("L"),
5734 true, false, Needs_Debug_Info (gnat_entity
));
5735 if (!Raises_Constraint_Error (gnat_hb
))
5736 elaborate_expression (gnat_hb
, gnat_entity
, get_identifier ("U"),
5737 true, false, Needs_Debug_Info (gnat_entity
));
5743 Node_Id full_definition
= Declaration_Node (gnat_entity
);
5744 Node_Id record_definition
= Type_Definition (full_definition
);
5746 /* If this is a record extension, go a level further to find the
5747 record definition. */
5748 if (Nkind (record_definition
) == N_Derived_Type_Definition
)
5749 record_definition
= Record_Extension_Part (record_definition
);
5753 case E_Record_Subtype
:
5754 case E_Private_Subtype
:
5755 case E_Limited_Private_Subtype
:
5756 case E_Record_Subtype_With_Private
:
5757 if (Is_Constrained (gnat_entity
)
5758 && Has_Discriminants (gnat_entity
)
5759 && Present (Discriminant_Constraint (gnat_entity
)))
5761 Node_Id gnat_discriminant_expr
;
5762 Entity_Id gnat_field
;
5765 = First_Discriminant (Implementation_Base_Type (gnat_entity
)),
5766 gnat_discriminant_expr
5767 = First_Elmt (Discriminant_Constraint (gnat_entity
));
5768 Present (gnat_field
);
5769 gnat_field
= Next_Discriminant (gnat_field
),
5770 gnat_discriminant_expr
= Next_Elmt (gnat_discriminant_expr
))
5771 /* ??? For now, ignore access discriminants. */
5772 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr
))))
5773 elaborate_expression (Node (gnat_discriminant_expr
),
5774 gnat_entity
, get_entity_name (gnat_field
),
5775 true, false, false);
5782 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5783 any entities on its entity chain similarly. */
5786 mark_out_of_scope (Entity_Id gnat_entity
)
5788 Entity_Id gnat_sub_entity
;
5789 unsigned int kind
= Ekind (gnat_entity
);
5791 /* If this has an entity list, process all in the list. */
5792 if (IN (kind
, Class_Wide_Kind
) || IN (kind
, Concurrent_Kind
)
5793 || IN (kind
, Private_Kind
)
5794 || kind
== E_Block
|| kind
== E_Entry
|| kind
== E_Entry_Family
5795 || kind
== E_Function
|| kind
== E_Generic_Function
5796 || kind
== E_Generic_Package
|| kind
== E_Generic_Procedure
5797 || kind
== E_Loop
|| kind
== E_Operator
|| kind
== E_Package
5798 || kind
== E_Package_Body
|| kind
== E_Procedure
5799 || kind
== E_Record_Type
|| kind
== E_Record_Subtype
5800 || kind
== E_Subprogram_Body
|| kind
== E_Subprogram_Type
)
5801 for (gnat_sub_entity
= First_Entity (gnat_entity
);
5802 Present (gnat_sub_entity
);
5803 gnat_sub_entity
= Next_Entity (gnat_sub_entity
))
5804 if (Scope (gnat_sub_entity
) == gnat_entity
5805 && gnat_sub_entity
!= gnat_entity
)
5806 mark_out_of_scope (gnat_sub_entity
);
5808 /* Now clear this if it has been defined, but only do so if it isn't
5809 a subprogram or parameter. We could refine this, but it isn't
5810 worth it. If this is statically allocated, it is supposed to
5811 hang around out of cope. */
5812 if (present_gnu_tree (gnat_entity
) && !Is_Statically_Allocated (gnat_entity
)
5813 && kind
!= E_Procedure
&& kind
!= E_Function
&& !IN (kind
, Formal_Kind
))
5815 save_gnu_tree (gnat_entity
, NULL_TREE
, true);
5816 save_gnu_tree (gnat_entity
, error_mark_node
, true);
5820 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5821 If this is a multi-dimensional array type, do this recursively.
5824 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5825 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5826 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5829 relate_alias_sets (tree gnu_new_type
, tree gnu_old_type
, enum alias_set_op op
)
5831 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5832 of a one-dimensional array, since the padding has the same alias set
5833 as the field type, but if it's a multi-dimensional array, we need to
5834 see the inner types. */
5835 while (TREE_CODE (gnu_old_type
) == RECORD_TYPE
5836 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type
)
5837 || TYPE_PADDING_P (gnu_old_type
)))
5838 gnu_old_type
= TREE_TYPE (TYPE_FIELDS (gnu_old_type
));
5840 /* Unconstrained array types are deemed incomplete and would thus be given
5841 alias set 0. Retrieve the underlying array type. */
5842 if (TREE_CODE (gnu_old_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5844 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type
))));
5845 if (TREE_CODE (gnu_new_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5847 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type
))));
5849 if (TREE_CODE (gnu_new_type
) == ARRAY_TYPE
5850 && TREE_CODE (TREE_TYPE (gnu_new_type
)) == ARRAY_TYPE
5851 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type
)))
5852 relate_alias_sets (TREE_TYPE (gnu_new_type
), TREE_TYPE (gnu_old_type
), op
);
5856 case ALIAS_SET_COPY
:
5857 /* The alias set shouldn't be copied between array types with different
5858 aliasing settings because this can break the aliasing relationship
5859 between the array type and its element type. */
5860 #ifndef ENABLE_CHECKING
5861 if (flag_strict_aliasing
)
5863 gcc_assert (!(TREE_CODE (gnu_new_type
) == ARRAY_TYPE
5864 && TREE_CODE (gnu_old_type
) == ARRAY_TYPE
5865 && TYPE_NONALIASED_COMPONENT (gnu_new_type
)
5866 != TYPE_NONALIASED_COMPONENT (gnu_old_type
)));
5868 TYPE_ALIAS_SET (gnu_new_type
) = get_alias_set (gnu_old_type
);
5871 case ALIAS_SET_SUBSET
:
5872 case ALIAS_SET_SUPERSET
:
5874 alias_set_type old_set
= get_alias_set (gnu_old_type
);
5875 alias_set_type new_set
= get_alias_set (gnu_new_type
);
5877 /* Do nothing if the alias sets conflict. This ensures that we
5878 never call record_alias_subset several times for the same pair
5879 or at all for alias set 0. */
5880 if (!alias_sets_conflict_p (old_set
, new_set
))
5882 if (op
== ALIAS_SET_SUBSET
)
5883 record_alias_subset (old_set
, new_set
);
5885 record_alias_subset (new_set
, old_set
);
5894 record_component_aliases (gnu_new_type
);
5897 /* Return true if the size represented by GNU_SIZE can be handled by an
5898 allocation. If STATIC_P is true, consider only what can be done with a
5899 static allocation. */
5902 allocatable_size_p (tree gnu_size
, bool static_p
)
5904 HOST_WIDE_INT our_size
;
5906 /* If this is not a static allocation, the only case we want to forbid
5907 is an overflowing size. That will be converted into a raise a
5910 return !(TREE_CODE (gnu_size
) == INTEGER_CST
5911 && TREE_OVERFLOW (gnu_size
));
5913 /* Otherwise, we need to deal with both variable sizes and constant
5914 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5915 since assemblers may not like very large sizes. */
5916 if (!host_integerp (gnu_size
, 1))
5919 our_size
= tree_low_cst (gnu_size
, 1);
5920 return (int) our_size
== our_size
;
5923 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5924 NAME, ARGS and ERROR_POINT. */
5927 prepend_one_attribute_to (struct attrib
** attr_list
,
5928 enum attr_type attr_type
,
5931 Node_Id attr_error_point
)
5933 struct attrib
* attr
= (struct attrib
*) xmalloc (sizeof (struct attrib
));
5935 attr
->type
= attr_type
;
5936 attr
->name
= attr_name
;
5937 attr
->args
= attr_args
;
5938 attr
->error_point
= attr_error_point
;
5940 attr
->next
= *attr_list
;
5944 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5947 prepend_attributes (Entity_Id gnat_entity
, struct attrib
** attr_list
)
5951 /* Attributes are stored as Representation Item pragmas. */
5953 for (gnat_temp
= First_Rep_Item (gnat_entity
); Present (gnat_temp
);
5954 gnat_temp
= Next_Rep_Item (gnat_temp
))
5955 if (Nkind (gnat_temp
) == N_Pragma
)
5957 tree gnu_arg0
= NULL_TREE
, gnu_arg1
= NULL_TREE
;
5958 Node_Id gnat_assoc
= Pragma_Argument_Associations (gnat_temp
);
5959 enum attr_type etype
;
5961 /* Map the kind of pragma at hand. Skip if this is not one
5962 we know how to handle. */
5964 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp
))))
5966 case Pragma_Machine_Attribute
:
5967 etype
= ATTR_MACHINE_ATTRIBUTE
;
5970 case Pragma_Linker_Alias
:
5971 etype
= ATTR_LINK_ALIAS
;
5974 case Pragma_Linker_Section
:
5975 etype
= ATTR_LINK_SECTION
;
5978 case Pragma_Linker_Constructor
:
5979 etype
= ATTR_LINK_CONSTRUCTOR
;
5982 case Pragma_Linker_Destructor
:
5983 etype
= ATTR_LINK_DESTRUCTOR
;
5986 case Pragma_Weak_External
:
5987 etype
= ATTR_WEAK_EXTERNAL
;
5990 case Pragma_Thread_Local_Storage
:
5991 etype
= ATTR_THREAD_LOCAL_STORAGE
;
5998 /* See what arguments we have and turn them into GCC trees for
5999 attribute handlers. These expect identifier for strings. We
6000 handle at most two arguments, static expressions only. */
6002 if (Present (gnat_assoc
) && Present (First (gnat_assoc
)))
6004 Node_Id gnat_arg0
= Next (First (gnat_assoc
));
6005 Node_Id gnat_arg1
= Empty
;
6007 if (Present (gnat_arg0
)
6008 && Is_Static_Expression (Expression (gnat_arg0
)))
6010 gnu_arg0
= gnat_to_gnu (Expression (gnat_arg0
));
6012 if (TREE_CODE (gnu_arg0
) == STRING_CST
)
6013 gnu_arg0
= get_identifier (TREE_STRING_POINTER (gnu_arg0
));
6015 gnat_arg1
= Next (gnat_arg0
);
6018 if (Present (gnat_arg1
)
6019 && Is_Static_Expression (Expression (gnat_arg1
)))
6021 gnu_arg1
= gnat_to_gnu (Expression (gnat_arg1
));
6023 if (TREE_CODE (gnu_arg1
) == STRING_CST
)
6024 gnu_arg1
= get_identifier (TREE_STRING_POINTER (gnu_arg1
));
6028 /* Prepend to the list now. Make a list of the argument we might
6029 have, as GCC expects it. */
6030 prepend_one_attribute_to
6033 (gnu_arg1
!= NULL_TREE
)
6034 ? build_tree_list (NULL_TREE
, gnu_arg1
) : NULL_TREE
,
6035 Present (Next (First (gnat_assoc
)))
6036 ? Expression (Next (First (gnat_assoc
))) : gnat_temp
);
6040 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6041 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6042 return the GCC tree to use for that expression. GNU_NAME is the suffix
6043 to use if a variable needs to be created and DEFINITION is true if this
6044 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6045 otherwise, we are just elaborating the expression for side-effects. If
6046 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6047 isn't needed for code generation. */
6050 elaborate_expression (Node_Id gnat_expr
, Entity_Id gnat_entity
, tree gnu_name
,
6051 bool definition
, bool need_value
, bool need_debug
)
6055 /* If we already elaborated this expression (e.g. it was involved
6056 in the definition of a private type), use the old value. */
6057 if (present_gnu_tree (gnat_expr
))
6058 return get_gnu_tree (gnat_expr
);
6060 /* If we don't need a value and this is static or a discriminant,
6061 we don't need to do anything. */
6063 && (Is_OK_Static_Expression (gnat_expr
)
6064 || (Nkind (gnat_expr
) == N_Identifier
6065 && Ekind (Entity (gnat_expr
)) == E_Discriminant
)))
6068 /* If it's a static expression, we don't need a variable for debugging. */
6069 if (need_debug
&& Is_OK_Static_Expression (gnat_expr
))
6072 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6073 gnu_expr
= elaborate_expression_1 (gnat_to_gnu (gnat_expr
), gnat_entity
,
6074 gnu_name
, definition
, need_debug
);
6076 /* Save the expression in case we try to elaborate this entity again. Since
6077 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6078 if (!CONTAINS_PLACEHOLDER_P (gnu_expr
))
6079 save_gnu_tree (gnat_expr
, gnu_expr
, true);
6081 return need_value
? gnu_expr
: error_mark_node
;
6084 /* Similar, but take a GNU expression and always return a result. */
6087 elaborate_expression_1 (tree gnu_expr
, Entity_Id gnat_entity
, tree gnu_name
,
6088 bool definition
, bool need_debug
)
6090 const bool expr_global_p
= Is_Public (gnat_entity
) || global_bindings_p ();
6091 bool expr_variable_p
, use_variable
;
6093 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
6094 reference will have been replaced with a COMPONENT_REF when the type
6095 is being elaborated. However, there are some cases involving child
6096 types where we will. So convert it to a COMPONENT_REF. We hope it
6097 will be at the highest level of the expression in these cases. */
6098 if (TREE_CODE (gnu_expr
) == FIELD_DECL
)
6099 gnu_expr
= build3 (COMPONENT_REF
, TREE_TYPE (gnu_expr
),
6100 build0 (PLACEHOLDER_EXPR
, DECL_CONTEXT (gnu_expr
)),
6101 gnu_expr
, NULL_TREE
);
6103 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6104 that an expression cannot contain both a discriminant and a variable. */
6105 if (CONTAINS_PLACEHOLDER_P (gnu_expr
))
6108 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6109 a variable that is initialized to contain the expression when the package
6110 containing the definition is elaborated. If this entity is defined at top
6111 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6112 if this is necessary. */
6113 if (CONSTANT_CLASS_P (gnu_expr
))
6114 expr_variable_p
= false;
6117 /* Skip any conversions and simple arithmetics to see if the expression
6118 is based on a read-only variable.
6119 ??? This really should remain read-only, but we have to think about
6120 the typing of the tree here. */
6122 = skip_simple_arithmetic (remove_conversions (gnu_expr
, true));
6124 if (handled_component_p (inner
))
6126 HOST_WIDE_INT bitsize
, bitpos
;
6128 enum machine_mode mode
;
6129 int unsignedp
, volatilep
;
6131 inner
= get_inner_reference (inner
, &bitsize
, &bitpos
, &offset
,
6132 &mode
, &unsignedp
, &volatilep
, false);
6133 /* If the offset is variable, err on the side of caution. */
6140 && TREE_CODE (inner
) == VAR_DECL
6141 && (TREE_READONLY (inner
) || DECL_READONLY_ONCE_ELAB (inner
)));
6144 /* We only need to use the variable if we are in a global context since GCC
6145 can do the right thing in the local case. However, when not optimizing,
6146 use it for bounds of loop iteration scheme to avoid code duplication. */
6147 use_variable
= expr_variable_p
6150 && Is_Itype (gnat_entity
)
6151 && Nkind (Associated_Node_For_Itype (gnat_entity
))
6152 == N_Loop_Parameter_Specification
));
6154 /* Now create it, possibly only for debugging purposes. */
6155 if (use_variable
|| need_debug
)
6158 = create_var_decl (create_concat_name (gnat_entity
,
6159 IDENTIFIER_POINTER (gnu_name
)),
6160 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
6161 !need_debug
, Is_Public (gnat_entity
),
6162 !definition
, expr_global_p
, NULL
, gnat_entity
);
6168 return expr_variable_p
? gnat_save_expr (gnu_expr
) : gnu_expr
;
6171 /* Similar, but take an alignment factor and make it explicit in the tree. */
6174 elaborate_expression_2 (tree gnu_expr
, Entity_Id gnat_entity
, tree gnu_name
,
6175 bool definition
, bool need_debug
, unsigned int align
)
6177 tree unit_align
= size_int (align
/ BITS_PER_UNIT
);
6179 size_binop (MULT_EXPR
,
6180 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR
,
6183 gnat_entity
, gnu_name
, definition
,
6188 /* Create a record type that contains a SIZE bytes long field of TYPE with a
6189 starting bit position so that it is aligned to ALIGN bits, and leaving at
6190 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
6191 record is guaranteed to get. */
6194 make_aligning_type (tree type
, unsigned int align
, tree size
,
6195 unsigned int base_align
, int room
)
6197 /* We will be crafting a record type with one field at a position set to be
6198 the next multiple of ALIGN past record'address + room bytes. We use a
6199 record placeholder to express record'address. */
6200 tree record_type
= make_node (RECORD_TYPE
);
6201 tree record
= build0 (PLACEHOLDER_EXPR
, record_type
);
6204 = convert (sizetype
, build_unary_op (ADDR_EXPR
, NULL_TREE
, record
));
6206 /* The diagram below summarizes the shape of what we manipulate:
6208 <--------- pos ---------->
6209 { +------------+-------------+-----------------+
6210 record =>{ |############| ... | field (type) |
6211 { +------------+-------------+-----------------+
6212 |<-- room -->|<- voffset ->|<---- size ----->|
6215 record_addr vblock_addr
6217 Every length is in sizetype bytes there, except "pos" which has to be
6218 set as a bit position in the GCC tree for the record. */
6219 tree room_st
= size_int (room
);
6220 tree vblock_addr_st
= size_binop (PLUS_EXPR
, record_addr_st
, room_st
);
6221 tree voffset_st
, pos
, field
;
6223 tree name
= TYPE_NAME (type
);
6225 if (TREE_CODE (name
) == TYPE_DECL
)
6226 name
= DECL_NAME (name
);
6227 name
= concat_name (name
, "ALIGN");
6228 TYPE_NAME (record_type
) = name
;
6230 /* Compute VOFFSET and then POS. The next byte position multiple of some
6231 alignment after some address is obtained by "and"ing the alignment minus
6232 1 with the two's complement of the address. */
6233 voffset_st
= size_binop (BIT_AND_EXPR
,
6234 fold_build1 (NEGATE_EXPR
, sizetype
, vblock_addr_st
),
6235 size_int ((align
/ BITS_PER_UNIT
) - 1));
6237 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
6238 pos
= size_binop (MULT_EXPR
,
6239 convert (bitsizetype
,
6240 size_binop (PLUS_EXPR
, room_st
, voffset_st
)),
6243 /* Craft the GCC record representation. We exceptionally do everything
6244 manually here because 1) our generic circuitry is not quite ready to
6245 handle the complex position/size expressions we are setting up, 2) we
6246 have a strong simplifying factor at hand: we know the maximum possible
6247 value of voffset, and 3) we have to set/reset at least the sizes in
6248 accordance with this maximum value anyway, as we need them to convey
6249 what should be "alloc"ated for this type.
6251 Use -1 as the 'addressable' indication for the field to prevent the
6252 creation of a bitfield. We don't need one, it would have damaging
6253 consequences on the alignment computation, and create_field_decl would
6254 make one without this special argument, for instance because of the
6255 complex position expression. */
6256 field
= create_field_decl (get_identifier ("F"), type
, record_type
, size
,
6258 TYPE_FIELDS (record_type
) = field
;
6260 TYPE_ALIGN (record_type
) = base_align
;
6261 TYPE_USER_ALIGN (record_type
) = 1;
6263 TYPE_SIZE (record_type
)
6264 = size_binop (PLUS_EXPR
,
6265 size_binop (MULT_EXPR
, convert (bitsizetype
, size
),
6267 bitsize_int (align
+ room
* BITS_PER_UNIT
));
6268 TYPE_SIZE_UNIT (record_type
)
6269 = size_binop (PLUS_EXPR
, size
,
6270 size_int (room
+ align
/ BITS_PER_UNIT
));
6272 SET_TYPE_MODE (record_type
, BLKmode
);
6273 relate_alias_sets (record_type
, type
, ALIAS_SET_COPY
);
6275 /* Declare it now since it will never be declared otherwise. This is
6276 necessary to ensure that its subtrees are properly marked. */
6277 create_type_decl (name
, record_type
, NULL
, true, false, Empty
);
6282 /* Return the result of rounding T up to ALIGN. */
6284 static inline unsigned HOST_WIDE_INT
6285 round_up_to_align (unsigned HOST_WIDE_INT t
, unsigned int align
)
6293 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
6294 as the field type of a packed record if IN_RECORD is true, or as the
6295 component type of a packed array if IN_RECORD is false. See if we can
6296 rewrite it either as a type that has a non-BLKmode, which we can pack
6297 tighter in the packed record case, or as a smaller type. If so, return
6298 the new type. If not, return the original type. */
6301 make_packable_type (tree type
, bool in_record
)
6303 unsigned HOST_WIDE_INT size
= tree_low_cst (TYPE_SIZE (type
), 1);
6304 unsigned HOST_WIDE_INT new_size
;
6305 tree new_type
, old_field
, field_list
= NULL_TREE
;
6307 /* No point in doing anything if the size is zero. */
6311 new_type
= make_node (TREE_CODE (type
));
6313 /* Copy the name and flags from the old type to that of the new.
6314 Note that we rely on the pointer equality created here for
6315 TYPE_NAME to look through conversions in various places. */
6316 TYPE_NAME (new_type
) = TYPE_NAME (type
);
6317 TYPE_JUSTIFIED_MODULAR_P (new_type
) = TYPE_JUSTIFIED_MODULAR_P (type
);
6318 TYPE_CONTAINS_TEMPLATE_P (new_type
) = TYPE_CONTAINS_TEMPLATE_P (type
);
6319 if (TREE_CODE (type
) == RECORD_TYPE
)
6320 TYPE_PADDING_P (new_type
) = TYPE_PADDING_P (type
);
6322 /* If we are in a record and have a small size, set the alignment to
6323 try for an integral mode. Otherwise set it to try for a smaller
6324 type with BLKmode. */
6325 if (in_record
&& size
<= MAX_FIXED_MODE_SIZE
)
6327 TYPE_ALIGN (new_type
) = ceil_alignment (size
);
6328 new_size
= round_up_to_align (size
, TYPE_ALIGN (new_type
));
6332 unsigned HOST_WIDE_INT align
;
6334 /* Do not try to shrink the size if the RM size is not constant. */
6335 if (TYPE_CONTAINS_TEMPLATE_P (type
)
6336 || !host_integerp (TYPE_ADA_SIZE (type
), 1))
6339 /* Round the RM size up to a unit boundary to get the minimal size
6340 for a BLKmode record. Give up if it's already the size. */
6341 new_size
= TREE_INT_CST_LOW (TYPE_ADA_SIZE (type
));
6342 new_size
= round_up_to_align (new_size
, BITS_PER_UNIT
);
6343 if (new_size
== size
)
6346 align
= new_size
& -new_size
;
6347 TYPE_ALIGN (new_type
) = MIN (TYPE_ALIGN (type
), align
);
6350 TYPE_USER_ALIGN (new_type
) = 1;
6352 /* Now copy the fields, keeping the position and size as we don't want
6353 to change the layout by propagating the packedness downwards. */
6354 for (old_field
= TYPE_FIELDS (type
); old_field
;
6355 old_field
= DECL_CHAIN (old_field
))
6357 tree new_field_type
= TREE_TYPE (old_field
);
6358 tree new_field
, new_size
;
6360 if ((TREE_CODE (new_field_type
) == RECORD_TYPE
6361 || TREE_CODE (new_field_type
) == UNION_TYPE
6362 || TREE_CODE (new_field_type
) == QUAL_UNION_TYPE
)
6363 && !TYPE_FAT_POINTER_P (new_field_type
)
6364 && host_integerp (TYPE_SIZE (new_field_type
), 1))
6365 new_field_type
= make_packable_type (new_field_type
, true);
6367 /* However, for the last field in a not already packed record type
6368 that is of an aggregate type, we need to use the RM size in the
6369 packable version of the record type, see finish_record_type. */
6370 if (!DECL_CHAIN (old_field
)
6371 && !TYPE_PACKED (type
)
6372 && (TREE_CODE (new_field_type
) == RECORD_TYPE
6373 || TREE_CODE (new_field_type
) == UNION_TYPE
6374 || TREE_CODE (new_field_type
) == QUAL_UNION_TYPE
)
6375 && !TYPE_FAT_POINTER_P (new_field_type
)
6376 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type
)
6377 && TYPE_ADA_SIZE (new_field_type
))
6378 new_size
= TYPE_ADA_SIZE (new_field_type
);
6380 new_size
= DECL_SIZE (old_field
);
6383 = create_field_decl (DECL_NAME (old_field
), new_field_type
, new_type
,
6384 new_size
, bit_position (old_field
),
6386 !DECL_NONADDRESSABLE_P (old_field
));
6388 DECL_INTERNAL_P (new_field
) = DECL_INTERNAL_P (old_field
);
6389 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field
, old_field
);
6390 if (TREE_CODE (new_type
) == QUAL_UNION_TYPE
)
6391 DECL_QUALIFIER (new_field
) = DECL_QUALIFIER (old_field
);
6393 DECL_CHAIN (new_field
) = field_list
;
6394 field_list
= new_field
;
6397 finish_record_type (new_type
, nreverse (field_list
), 2, false);
6398 relate_alias_sets (new_type
, type
, ALIAS_SET_COPY
);
6399 SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type
),
6400 DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type
)));
6402 /* If this is a padding record, we never want to make the size smaller
6403 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
6404 if (TYPE_IS_PADDING_P (type
) || TREE_CODE (type
) == QUAL_UNION_TYPE
)
6406 TYPE_SIZE (new_type
) = TYPE_SIZE (type
);
6407 TYPE_SIZE_UNIT (new_type
) = TYPE_SIZE_UNIT (type
);
6412 TYPE_SIZE (new_type
) = bitsize_int (new_size
);
6413 TYPE_SIZE_UNIT (new_type
)
6414 = size_int ((new_size
+ BITS_PER_UNIT
- 1) / BITS_PER_UNIT
);
6417 if (!TYPE_CONTAINS_TEMPLATE_P (type
))
6418 SET_TYPE_ADA_SIZE (new_type
, TYPE_ADA_SIZE (type
));
6420 compute_record_mode (new_type
);
6422 /* Try harder to get a packable type if necessary, for example
6423 in case the record itself contains a BLKmode field. */
6424 if (in_record
&& TYPE_MODE (new_type
) == BLKmode
)
6425 SET_TYPE_MODE (new_type
,
6426 mode_for_size_tree (TYPE_SIZE (new_type
), MODE_INT
, 1));
6428 /* If neither the mode nor the size has shrunk, return the old type. */
6429 if (TYPE_MODE (new_type
) == BLKmode
&& new_size
>= size
)
6435 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
6436 if needed. We have already verified that SIZE and TYPE are large enough.
6437 GNAT_ENTITY is used to name the resulting record and to issue a warning.
6438 IS_COMPONENT_TYPE is true if this is being done for the component type
6439 of an array. IS_USER_TYPE is true if we must complete the original type.
6440 DEFINITION is true if this type is being defined. SAME_RM_SIZE is true
6441 if the RM size of the resulting type is to be set to SIZE too; otherwise,
6442 it's set to the RM size of the original type. */
6445 maybe_pad_type (tree type
, tree size
, unsigned int align
,
6446 Entity_Id gnat_entity
, bool is_component_type
,
6447 bool is_user_type
, bool definition
, bool same_rm_size
)
6449 tree orig_rm_size
= same_rm_size
? NULL_TREE
: rm_size (type
);
6450 tree orig_size
= TYPE_SIZE (type
);
6453 /* If TYPE is a padded type, see if it agrees with any size and alignment
6454 we were given. If so, return the original type. Otherwise, strip
6455 off the padding, since we will either be returning the inner type
6456 or repadding it. If no size or alignment is specified, use that of
6457 the original padded type. */
6458 if (TYPE_IS_PADDING_P (type
))
6461 || operand_equal_p (round_up (size
,
6462 MAX (align
, TYPE_ALIGN (type
))),
6463 round_up (TYPE_SIZE (type
),
6464 MAX (align
, TYPE_ALIGN (type
))),
6466 && (align
== 0 || align
== TYPE_ALIGN (type
)))
6470 size
= TYPE_SIZE (type
);
6472 align
= TYPE_ALIGN (type
);
6474 type
= TREE_TYPE (TYPE_FIELDS (type
));
6475 orig_size
= TYPE_SIZE (type
);
6478 /* If the size is either not being changed or is being made smaller (which
6479 is not done here and is only valid for bitfields anyway), show the size
6480 isn't changing. Likewise, clear the alignment if it isn't being
6481 changed. Then return if we aren't doing anything. */
6483 && (operand_equal_p (size
, orig_size
, 0)
6484 || (TREE_CODE (orig_size
) == INTEGER_CST
6485 && tree_int_cst_lt (size
, orig_size
))))
6488 if (align
== TYPE_ALIGN (type
))
6491 if (align
== 0 && !size
)
6494 /* If requested, complete the original type and give it a name. */
6496 create_type_decl (get_entity_name (gnat_entity
), type
,
6497 NULL
, !Comes_From_Source (gnat_entity
),
6499 && TREE_CODE (TYPE_NAME (type
)) == TYPE_DECL
6500 && DECL_IGNORED_P (TYPE_NAME (type
))),
6503 /* We used to modify the record in place in some cases, but that could
6504 generate incorrect debugging information. So make a new record
6506 record
= make_node (RECORD_TYPE
);
6507 TYPE_PADDING_P (record
) = 1;
6509 if (Present (gnat_entity
))
6510 TYPE_NAME (record
) = create_concat_name (gnat_entity
, "PAD");
6512 TYPE_VOLATILE (record
)
6513 = Present (gnat_entity
) && Treat_As_Volatile (gnat_entity
);
6515 TYPE_ALIGN (record
) = align
;
6516 TYPE_SIZE (record
) = size
? size
: orig_size
;
6517 TYPE_SIZE_UNIT (record
)
6518 = convert (sizetype
,
6519 size_binop (CEIL_DIV_EXPR
, TYPE_SIZE (record
),
6520 bitsize_unit_node
));
6522 /* If we are changing the alignment and the input type is a record with
6523 BLKmode and a small constant size, try to make a form that has an
6524 integral mode. This might allow the padding record to also have an
6525 integral mode, which will be much more efficient. There is no point
6526 in doing so if a size is specified unless it is also a small constant
6527 size and it is incorrect to do so if we cannot guarantee that the mode
6528 will be naturally aligned since the field must always be addressable.
6530 ??? This might not always be a win when done for a stand-alone object:
6531 since the nominal and the effective type of the object will now have
6532 different modes, a VIEW_CONVERT_EXPR will be required for converting
6533 between them and it might be hard to overcome afterwards, including
6534 at the RTL level when the stand-alone object is accessed as a whole. */
6536 && TREE_CODE (type
) == RECORD_TYPE
6537 && TYPE_MODE (type
) == BLKmode
6538 && !TREE_ADDRESSABLE (type
)
6539 && TREE_CODE (orig_size
) == INTEGER_CST
6540 && !TREE_OVERFLOW (orig_size
)
6541 && compare_tree_int (orig_size
, MAX_FIXED_MODE_SIZE
) <= 0
6543 || (TREE_CODE (size
) == INTEGER_CST
6544 && compare_tree_int (size
, MAX_FIXED_MODE_SIZE
) <= 0)))
6546 tree packable_type
= make_packable_type (type
, true);
6547 if (TYPE_MODE (packable_type
) != BLKmode
6548 && align
>= TYPE_ALIGN (packable_type
))
6549 type
= packable_type
;
6552 /* Now create the field with the original size. */
6553 field
= create_field_decl (get_identifier ("F"), type
, record
, orig_size
,
6554 bitsize_zero_node
, 0, 1);
6555 DECL_INTERNAL_P (field
) = 1;
6557 /* Do not emit debug info until after the auxiliary record is built. */
6558 finish_record_type (record
, field
, 1, false);
6560 /* Set the same size for its RM size if requested; otherwise reuse
6561 the RM size of the original type. */
6562 SET_TYPE_ADA_SIZE (record
, same_rm_size
? size
: orig_rm_size
);
6564 /* Unless debugging information isn't being written for the input type,
6565 write a record that shows what we are a subtype of and also make a
6566 variable that indicates our size, if still variable. */
6567 if (TREE_CODE (orig_size
) != INTEGER_CST
6568 && TYPE_NAME (record
)
6570 && !(TREE_CODE (TYPE_NAME (type
)) == TYPE_DECL
6571 && DECL_IGNORED_P (TYPE_NAME (type
))))
6573 tree marker
= make_node (RECORD_TYPE
);
6574 tree name
= TYPE_NAME (record
);
6575 tree orig_name
= TYPE_NAME (type
);
6577 if (TREE_CODE (name
) == TYPE_DECL
)
6578 name
= DECL_NAME (name
);
6580 if (TREE_CODE (orig_name
) == TYPE_DECL
)
6581 orig_name
= DECL_NAME (orig_name
);
6583 TYPE_NAME (marker
) = concat_name (name
, "XVS");
6584 finish_record_type (marker
,
6585 create_field_decl (orig_name
,
6586 build_reference_type (type
),
6587 marker
, NULL_TREE
, NULL_TREE
,
6591 add_parallel_type (TYPE_STUB_DECL (record
), marker
);
6593 if (definition
&& size
&& TREE_CODE (size
) != INTEGER_CST
)
6594 TYPE_SIZE_UNIT (marker
)
6595 = create_var_decl (concat_name (name
, "XVZ"), NULL_TREE
, sizetype
,
6596 TYPE_SIZE_UNIT (record
), false, false, false,
6597 false, NULL
, gnat_entity
);
6600 rest_of_record_type_compilation (record
);
6602 /* If the size was widened explicitly, maybe give a warning. Take the
6603 original size as the maximum size of the input if there was an
6604 unconstrained record involved and round it up to the specified alignment,
6605 if one was specified. */
6606 if (CONTAINS_PLACEHOLDER_P (orig_size
))
6607 orig_size
= max_size (orig_size
, true);
6610 orig_size
= round_up (orig_size
, align
);
6612 if (Present (gnat_entity
)
6614 && TREE_CODE (size
) != MAX_EXPR
6615 && TREE_CODE (size
) != COND_EXPR
6616 && !operand_equal_p (size
, orig_size
, 0)
6617 && !(TREE_CODE (size
) == INTEGER_CST
6618 && TREE_CODE (orig_size
) == INTEGER_CST
6619 && (TREE_OVERFLOW (size
)
6620 || TREE_OVERFLOW (orig_size
)
6621 || tree_int_cst_lt (size
, orig_size
))))
6623 Node_Id gnat_error_node
= Empty
;
6625 if (Is_Packed_Array_Type (gnat_entity
))
6626 gnat_entity
= Original_Array_Type (gnat_entity
);
6628 if ((Ekind (gnat_entity
) == E_Component
6629 || Ekind (gnat_entity
) == E_Discriminant
)
6630 && Present (Component_Clause (gnat_entity
)))
6631 gnat_error_node
= Last_Bit (Component_Clause (gnat_entity
));
6632 else if (Present (Size_Clause (gnat_entity
)))
6633 gnat_error_node
= Expression (Size_Clause (gnat_entity
));
6635 /* Generate message only for entities that come from source, since
6636 if we have an entity created by expansion, the message will be
6637 generated for some other corresponding source entity. */
6638 if (Comes_From_Source (gnat_entity
))
6640 if (Present (gnat_error_node
))
6641 post_error_ne_tree ("{^ }bits of & unused?",
6642 gnat_error_node
, gnat_entity
,
6643 size_diffop (size
, orig_size
));
6644 else if (is_component_type
)
6645 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6646 gnat_entity
, gnat_entity
,
6647 size_diffop (size
, orig_size
));
6654 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6655 the value passed against the list of choices. */
6658 choices_to_gnu (tree operand
, Node_Id choices
)
6662 tree result
= boolean_false_node
;
6663 tree this_test
, low
= 0, high
= 0, single
= 0;
6665 for (choice
= First (choices
); Present (choice
); choice
= Next (choice
))
6667 switch (Nkind (choice
))
6670 low
= gnat_to_gnu (Low_Bound (choice
));
6671 high
= gnat_to_gnu (High_Bound (choice
));
6674 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6675 build_binary_op (GE_EXPR
, boolean_type_node
,
6677 build_binary_op (LE_EXPR
, boolean_type_node
,
6682 case N_Subtype_Indication
:
6683 gnat_temp
= Range_Expression (Constraint (choice
));
6684 low
= gnat_to_gnu (Low_Bound (gnat_temp
));
6685 high
= gnat_to_gnu (High_Bound (gnat_temp
));
6688 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6689 build_binary_op (GE_EXPR
, boolean_type_node
,
6691 build_binary_op (LE_EXPR
, boolean_type_node
,
6696 case N_Expanded_Name
:
6697 /* This represents either a subtype range, an enumeration
6698 literal, or a constant Ekind says which. If an enumeration
6699 literal or constant, fall through to the next case. */
6700 if (Ekind (Entity (choice
)) != E_Enumeration_Literal
6701 && Ekind (Entity (choice
)) != E_Constant
)
6703 tree type
= gnat_to_gnu_type (Entity (choice
));
6705 low
= TYPE_MIN_VALUE (type
);
6706 high
= TYPE_MAX_VALUE (type
);
6709 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6710 build_binary_op (GE_EXPR
, boolean_type_node
,
6712 build_binary_op (LE_EXPR
, boolean_type_node
,
6717 /* ... fall through ... */
6719 case N_Character_Literal
:
6720 case N_Integer_Literal
:
6721 single
= gnat_to_gnu (choice
);
6722 this_test
= build_binary_op (EQ_EXPR
, boolean_type_node
, operand
,
6726 case N_Others_Choice
:
6727 this_test
= boolean_true_node
;
6734 result
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, result
,
6741 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6742 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6745 adjust_packed (tree field_type
, tree record_type
, int packed
)
6747 /* If the field contains an item of variable size, we cannot pack it
6748 because we cannot create temporaries of non-fixed size in case
6749 we need to take the address of the field. See addressable_p and
6750 the notes on the addressability issues for further details. */
6751 if (is_variable_size (field_type
))
6754 /* If the alignment of the record is specified and the field type
6755 is over-aligned, request Storage_Unit alignment for the field. */
6758 if (TYPE_ALIGN (field_type
) > TYPE_ALIGN (record_type
))
6767 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6768 placed in GNU_RECORD_TYPE.
6770 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6771 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6772 record has a specified alignment.
6774 DEFINITION is true if this field is for a record being defined.
6776 DEBUG_INFO_P is true if we need to write debug information for types
6777 that we may create in the process. */
6780 gnat_to_gnu_field (Entity_Id gnat_field
, tree gnu_record_type
, int packed
,
6781 bool definition
, bool debug_info_p
)
6783 const Entity_Id gnat_field_type
= Etype (gnat_field
);
6784 tree gnu_field_type
= gnat_to_gnu_type (gnat_field_type
);
6785 tree gnu_field_id
= get_entity_name (gnat_field
);
6786 tree gnu_field
, gnu_size
, gnu_pos
;
6788 = (Treat_As_Volatile (gnat_field
) || Treat_As_Volatile (gnat_field_type
));
6789 bool needs_strict_alignment
6791 || Is_Aliased (gnat_field
)
6792 || Strict_Alignment (gnat_field_type
));
6794 /* If this field requires strict alignment, we cannot pack it because
6795 it would very likely be under-aligned in the record. */
6796 if (needs_strict_alignment
)
6799 packed
= adjust_packed (gnu_field_type
, gnu_record_type
, packed
);
6801 /* If a size is specified, use it. Otherwise, if the record type is packed,
6802 use the official RM size. See "Handling of Type'Size Values" in Einfo
6803 for further details. */
6804 if (Known_Esize (gnat_field
))
6805 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6806 gnat_field
, FIELD_DECL
, false, true);
6807 else if (packed
== 1)
6808 gnu_size
= validate_size (RM_Size (gnat_field_type
), gnu_field_type
,
6809 gnat_field
, FIELD_DECL
, false, true);
6811 gnu_size
= NULL_TREE
;
6813 /* If we have a specified size that is smaller than that of the field's type,
6814 or a position is specified, and the field's type is a record that doesn't
6815 require strict alignment, see if we can get either an integral mode form
6816 of the type or a smaller form. If we can, show a size was specified for
6817 the field if there wasn't one already, so we know to make this a bitfield
6818 and avoid making things wider.
6820 Changing to an integral mode form is useful when the record is packed as
6821 we can then place the field at a non-byte-aligned position and so achieve
6822 tighter packing. This is in addition required if the field shares a byte
6823 with another field and the front-end lets the back-end handle the access
6824 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6826 Changing to a smaller form is required if the specified size is smaller
6827 than that of the field's type and the type contains sub-fields that are
6828 padded, in order to avoid generating accesses to these sub-fields that
6829 are wider than the field.
6831 We avoid the transformation if it is not required or potentially useful,
6832 as it might entail an increase of the field's alignment and have ripple
6833 effects on the outer record type. A typical case is a field known to be
6834 byte-aligned and not to share a byte with another field. */
6835 if (!needs_strict_alignment
6836 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
6837 && !TYPE_FAT_POINTER_P (gnu_field_type
)
6838 && host_integerp (TYPE_SIZE (gnu_field_type
), 1)
6841 && (tree_int_cst_lt (gnu_size
, TYPE_SIZE (gnu_field_type
))
6842 || (Present (Component_Clause (gnat_field
))
6843 && !(UI_To_Int (Component_Bit_Offset (gnat_field
))
6844 % BITS_PER_UNIT
== 0
6845 && value_factor_p (gnu_size
, BITS_PER_UNIT
)))))))
6847 tree gnu_packable_type
= make_packable_type (gnu_field_type
, true);
6848 if (gnu_packable_type
!= gnu_field_type
)
6850 gnu_field_type
= gnu_packable_type
;
6852 gnu_size
= rm_size (gnu_field_type
);
6856 if (Is_Atomic (gnat_field
))
6857 check_ok_for_atomic (gnu_field_type
, gnat_field
, false);
6859 if (Present (Component_Clause (gnat_field
)))
6861 Entity_Id gnat_parent
6862 = Parent_Subtype (Underlying_Type (Scope (gnat_field
)));
6864 gnu_pos
= UI_To_gnu (Component_Bit_Offset (gnat_field
), bitsizetype
);
6865 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6866 gnat_field
, FIELD_DECL
, false, true);
6868 /* Ensure the position does not overlap with the parent subtype, if there
6869 is one. This test is omitted if the parent of the tagged type has a
6870 full rep clause since, in this case, component clauses are allowed to
6871 overlay the space allocated for the parent type and the front-end has
6872 checked that there are no overlapping components. */
6873 if (Present (gnat_parent
) && !Is_Fully_Repped_Tagged_Type (gnat_parent
))
6875 tree gnu_parent
= gnat_to_gnu_type (gnat_parent
);
6877 if (TREE_CODE (TYPE_SIZE (gnu_parent
)) == INTEGER_CST
6878 && tree_int_cst_lt (gnu_pos
, TYPE_SIZE (gnu_parent
)))
6881 ("offset of& must be beyond parent{, minimum allowed is ^}",
6882 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6883 TYPE_SIZE_UNIT (gnu_parent
));
6887 /* If this field needs strict alignment, ensure the record is
6888 sufficiently aligned and that that position and size are
6889 consistent with the alignment. */
6890 if (needs_strict_alignment
)
6892 TYPE_ALIGN (gnu_record_type
)
6893 = MAX (TYPE_ALIGN (gnu_record_type
), TYPE_ALIGN (gnu_field_type
));
6896 && !operand_equal_p (gnu_size
, TYPE_SIZE (gnu_field_type
), 0))
6898 if (Is_Atomic (gnat_field
) || Is_Atomic (gnat_field_type
))
6900 ("atomic field& must be natural size of type{ (^)}",
6901 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6902 TYPE_SIZE (gnu_field_type
));
6904 else if (Is_Aliased (gnat_field
))
6906 ("size of aliased field& must be ^ bits",
6907 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6908 TYPE_SIZE (gnu_field_type
));
6910 else if (Strict_Alignment (gnat_field_type
))
6912 ("size of & with aliased or tagged components not ^ bits",
6913 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6914 TYPE_SIZE (gnu_field_type
));
6916 gnu_size
= NULL_TREE
;
6919 if (!integer_zerop (size_binop
6920 (TRUNC_MOD_EXPR
, gnu_pos
,
6921 bitsize_int (TYPE_ALIGN (gnu_field_type
)))))
6925 ("position of volatile field& must be multiple of ^ bits",
6926 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6927 TYPE_ALIGN (gnu_field_type
));
6929 else if (Is_Aliased (gnat_field
))
6931 ("position of aliased field& must be multiple of ^ bits",
6932 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6933 TYPE_ALIGN (gnu_field_type
));
6935 else if (Strict_Alignment (gnat_field_type
))
6937 ("position of & with aliased or tagged components not multiple of ^ bits",
6938 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6939 TYPE_ALIGN (gnu_field_type
));
6944 gnu_pos
= NULL_TREE
;
6949 /* If the record has rep clauses and this is the tag field, make a rep
6950 clause for it as well. */
6951 else if (Has_Specified_Layout (Scope (gnat_field
))
6952 && Chars (gnat_field
) == Name_uTag
)
6954 gnu_pos
= bitsize_zero_node
;
6955 gnu_size
= TYPE_SIZE (gnu_field_type
);
6960 gnu_pos
= NULL_TREE
;
6962 /* If we are packing the record and the field is BLKmode, round the
6963 size up to a byte boundary. */
6964 if (packed
&& TYPE_MODE (gnu_field_type
) == BLKmode
&& gnu_size
)
6965 gnu_size
= round_up (gnu_size
, BITS_PER_UNIT
);
6968 /* We need to make the size the maximum for the type if it is
6969 self-referential and an unconstrained type. In that case, we can't
6970 pack the field since we can't make a copy to align it. */
6971 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
6973 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type
))
6974 && !Is_Constrained (Underlying_Type (gnat_field_type
)))
6976 gnu_size
= max_size (TYPE_SIZE (gnu_field_type
), true);
6980 /* If a size is specified, adjust the field's type to it. */
6983 tree orig_field_type
;
6985 /* If the field's type is justified modular, we would need to remove
6986 the wrapper to (better) meet the layout requirements. However we
6987 can do so only if the field is not aliased to preserve the unique
6988 layout and if the prescribed size is not greater than that of the
6989 packed array to preserve the justification. */
6990 if (!needs_strict_alignment
6991 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
6992 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
6993 && tree_int_cst_compare (gnu_size
, TYPE_ADA_SIZE (gnu_field_type
))
6995 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
6998 = make_type_from_size (gnu_field_type
, gnu_size
,
6999 Has_Biased_Representation (gnat_field
));
7001 orig_field_type
= gnu_field_type
;
7002 gnu_field_type
= maybe_pad_type (gnu_field_type
, gnu_size
, 0, gnat_field
,
7003 false, false, definition
, true);
7005 /* If a padding record was made, declare it now since it will never be
7006 declared otherwise. This is necessary to ensure that its subtrees
7007 are properly marked. */
7008 if (gnu_field_type
!= orig_field_type
7009 && !DECL_P (TYPE_NAME (gnu_field_type
)))
7010 create_type_decl (TYPE_NAME (gnu_field_type
), gnu_field_type
, NULL
,
7011 true, debug_info_p
, gnat_field
);
7014 /* Otherwise (or if there was an error), don't specify a position. */
7016 gnu_pos
= NULL_TREE
;
7018 gcc_assert (TREE_CODE (gnu_field_type
) != RECORD_TYPE
7019 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type
));
7021 /* Now create the decl for the field. */
7023 = create_field_decl (gnu_field_id
, gnu_field_type
, gnu_record_type
,
7024 gnu_size
, gnu_pos
, packed
, Is_Aliased (gnat_field
));
7025 Sloc_to_locus (Sloc (gnat_field
), &DECL_SOURCE_LOCATION (gnu_field
));
7026 TREE_THIS_VOLATILE (gnu_field
) = TREE_SIDE_EFFECTS (gnu_field
) = is_volatile
;
7028 if (Ekind (gnat_field
) == E_Discriminant
)
7029 DECL_DISCRIMINANT_NUMBER (gnu_field
)
7030 = UI_To_gnu (Discriminant_Number (gnat_field
), sizetype
);
7035 /* Return true if TYPE is a type with variable size, a padding type with a
7036 field of variable size or is a record that has a field such a field. */
7039 is_variable_size (tree type
)
7043 if (!TREE_CONSTANT (TYPE_SIZE (type
)))
7046 if (TYPE_IS_PADDING_P (type
)
7047 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type
))))
7050 if (TREE_CODE (type
) != RECORD_TYPE
7051 && TREE_CODE (type
) != UNION_TYPE
7052 && TREE_CODE (type
) != QUAL_UNION_TYPE
)
7055 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
7056 if (is_variable_size (TREE_TYPE (field
)))
7062 /* qsort comparer for the bit positions of two record components. */
7065 compare_field_bitpos (const PTR rt1
, const PTR rt2
)
7067 const_tree
const field1
= * (const_tree
const *) rt1
;
7068 const_tree
const field2
= * (const_tree
const *) rt2
;
7070 = tree_int_cst_compare (bit_position (field1
), bit_position (field2
));
7072 return ret
? ret
: (int) (DECL_UID (field1
) - DECL_UID (field2
));
7075 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
7076 the result as the field list of GNU_RECORD_TYPE and finish it up. When
7077 called from gnat_to_gnu_entity during the processing of a record type
7078 definition, the GCC node for the parent, if any, will be the single field
7079 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
7080 GNU_FIELD_LIST. The other calls to this function are recursive calls for
7081 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
7083 PACKED is 1 if this is for a packed record, -1 if this is for a record
7084 with Component_Alignment of Storage_Unit, -2 if this is for a record
7085 with a specified alignment.
7087 DEFINITION is true if we are defining this record type.
7089 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
7090 out the record. This means the alignment only serves to force fields to
7091 be bitfields, but not to require the record to be that aligned. This is
7094 ALL_REP is true if a rep clause is present for all the fields.
7096 UNCHECKED_UNION is true if we are building this type for a record with a
7097 Pragma Unchecked_Union.
7099 DEBUG_INFO is true if we need to write debug information about the type.
7101 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
7102 mean that its contents may be unused as well, only the container itself.
7104 REORDER is true if we are permitted to reorder components of this type.
7106 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
7107 with a rep clause is to be added; in this case, that is all that should
7108 be done with such fields. */
7111 components_to_record (tree gnu_record_type
, Node_Id gnat_component_list
,
7112 tree gnu_field_list
, int packed
, bool definition
,
7113 bool cancel_alignment
, bool all_rep
,
7114 bool unchecked_union
, bool debug_info
,
7115 bool maybe_unused
, bool reorder
,
7116 tree
*p_gnu_rep_list
)
7118 bool all_rep_and_size
= all_rep
&& TYPE_SIZE (gnu_record_type
);
7119 bool layout_with_rep
= false;
7120 Node_Id component_decl
, variant_part
;
7121 tree gnu_field
, gnu_next
, gnu_last
;
7122 tree gnu_variant_part
= NULL_TREE
;
7123 tree gnu_rep_list
= NULL_TREE
;
7124 tree gnu_var_list
= NULL_TREE
;
7125 tree gnu_self_list
= NULL_TREE
;
7127 /* For each component referenced in a component declaration create a GCC
7128 field and add it to the list, skipping pragmas in the GNAT list. */
7129 gnu_last
= tree_last (gnu_field_list
);
7130 if (Present (Component_Items (gnat_component_list
)))
7132 = First_Non_Pragma (Component_Items (gnat_component_list
));
7133 Present (component_decl
);
7134 component_decl
= Next_Non_Pragma (component_decl
))
7136 Entity_Id gnat_field
= Defining_Entity (component_decl
);
7137 Name_Id gnat_name
= Chars (gnat_field
);
7139 /* If present, the _Parent field must have been created as the single
7140 field of the record type. Put it before any other fields. */
7141 if (gnat_name
== Name_uParent
)
7143 gnu_field
= TYPE_FIELDS (gnu_record_type
);
7144 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
7148 gnu_field
= gnat_to_gnu_field (gnat_field
, gnu_record_type
, packed
,
7149 definition
, debug_info
);
7151 /* If this is the _Tag field, put it before any other fields. */
7152 if (gnat_name
== Name_uTag
)
7153 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
7155 /* If this is the _Controller field, put it before the other
7156 fields except for the _Tag or _Parent field. */
7157 else if (gnat_name
== Name_uController
&& gnu_last
)
7159 DECL_CHAIN (gnu_field
) = DECL_CHAIN (gnu_last
);
7160 DECL_CHAIN (gnu_last
) = gnu_field
;
7163 /* If this is a regular field, put it after the other fields. */
7166 DECL_CHAIN (gnu_field
) = gnu_field_list
;
7167 gnu_field_list
= gnu_field
;
7169 gnu_last
= gnu_field
;
7173 save_gnu_tree (gnat_field
, gnu_field
, false);
7176 /* At the end of the component list there may be a variant part. */
7177 variant_part
= Variant_Part (gnat_component_list
);
7179 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7180 mutually exclusive and should go in the same memory. To do this we need
7181 to treat each variant as a record whose elements are created from the
7182 component list for the variant. So here we create the records from the
7183 lists for the variants and put them all into the QUAL_UNION_TYPE.
7184 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7185 use GNU_RECORD_TYPE if there are no fields so far. */
7186 if (Present (variant_part
))
7188 Node_Id gnat_discr
= Name (variant_part
), variant
;
7189 tree gnu_discr
= gnat_to_gnu (gnat_discr
);
7190 tree gnu_name
= TYPE_NAME (gnu_record_type
);
7192 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr
))),
7194 tree gnu_union_type
, gnu_union_name
;
7195 tree gnu_variant_list
= NULL_TREE
;
7197 if (TREE_CODE (gnu_name
) == TYPE_DECL
)
7198 gnu_name
= DECL_NAME (gnu_name
);
7201 = concat_name (gnu_name
, IDENTIFIER_POINTER (gnu_var_name
));
7203 /* Reuse an enclosing union if all fields are in the variant part
7204 and there is no representation clause on the record, to match
7205 the layout of C unions. There is an associated check below. */
7207 && TREE_CODE (gnu_record_type
) == UNION_TYPE
7208 && !TYPE_PACKED (gnu_record_type
))
7209 gnu_union_type
= gnu_record_type
;
7213 = make_node (unchecked_union
? UNION_TYPE
: QUAL_UNION_TYPE
);
7215 TYPE_NAME (gnu_union_type
) = gnu_union_name
;
7216 TYPE_ALIGN (gnu_union_type
) = 0;
7217 TYPE_PACKED (gnu_union_type
) = TYPE_PACKED (gnu_record_type
);
7220 for (variant
= First_Non_Pragma (Variants (variant_part
));
7222 variant
= Next_Non_Pragma (variant
))
7224 tree gnu_variant_type
= make_node (RECORD_TYPE
);
7225 tree gnu_inner_name
;
7228 Get_Variant_Encoding (variant
);
7229 gnu_inner_name
= get_identifier_with_length (Name_Buffer
, Name_Len
);
7230 TYPE_NAME (gnu_variant_type
)
7231 = concat_name (gnu_union_name
,
7232 IDENTIFIER_POINTER (gnu_inner_name
));
7234 /* Set the alignment of the inner type in case we need to make
7235 inner objects into bitfields, but then clear it out so the
7236 record actually gets only the alignment required. */
7237 TYPE_ALIGN (gnu_variant_type
) = TYPE_ALIGN (gnu_record_type
);
7238 TYPE_PACKED (gnu_variant_type
) = TYPE_PACKED (gnu_record_type
);
7240 /* Similarly, if the outer record has a size specified and all
7241 fields have record rep clauses, we can propagate the size
7242 into the variant part. */
7243 if (all_rep_and_size
)
7245 TYPE_SIZE (gnu_variant_type
) = TYPE_SIZE (gnu_record_type
);
7246 TYPE_SIZE_UNIT (gnu_variant_type
)
7247 = TYPE_SIZE_UNIT (gnu_record_type
);
7250 /* Add the fields into the record type for the variant. Note that
7251 we aren't sure to really use it at this point, see below. */
7252 components_to_record (gnu_variant_type
, Component_List (variant
),
7253 NULL_TREE
, packed
, definition
,
7254 !all_rep_and_size
, all_rep
,
7255 unchecked_union
, debug_info
,
7256 true, reorder
, &gnu_rep_list
);
7258 gnu_qual
= choices_to_gnu (gnu_discr
, Discrete_Choices (variant
));
7260 Set_Present_Expr (variant
, annotate_value (gnu_qual
));
7262 /* If this is an Unchecked_Union and we have exactly one field,
7263 use this field directly to match the layout of C unions. */
7265 && TYPE_FIELDS (gnu_variant_type
)
7266 && !DECL_CHAIN (TYPE_FIELDS (gnu_variant_type
)))
7267 gnu_field
= TYPE_FIELDS (gnu_variant_type
);
7270 /* Deal with packedness like in gnat_to_gnu_field. */
7272 = adjust_packed (gnu_variant_type
, gnu_record_type
, packed
);
7274 /* Finalize the record type now. We used to throw away
7275 empty records but we no longer do that because we need
7276 them to generate complete debug info for the variant;
7277 otherwise, the union type definition will be lacking
7278 the fields associated with these empty variants. */
7279 rest_of_record_type_compilation (gnu_variant_type
);
7280 create_type_decl (TYPE_NAME (gnu_variant_type
), gnu_variant_type
,
7281 NULL
, true, debug_info
, gnat_component_list
);
7284 = create_field_decl (gnu_inner_name
, gnu_variant_type
,
7287 ? TYPE_SIZE (gnu_variant_type
) : 0,
7289 ? bitsize_zero_node
: 0,
7292 DECL_INTERNAL_P (gnu_field
) = 1;
7294 if (!unchecked_union
)
7295 DECL_QUALIFIER (gnu_field
) = gnu_qual
;
7298 DECL_CHAIN (gnu_field
) = gnu_variant_list
;
7299 gnu_variant_list
= gnu_field
;
7302 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7303 if (gnu_variant_list
)
7305 int union_field_packed
;
7307 if (all_rep_and_size
)
7309 TYPE_SIZE (gnu_union_type
) = TYPE_SIZE (gnu_record_type
);
7310 TYPE_SIZE_UNIT (gnu_union_type
)
7311 = TYPE_SIZE_UNIT (gnu_record_type
);
7314 finish_record_type (gnu_union_type
, nreverse (gnu_variant_list
),
7315 all_rep_and_size
? 1 : 0, debug_info
);
7317 /* If GNU_UNION_TYPE is our record type, it means we must have an
7318 Unchecked_Union with no fields. Verify that and, if so, just
7320 if (gnu_union_type
== gnu_record_type
)
7322 gcc_assert (unchecked_union
7328 create_type_decl (TYPE_NAME (gnu_union_type
), gnu_union_type
,
7329 NULL
, true, debug_info
, gnat_component_list
);
7331 /* Deal with packedness like in gnat_to_gnu_field. */
7333 = adjust_packed (gnu_union_type
, gnu_record_type
, packed
);
7336 = create_field_decl (gnu_var_name
, gnu_union_type
, gnu_record_type
,
7337 all_rep
? TYPE_SIZE (gnu_union_type
) : 0,
7338 all_rep
? bitsize_zero_node
: 0,
7339 union_field_packed
, 0);
7341 DECL_INTERNAL_P (gnu_variant_part
) = 1;
7342 DECL_CHAIN (gnu_variant_part
) = gnu_field_list
;
7343 gnu_field_list
= gnu_variant_part
;
7347 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
7348 permitted to reorder components, self-referential sizes or variable sizes.
7349 If they do, pull them out and put them onto the appropriate list. We have
7350 to do this in a separate pass since we want to handle the discriminants
7351 but can't play with them until we've used them in debugging data above.
7353 ??? If we reorder them, debugging information will be wrong but there is
7354 nothing that can be done about this at the moment. */
7355 gnu_last
= NULL_TREE
;
7357 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7360 DECL_CHAIN (gnu_last) = gnu_next; \
7362 gnu_field_list = gnu_next; \
7364 DECL_CHAIN (gnu_field) = (LIST); \
7365 (LIST) = gnu_field; \
7368 for (gnu_field
= gnu_field_list
; gnu_field
; gnu_field
= gnu_next
)
7370 gnu_next
= DECL_CHAIN (gnu_field
);
7372 if (DECL_FIELD_OFFSET (gnu_field
))
7374 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list
);
7380 /* Pull out the variant part and put it onto GNU_SELF_LIST. */
7381 if (gnu_field
== gnu_variant_part
)
7383 MOVE_FROM_FIELD_LIST_TO (gnu_self_list
);
7387 /* Skip internal fields and fields with fixed size. */
7388 if (!DECL_INTERNAL_P (gnu_field
)
7389 && !(DECL_SIZE (gnu_field
)
7390 && TREE_CODE (DECL_SIZE (gnu_field
)) == INTEGER_CST
))
7392 tree type_size
= TYPE_SIZE (TREE_TYPE (gnu_field
));
7394 if (CONTAINS_PLACEHOLDER_P (type_size
))
7396 MOVE_FROM_FIELD_LIST_TO (gnu_self_list
);
7400 if (TREE_CODE (type_size
) != INTEGER_CST
)
7402 MOVE_FROM_FIELD_LIST_TO (gnu_var_list
);
7408 gnu_last
= gnu_field
;
7411 #undef MOVE_FROM_FIELD_LIST_TO
7413 /* If permitted, we reorder the components as follows:
7415 1) all fixed length fields,
7416 2) all fields whose length doesn't depend on discriminants,
7417 3) all fields whose length depends on discriminants,
7418 4) the variant part,
7420 within the record and within each variant recursively. */
7423 = chainon (nreverse (gnu_self_list
),
7424 chainon (nreverse (gnu_var_list
), gnu_field_list
));
7426 /* If we have any fields in our rep'ed field list and it is not the case that
7427 all the fields in the record have rep clauses and P_REP_LIST is nonzero,
7428 set it and ignore these fields. */
7429 if (gnu_rep_list
&& p_gnu_rep_list
&& !all_rep
)
7430 *p_gnu_rep_list
= chainon (*p_gnu_rep_list
, gnu_rep_list
);
7432 /* Otherwise, sort the fields by bit position and put them into their own
7433 record, before the others, if we also have fields without rep clauses. */
7434 else if (gnu_rep_list
)
7437 = (gnu_field_list
? make_node (RECORD_TYPE
) : gnu_record_type
);
7438 int i
, len
= list_length (gnu_rep_list
);
7439 tree
*gnu_arr
= XALLOCAVEC (tree
, len
);
7441 for (gnu_field
= gnu_rep_list
, i
= 0;
7443 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
7444 gnu_arr
[i
] = gnu_field
;
7446 qsort (gnu_arr
, len
, sizeof (tree
), compare_field_bitpos
);
7448 /* Put the fields in the list in order of increasing position, which
7449 means we start from the end. */
7450 gnu_rep_list
= NULL_TREE
;
7451 for (i
= len
- 1; i
>= 0; i
--)
7453 DECL_CHAIN (gnu_arr
[i
]) = gnu_rep_list
;
7454 gnu_rep_list
= gnu_arr
[i
];
7455 DECL_CONTEXT (gnu_arr
[i
]) = gnu_rep_type
;
7460 finish_record_type (gnu_rep_type
, gnu_rep_list
, 1, debug_info
);
7462 = create_field_decl (get_identifier ("REP"), gnu_rep_type
,
7463 gnu_record_type
, NULL_TREE
, NULL_TREE
, 0, 1);
7464 DECL_INTERNAL_P (gnu_field
) = 1;
7465 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
7469 layout_with_rep
= true;
7470 gnu_field_list
= nreverse (gnu_rep_list
);
7474 if (cancel_alignment
)
7475 TYPE_ALIGN (gnu_record_type
) = 0;
7477 finish_record_type (gnu_record_type
, nreverse (gnu_field_list
),
7478 layout_with_rep
? 1 : 0, debug_info
&& !maybe_unused
);
7481 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7482 placed into an Esize, Component_Bit_Offset, or Component_Size value
7483 in the GNAT tree. */
7486 annotate_value (tree gnu_size
)
7489 Node_Ref_Or_Val ops
[3], ret
;
7490 struct tree_int_map in
;
7493 /* See if we've already saved the value for this node. */
7494 if (EXPR_P (gnu_size
))
7496 struct tree_int_map
*e
;
7498 if (!annotate_value_cache
)
7499 annotate_value_cache
= htab_create_ggc (512, tree_int_map_hash
,
7500 tree_int_map_eq
, 0);
7501 in
.base
.from
= gnu_size
;
7502 e
= (struct tree_int_map
*)
7503 htab_find (annotate_value_cache
, &in
);
7506 return (Node_Ref_Or_Val
) e
->to
;
7509 in
.base
.from
= NULL_TREE
;
7511 /* If we do not return inside this switch, TCODE will be set to the
7512 code to use for a Create_Node operand and LEN (set above) will be
7513 the number of recursive calls for us to make. */
7515 switch (TREE_CODE (gnu_size
))
7518 if (TREE_OVERFLOW (gnu_size
))
7521 /* This may come from a conversion from some smaller type, so ensure
7522 this is in bitsizetype. */
7523 gnu_size
= convert (bitsizetype
, gnu_size
);
7525 /* For a negative value, build NEGATE_EXPR of the opposite. Such values
7526 appear in expressions containing aligning patterns. Note that, since
7527 sizetype is sign-extended but nonetheless unsigned, we don't directly
7528 use tree_int_cst_sgn. */
7529 if (TREE_INT_CST_HIGH (gnu_size
) < 0)
7531 tree op_size
= fold_build1 (NEGATE_EXPR
, bitsizetype
, gnu_size
);
7532 return annotate_value (build1 (NEGATE_EXPR
, bitsizetype
, op_size
));
7535 return UI_From_gnu (gnu_size
);
7538 /* The only case we handle here is a simple discriminant reference. */
7539 if (TREE_CODE (TREE_OPERAND (gnu_size
, 0)) == PLACEHOLDER_EXPR
7540 && TREE_CODE (TREE_OPERAND (gnu_size
, 1)) == FIELD_DECL
7541 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size
, 1)))
7542 return Create_Node (Discrim_Val
,
7543 annotate_value (DECL_DISCRIMINANT_NUMBER
7544 (TREE_OPERAND (gnu_size
, 1))),
7549 CASE_CONVERT
: case NON_LVALUE_EXPR
:
7550 return annotate_value (TREE_OPERAND (gnu_size
, 0));
7552 /* Now just list the operations we handle. */
7553 case COND_EXPR
: tcode
= Cond_Expr
; break;
7554 case PLUS_EXPR
: tcode
= Plus_Expr
; break;
7555 case MINUS_EXPR
: tcode
= Minus_Expr
; break;
7556 case MULT_EXPR
: tcode
= Mult_Expr
; break;
7557 case TRUNC_DIV_EXPR
: tcode
= Trunc_Div_Expr
; break;
7558 case CEIL_DIV_EXPR
: tcode
= Ceil_Div_Expr
; break;
7559 case FLOOR_DIV_EXPR
: tcode
= Floor_Div_Expr
; break;
7560 case TRUNC_MOD_EXPR
: tcode
= Trunc_Mod_Expr
; break;
7561 case CEIL_MOD_EXPR
: tcode
= Ceil_Mod_Expr
; break;
7562 case FLOOR_MOD_EXPR
: tcode
= Floor_Mod_Expr
; break;
7563 case EXACT_DIV_EXPR
: tcode
= Exact_Div_Expr
; break;
7564 case NEGATE_EXPR
: tcode
= Negate_Expr
; break;
7565 case MIN_EXPR
: tcode
= Min_Expr
; break;
7566 case MAX_EXPR
: tcode
= Max_Expr
; break;
7567 case ABS_EXPR
: tcode
= Abs_Expr
; break;
7568 case TRUTH_ANDIF_EXPR
: tcode
= Truth_Andif_Expr
; break;
7569 case TRUTH_ORIF_EXPR
: tcode
= Truth_Orif_Expr
; break;
7570 case TRUTH_AND_EXPR
: tcode
= Truth_And_Expr
; break;
7571 case TRUTH_OR_EXPR
: tcode
= Truth_Or_Expr
; break;
7572 case TRUTH_XOR_EXPR
: tcode
= Truth_Xor_Expr
; break;
7573 case TRUTH_NOT_EXPR
: tcode
= Truth_Not_Expr
; break;
7574 case BIT_AND_EXPR
: tcode
= Bit_And_Expr
; break;
7575 case LT_EXPR
: tcode
= Lt_Expr
; break;
7576 case LE_EXPR
: tcode
= Le_Expr
; break;
7577 case GT_EXPR
: tcode
= Gt_Expr
; break;
7578 case GE_EXPR
: tcode
= Ge_Expr
; break;
7579 case EQ_EXPR
: tcode
= Eq_Expr
; break;
7580 case NE_EXPR
: tcode
= Ne_Expr
; break;
7584 tree t
= maybe_inline_call_in_expr (gnu_size
);
7586 return annotate_value (t
);
7589 /* Fall through... */
7595 /* Now get each of the operands that's relevant for this code. If any
7596 cannot be expressed as a repinfo node, say we can't. */
7597 for (i
= 0; i
< 3; i
++)
7600 for (i
= 0; i
< TREE_CODE_LENGTH (TREE_CODE (gnu_size
)); i
++)
7602 ops
[i
] = annotate_value (TREE_OPERAND (gnu_size
, i
));
7603 if (ops
[i
] == No_Uint
)
7607 ret
= Create_Node (tcode
, ops
[0], ops
[1], ops
[2]);
7609 /* Save the result in the cache. */
7612 struct tree_int_map
**h
;
7613 /* We can't assume the hash table data hasn't moved since the
7614 initial look up, so we have to search again. Allocating and
7615 inserting an entry at that point would be an alternative, but
7616 then we'd better discard the entry if we decided not to cache
7618 h
= (struct tree_int_map
**)
7619 htab_find_slot (annotate_value_cache
, &in
, INSERT
);
7621 *h
= ggc_alloc_tree_int_map ();
7622 (*h
)->base
.from
= gnu_size
;
7629 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7630 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7631 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7632 BY_REF is true if the object is used by reference and BY_DOUBLE_REF is
7633 true if the object is used by double reference. */
7636 annotate_object (Entity_Id gnat_entity
, tree gnu_type
, tree size
, bool by_ref
,
7642 gnu_type
= TREE_TYPE (gnu_type
);
7644 if (TYPE_IS_FAT_POINTER_P (gnu_type
))
7645 gnu_type
= TYPE_UNCONSTRAINED_ARRAY (gnu_type
);
7647 gnu_type
= TREE_TYPE (gnu_type
);
7650 if (Unknown_Esize (gnat_entity
))
7652 if (TREE_CODE (gnu_type
) == RECORD_TYPE
7653 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7654 size
= TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
))));
7656 size
= TYPE_SIZE (gnu_type
);
7659 Set_Esize (gnat_entity
, annotate_value (size
));
7662 if (Unknown_Alignment (gnat_entity
))
7663 Set_Alignment (gnat_entity
,
7664 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
7667 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7668 Return NULL_TREE if there is no such element in the list. */
7671 purpose_member_field (const_tree elem
, tree list
)
7675 tree field
= TREE_PURPOSE (list
);
7676 if (SAME_FIELD_P (field
, elem
))
7678 list
= TREE_CHAIN (list
);
7683 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7684 set Component_Bit_Offset and Esize of the components to the position and
7685 size used by Gigi. */
7688 annotate_rep (Entity_Id gnat_entity
, tree gnu_type
)
7690 Entity_Id gnat_field
;
7693 /* We operate by first making a list of all fields and their position (we
7694 can get the size easily) and then update all the sizes in the tree. */
7696 = build_position_list (gnu_type
, false, size_zero_node
, bitsize_zero_node
,
7697 BIGGEST_ALIGNMENT
, NULL_TREE
);
7699 for (gnat_field
= First_Entity (gnat_entity
);
7700 Present (gnat_field
);
7701 gnat_field
= Next_Entity (gnat_field
))
7702 if (Ekind (gnat_field
) == E_Component
7703 || (Ekind (gnat_field
) == E_Discriminant
7704 && !Is_Unchecked_Union (Scope (gnat_field
))))
7706 tree t
= purpose_member_field (gnat_to_gnu_field_decl (gnat_field
),
7712 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
7714 /* In this mode the tag and parent components are not
7715 generated, so we add the appropriate offset to each
7716 component. For a component appearing in the current
7717 extension, the offset is the size of the parent. */
7718 if (Is_Derived_Type (gnat_entity
)
7719 && Original_Record_Component (gnat_field
) == gnat_field
)
7721 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity
))),
7724 parent_offset
= bitsize_int (POINTER_SIZE
);
7727 parent_offset
= bitsize_zero_node
;
7729 Set_Component_Bit_Offset
7732 (size_binop (PLUS_EXPR
,
7733 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t
), 0),
7734 TREE_VEC_ELT (TREE_VALUE (t
), 2)),
7737 Set_Esize (gnat_field
,
7738 annotate_value (DECL_SIZE (TREE_PURPOSE (t
))));
7740 else if (Is_Tagged_Type (gnat_entity
) && Is_Derived_Type (gnat_entity
))
7742 /* If there is no entry, this is an inherited component whose
7743 position is the same as in the parent type. */
7744 Set_Component_Bit_Offset
7746 Component_Bit_Offset (Original_Record_Component (gnat_field
)));
7748 Set_Esize (gnat_field
,
7749 Esize (Original_Record_Component (gnat_field
)));
7754 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7755 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7756 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7757 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7758 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7759 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7760 pre-existing list to be chained to the newly created entries. */
7763 build_position_list (tree gnu_type
, bool do_not_flatten_variant
, tree gnu_pos
,
7764 tree gnu_bitpos
, unsigned int offset_align
, tree gnu_list
)
7768 for (gnu_field
= TYPE_FIELDS (gnu_type
);
7770 gnu_field
= DECL_CHAIN (gnu_field
))
7772 tree gnu_our_bitpos
= size_binop (PLUS_EXPR
, gnu_bitpos
,
7773 DECL_FIELD_BIT_OFFSET (gnu_field
));
7774 tree gnu_our_offset
= size_binop (PLUS_EXPR
, gnu_pos
,
7775 DECL_FIELD_OFFSET (gnu_field
));
7776 unsigned int our_offset_align
7777 = MIN (offset_align
, DECL_OFFSET_ALIGN (gnu_field
));
7778 tree v
= make_tree_vec (3);
7780 TREE_VEC_ELT (v
, 0) = gnu_our_offset
;
7781 TREE_VEC_ELT (v
, 1) = size_int (our_offset_align
);
7782 TREE_VEC_ELT (v
, 2) = gnu_our_bitpos
;
7783 gnu_list
= tree_cons (gnu_field
, v
, gnu_list
);
7785 /* Recurse on internal fields, flattening the nested fields except for
7786 those in the variant part, if requested. */
7787 if (DECL_INTERNAL_P (gnu_field
))
7789 tree gnu_field_type
= TREE_TYPE (gnu_field
);
7790 if (do_not_flatten_variant
7791 && TREE_CODE (gnu_field_type
) == QUAL_UNION_TYPE
)
7793 = build_position_list (gnu_field_type
, do_not_flatten_variant
,
7794 size_zero_node
, bitsize_zero_node
,
7795 BIGGEST_ALIGNMENT
, gnu_list
);
7798 = build_position_list (gnu_field_type
, do_not_flatten_variant
,
7799 gnu_our_offset
, gnu_our_bitpos
,
7800 our_offset_align
, gnu_list
);
7807 /* Return a VEC describing the substitutions needed to reflect the
7808 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7809 be in any order. The values in an element of the VEC are in the form
7810 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
7811 a definition of GNAT_SUBTYPE. */
7813 static VEC(subst_pair
,heap
) *
7814 build_subst_list (Entity_Id gnat_subtype
, Entity_Id gnat_type
, bool definition
)
7816 VEC(subst_pair
,heap
) *gnu_vec
= NULL
;
7817 Entity_Id gnat_discrim
;
7820 for (gnat_discrim
= First_Stored_Discriminant (gnat_type
),
7821 gnat_value
= First_Elmt (Stored_Constraint (gnat_subtype
));
7822 Present (gnat_discrim
);
7823 gnat_discrim
= Next_Stored_Discriminant (gnat_discrim
),
7824 gnat_value
= Next_Elmt (gnat_value
))
7825 /* Ignore access discriminants. */
7826 if (!Is_Access_Type (Etype (Node (gnat_value
))))
7828 tree gnu_field
= gnat_to_gnu_field_decl (gnat_discrim
);
7829 tree replacement
= convert (TREE_TYPE (gnu_field
),
7830 elaborate_expression
7831 (Node (gnat_value
), gnat_subtype
,
7832 get_entity_name (gnat_discrim
),
7833 definition
, true, false));
7834 subst_pair
*s
= VEC_safe_push (subst_pair
, heap
, gnu_vec
, NULL
);
7835 s
->discriminant
= gnu_field
;
7836 s
->replacement
= replacement
;
7842 /* Scan all fields in QUAL_UNION_TYPE and return a VEC describing the
7843 variants of QUAL_UNION_TYPE that are still relevant after applying
7844 the substitutions described in SUBST_LIST. VARIANT_LIST is a
7845 pre-existing VEC onto which newly created entries should be
7848 static VEC(variant_desc
,heap
) *
7849 build_variant_list (tree qual_union_type
, VEC(subst_pair
,heap
) *subst_list
,
7850 VEC(variant_desc
,heap
) *variant_list
)
7854 for (gnu_field
= TYPE_FIELDS (qual_union_type
);
7856 gnu_field
= DECL_CHAIN (gnu_field
))
7858 tree qual
= DECL_QUALIFIER (gnu_field
);
7862 FOR_EACH_VEC_ELT_REVERSE (subst_pair
, subst_list
, ix
, s
)
7863 qual
= SUBSTITUTE_IN_EXPR (qual
, s
->discriminant
, s
->replacement
);
7865 /* If the new qualifier is not unconditionally false, its variant may
7866 still be accessed. */
7867 if (!integer_zerop (qual
))
7870 tree variant_type
= TREE_TYPE (gnu_field
), variant_subpart
;
7872 v
= VEC_safe_push (variant_desc
, heap
, variant_list
, NULL
);
7873 v
->type
= variant_type
;
7874 v
->field
= gnu_field
;
7876 v
->record
= NULL_TREE
;
7878 /* Recurse on the variant subpart of the variant, if any. */
7879 variant_subpart
= get_variant_part (variant_type
);
7880 if (variant_subpart
)
7881 variant_list
= build_variant_list (TREE_TYPE (variant_subpart
),
7882 subst_list
, variant_list
);
7884 /* If the new qualifier is unconditionally true, the subsequent
7885 variants cannot be accessed. */
7886 if (integer_onep (qual
))
7891 return variant_list
;
7894 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7895 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
7896 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
7897 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
7898 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
7899 true if we are being called to process the Component_Size of GNAT_OBJECT;
7900 this is used only for error messages. ZERO_OK is true if a size of zero
7901 is permitted; if ZERO_OK is false, it means that a size of zero should be
7902 treated as an unspecified size. */
7905 validate_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_object
,
7906 enum tree_code kind
, bool component_p
, bool zero_ok
)
7908 Node_Id gnat_error_node
;
7909 tree type_size
, size
;
7911 /* Return 0 if no size was specified. */
7912 if (uint_size
== No_Uint
)
7915 /* Ignore a negative size since that corresponds to our back-annotation. */
7916 if (UI_Lt (uint_size
, Uint_0
))
7919 /* Find the node to use for error messages. */
7920 if ((Ekind (gnat_object
) == E_Component
7921 || Ekind (gnat_object
) == E_Discriminant
)
7922 && Present (Component_Clause (gnat_object
)))
7923 gnat_error_node
= Last_Bit (Component_Clause (gnat_object
));
7924 else if (Present (Size_Clause (gnat_object
)))
7925 gnat_error_node
= Expression (Size_Clause (gnat_object
));
7927 gnat_error_node
= gnat_object
;
7929 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7930 but cannot be represented in bitsizetype. */
7931 size
= UI_To_gnu (uint_size
, bitsizetype
);
7932 if (TREE_OVERFLOW (size
))
7935 post_error_ne ("component size for& is too large", gnat_error_node
,
7938 post_error_ne ("size for& is too large", gnat_error_node
,
7943 /* Ignore a zero size if it is not permitted. */
7944 if (!zero_ok
&& integer_zerop (size
))
7947 /* The size of objects is always a multiple of a byte. */
7948 if (kind
== VAR_DECL
7949 && !integer_zerop (size_binop (TRUNC_MOD_EXPR
, size
, bitsize_unit_node
)))
7952 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7953 gnat_error_node
, gnat_object
);
7955 post_error_ne ("size for& is not a multiple of Storage_Unit",
7956 gnat_error_node
, gnat_object
);
7960 /* If this is an integral type or a packed array type, the front-end has
7961 already verified the size, so we need not do it here (which would mean
7962 checking against the bounds). However, if this is an aliased object,
7963 it may not be smaller than the type of the object. */
7964 if ((INTEGRAL_TYPE_P (gnu_type
) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type
))
7965 && !(kind
== VAR_DECL
&& Is_Aliased (gnat_object
)))
7968 /* If the object is a record that contains a template, add the size of the
7969 template to the specified size. */
7970 if (TREE_CODE (gnu_type
) == RECORD_TYPE
7971 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7972 size
= size_binop (PLUS_EXPR
, DECL_SIZE (TYPE_FIELDS (gnu_type
)), size
);
7974 if (kind
== VAR_DECL
7975 /* If a type needs strict alignment, a component of this type in
7976 a packed record cannot be packed and thus uses the type size. */
7977 || (kind
== TYPE_DECL
&& Strict_Alignment (gnat_object
)))
7978 type_size
= TYPE_SIZE (gnu_type
);
7980 type_size
= rm_size (gnu_type
);
7982 /* Modify the size of a discriminated type to be the maximum size. */
7983 if (type_size
&& CONTAINS_PLACEHOLDER_P (type_size
))
7984 type_size
= max_size (type_size
, true);
7986 /* If this is an access type or a fat pointer, the minimum size is that given
7987 by the smallest integral mode that's valid for pointers. */
7988 if (TREE_CODE (gnu_type
) == POINTER_TYPE
|| TYPE_IS_FAT_POINTER_P (gnu_type
))
7990 enum machine_mode p_mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
7991 while (!targetm
.valid_pointer_mode (p_mode
))
7992 p_mode
= GET_MODE_WIDER_MODE (p_mode
);
7993 type_size
= bitsize_int (GET_MODE_BITSIZE (p_mode
));
7996 /* Issue an error either if the default size of the object isn't a constant
7997 or if the new size is smaller than it. */
7998 if (TREE_CODE (type_size
) != INTEGER_CST
7999 || TREE_OVERFLOW (type_size
)
8000 || tree_int_cst_lt (size
, type_size
))
8004 ("component size for& too small{, minimum allowed is ^}",
8005 gnat_error_node
, gnat_object
, type_size
);
8008 ("size for& too small{, minimum allowed is ^}",
8009 gnat_error_node
, gnat_object
, type_size
);
8016 /* Similarly, but both validate and process a value of RM size. This routine
8017 is only called for types. */
8020 set_rm_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_entity
)
8022 Node_Id gnat_attr_node
;
8023 tree old_size
, size
;
8025 /* Do nothing if no size was specified. */
8026 if (uint_size
== No_Uint
)
8029 /* Ignore a negative size since that corresponds to our back-annotation. */
8030 if (UI_Lt (uint_size
, Uint_0
))
8033 /* Only issue an error if a Value_Size clause was explicitly given.
8034 Otherwise, we'd be duplicating an error on the Size clause. */
8036 = Get_Attribute_Definition_Clause (gnat_entity
, Attr_Value_Size
);
8038 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8039 but cannot be represented in bitsizetype. */
8040 size
= UI_To_gnu (uint_size
, bitsizetype
);
8041 if (TREE_OVERFLOW (size
))
8043 if (Present (gnat_attr_node
))
8044 post_error_ne ("Value_Size for& is too large", gnat_attr_node
,
8049 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8050 exists, or this is an integer type, in which case the front-end will
8051 have always set it. */
8052 if (No (gnat_attr_node
)
8053 && integer_zerop (size
)
8054 && !Has_Size_Clause (gnat_entity
)
8055 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
8058 old_size
= rm_size (gnu_type
);
8060 /* If the old size is self-referential, get the maximum size. */
8061 if (CONTAINS_PLACEHOLDER_P (old_size
))
8062 old_size
= max_size (old_size
, true);
8064 /* Issue an error either if the old size of the object isn't a constant or
8065 if the new size is smaller than it. The front-end has already verified
8066 this for scalar and packed array types. */
8067 if (TREE_CODE (old_size
) != INTEGER_CST
8068 || TREE_OVERFLOW (old_size
)
8069 || (AGGREGATE_TYPE_P (gnu_type
)
8070 && !(TREE_CODE (gnu_type
) == ARRAY_TYPE
8071 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type
))
8072 && !(TYPE_IS_PADDING_P (gnu_type
)
8073 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
))) == ARRAY_TYPE
8074 && TYPE_PACKED_ARRAY_TYPE_P
8075 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))
8076 && tree_int_cst_lt (size
, old_size
)))
8078 if (Present (gnat_attr_node
))
8080 ("Value_Size for& too small{, minimum allowed is ^}",
8081 gnat_attr_node
, gnat_entity
, old_size
);
8085 /* Otherwise, set the RM size proper for integral types... */
8086 if ((TREE_CODE (gnu_type
) == INTEGER_TYPE
8087 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
8088 || (TREE_CODE (gnu_type
) == ENUMERAL_TYPE
8089 || TREE_CODE (gnu_type
) == BOOLEAN_TYPE
))
8090 SET_TYPE_RM_SIZE (gnu_type
, size
);
8092 /* ...or the Ada size for record and union types. */
8093 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
8094 || TREE_CODE (gnu_type
) == UNION_TYPE
8095 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
8096 && !TYPE_FAT_POINTER_P (gnu_type
))
8097 SET_TYPE_ADA_SIZE (gnu_type
, size
);
8100 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
8101 If TYPE is the best type, return it. Otherwise, make a new type. We
8102 only support new integral and pointer types. FOR_BIASED is true if
8103 we are making a biased type. */
8106 make_type_from_size (tree type
, tree size_tree
, bool for_biased
)
8108 unsigned HOST_WIDE_INT size
;
8112 /* If size indicates an error, just return TYPE to avoid propagating
8113 the error. Likewise if it's too large to represent. */
8114 if (!size_tree
|| !host_integerp (size_tree
, 1))
8117 size
= tree_low_cst (size_tree
, 1);
8119 switch (TREE_CODE (type
))
8124 biased_p
= (TREE_CODE (type
) == INTEGER_TYPE
8125 && TYPE_BIASED_REPRESENTATION_P (type
));
8127 /* Integer types with precision 0 are forbidden. */
8131 /* Only do something if the type is not a packed array type and
8132 doesn't already have the proper size. */
8133 if (TYPE_PACKED_ARRAY_TYPE_P (type
)
8134 || (TYPE_PRECISION (type
) == size
&& biased_p
== for_biased
))
8137 biased_p
|= for_biased
;
8138 if (size
> LONG_LONG_TYPE_SIZE
)
8139 size
= LONG_LONG_TYPE_SIZE
;
8141 if (TYPE_UNSIGNED (type
) || biased_p
)
8142 new_type
= make_unsigned_type (size
);
8144 new_type
= make_signed_type (size
);
8145 TREE_TYPE (new_type
) = TREE_TYPE (type
) ? TREE_TYPE (type
) : type
;
8146 SET_TYPE_RM_MIN_VALUE (new_type
,
8147 convert (TREE_TYPE (new_type
),
8148 TYPE_MIN_VALUE (type
)));
8149 SET_TYPE_RM_MAX_VALUE (new_type
,
8150 convert (TREE_TYPE (new_type
),
8151 TYPE_MAX_VALUE (type
)));
8152 /* Copy the name to show that it's essentially the same type and
8153 not a subrange type. */
8154 TYPE_NAME (new_type
) = TYPE_NAME (type
);
8155 TYPE_BIASED_REPRESENTATION_P (new_type
) = biased_p
;
8156 SET_TYPE_RM_SIZE (new_type
, bitsize_int (size
));
8160 /* Do something if this is a fat pointer, in which case we
8161 may need to return the thin pointer. */
8162 if (TYPE_FAT_POINTER_P (type
) && size
< POINTER_SIZE
* 2)
8164 enum machine_mode p_mode
= mode_for_size (size
, MODE_INT
, 0);
8165 if (!targetm
.valid_pointer_mode (p_mode
))
8168 build_pointer_type_for_mode
8169 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type
)),
8175 /* Only do something if this is a thin pointer, in which case we
8176 may need to return the fat pointer. */
8177 if (TYPE_IS_THIN_POINTER_P (type
) && size
>= POINTER_SIZE
* 2)
8179 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)));
8189 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8190 a type or object whose present alignment is ALIGN. If this alignment is
8191 valid, return it. Otherwise, give an error and return ALIGN. */
8194 validate_alignment (Uint alignment
, Entity_Id gnat_entity
, unsigned int align
)
8196 unsigned int max_allowed_alignment
= get_target_maximum_allowed_alignment ();
8197 unsigned int new_align
;
8198 Node_Id gnat_error_node
;
8200 /* Don't worry about checking alignment if alignment was not specified
8201 by the source program and we already posted an error for this entity. */
8202 if (Error_Posted (gnat_entity
) && !Has_Alignment_Clause (gnat_entity
))
8205 /* Post the error on the alignment clause if any. Note, for the implicit
8206 base type of an array type, the alignment clause is on the first
8208 if (Present (Alignment_Clause (gnat_entity
)))
8209 gnat_error_node
= Expression (Alignment_Clause (gnat_entity
));
8211 else if (Is_Itype (gnat_entity
)
8212 && Is_Array_Type (gnat_entity
)
8213 && Etype (gnat_entity
) == gnat_entity
8214 && Present (Alignment_Clause (First_Subtype (gnat_entity
))))
8216 Expression (Alignment_Clause (First_Subtype (gnat_entity
)));
8219 gnat_error_node
= gnat_entity
;
8221 /* Within GCC, an alignment is an integer, so we must make sure a value is
8222 specified that fits in that range. Also, there is an upper bound to
8223 alignments we can support/allow. */
8224 if (!UI_Is_In_Int_Range (alignment
)
8225 || ((new_align
= UI_To_Int (alignment
)) > max_allowed_alignment
))
8226 post_error_ne_num ("largest supported alignment for& is ^",
8227 gnat_error_node
, gnat_entity
, max_allowed_alignment
);
8228 else if (!(Present (Alignment_Clause (gnat_entity
))
8229 && From_At_Mod (Alignment_Clause (gnat_entity
)))
8230 && new_align
* BITS_PER_UNIT
< align
)
8232 unsigned int double_align
;
8233 bool is_capped_double
, align_clause
;
8235 /* If the default alignment of "double" or larger scalar types is
8236 specifically capped and the new alignment is above the cap, do
8237 not post an error and change the alignment only if there is an
8238 alignment clause; this makes it possible to have the associated
8239 GCC type overaligned by default for performance reasons. */
8240 if ((double_align
= double_float_alignment
) > 0)
8243 = Is_Type (gnat_entity
) ? gnat_entity
: Etype (gnat_entity
);
8245 = is_double_float_or_array (gnat_type
, &align_clause
);
8247 else if ((double_align
= double_scalar_alignment
) > 0)
8250 = Is_Type (gnat_entity
) ? gnat_entity
: Etype (gnat_entity
);
8252 = is_double_scalar_or_array (gnat_type
, &align_clause
);
8255 is_capped_double
= align_clause
= false;
8257 if (is_capped_double
&& new_align
>= double_align
)
8260 align
= new_align
* BITS_PER_UNIT
;
8264 if (is_capped_double
)
8265 align
= double_align
* BITS_PER_UNIT
;
8267 post_error_ne_num ("alignment for& must be at least ^",
8268 gnat_error_node
, gnat_entity
,
8269 align
/ BITS_PER_UNIT
);
8274 new_align
= (new_align
> 0 ? new_align
* BITS_PER_UNIT
: 1);
8275 if (new_align
> align
)
8282 /* Return the smallest alignment not less than SIZE. */
8285 ceil_alignment (unsigned HOST_WIDE_INT size
)
8287 return (unsigned int) 1 << (floor_log2 (size
- 1) + 1);
8290 /* Verify that OBJECT, a type or decl, is something we can implement
8291 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
8292 if we require atomic components. */
8295 check_ok_for_atomic (tree object
, Entity_Id gnat_entity
, bool comp_p
)
8297 Node_Id gnat_error_point
= gnat_entity
;
8299 enum machine_mode mode
;
8303 /* There are three case of what OBJECT can be. It can be a type, in which
8304 case we take the size, alignment and mode from the type. It can be a
8305 declaration that was indirect, in which case the relevant values are
8306 that of the type being pointed to, or it can be a normal declaration,
8307 in which case the values are of the decl. The code below assumes that
8308 OBJECT is either a type or a decl. */
8309 if (TYPE_P (object
))
8311 /* If this is an anonymous base type, nothing to check. Error will be
8312 reported on the source type. */
8313 if (!Comes_From_Source (gnat_entity
))
8316 mode
= TYPE_MODE (object
);
8317 align
= TYPE_ALIGN (object
);
8318 size
= TYPE_SIZE (object
);
8320 else if (DECL_BY_REF_P (object
))
8322 mode
= TYPE_MODE (TREE_TYPE (TREE_TYPE (object
)));
8323 align
= TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object
)));
8324 size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (object
)));
8328 mode
= DECL_MODE (object
);
8329 align
= DECL_ALIGN (object
);
8330 size
= DECL_SIZE (object
);
8333 /* Consider all floating-point types atomic and any types that that are
8334 represented by integers no wider than a machine word. */
8335 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
8336 || ((GET_MODE_CLASS (mode
) == MODE_INT
8337 || GET_MODE_CLASS (mode
) == MODE_PARTIAL_INT
)
8338 && GET_MODE_BITSIZE (mode
) <= BITS_PER_WORD
))
8341 /* For the moment, also allow anything that has an alignment equal
8342 to its size and which is smaller than a word. */
8343 if (size
&& TREE_CODE (size
) == INTEGER_CST
8344 && compare_tree_int (size
, align
) == 0
8345 && align
<= BITS_PER_WORD
)
8348 for (gnat_node
= First_Rep_Item (gnat_entity
); Present (gnat_node
);
8349 gnat_node
= Next_Rep_Item (gnat_node
))
8351 if (!comp_p
&& Nkind (gnat_node
) == N_Pragma
8352 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
8354 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
8355 else if (comp_p
&& Nkind (gnat_node
) == N_Pragma
8356 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
8357 == Pragma_Atomic_Components
))
8358 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
8362 post_error_ne ("atomic access to component of & cannot be guaranteed",
8363 gnat_error_point
, gnat_entity
);
8365 post_error_ne ("atomic access to & cannot be guaranteed",
8366 gnat_error_point
, gnat_entity
);
8370 /* Helper for the intrin compatibility checks family. Evaluate whether
8371 two types are definitely incompatible. */
8374 intrin_types_incompatible_p (tree t1
, tree t2
)
8376 enum tree_code code
;
8378 if (TYPE_MAIN_VARIANT (t1
) == TYPE_MAIN_VARIANT (t2
))
8381 if (TYPE_MODE (t1
) != TYPE_MODE (t2
))
8384 if (TREE_CODE (t1
) != TREE_CODE (t2
))
8387 code
= TREE_CODE (t1
);
8393 return TYPE_PRECISION (t1
) != TYPE_PRECISION (t2
);
8396 case REFERENCE_TYPE
:
8397 /* Assume designated types are ok. We'd need to account for char * and
8398 void * variants to do better, which could rapidly get messy and isn't
8399 clearly worth the effort. */
8409 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8410 on the Ada/builtin argument lists for the INB binding. */
8413 intrin_arglists_compatible_p (intrin_binding_t
* inb
)
8415 function_args_iterator ada_iter
, btin_iter
;
8417 function_args_iter_init (&ada_iter
, inb
->ada_fntype
);
8418 function_args_iter_init (&btin_iter
, inb
->btin_fntype
);
8420 /* Sequence position of the last argument we checked. */
8425 tree ada_type
= function_args_iter_cond (&ada_iter
);
8426 tree btin_type
= function_args_iter_cond (&btin_iter
);
8428 /* If we've exhausted both lists simultaneously, we're done. */
8429 if (ada_type
== NULL_TREE
&& btin_type
== NULL_TREE
)
8432 /* If one list is shorter than the other, they fail to match. */
8433 if (ada_type
== NULL_TREE
|| btin_type
== NULL_TREE
)
8436 /* If we're done with the Ada args and not with the internal builtin
8437 args, or the other way around, complain. */
8438 if (ada_type
== void_type_node
8439 && btin_type
!= void_type_node
)
8441 post_error ("?Ada arguments list too short!", inb
->gnat_entity
);
8445 if (btin_type
== void_type_node
8446 && ada_type
!= void_type_node
)
8448 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8449 inb
->gnat_entity
, inb
->gnat_entity
, argpos
);
8453 /* Otherwise, check that types match for the current argument. */
8455 if (intrin_types_incompatible_p (ada_type
, btin_type
))
8457 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8458 inb
->gnat_entity
, inb
->gnat_entity
, argpos
);
8463 function_args_iter_next (&ada_iter
);
8464 function_args_iter_next (&btin_iter
);
8470 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8471 on the Ada/builtin return values for the INB binding. */
8474 intrin_return_compatible_p (intrin_binding_t
* inb
)
8476 tree ada_return_type
= TREE_TYPE (inb
->ada_fntype
);
8477 tree btin_return_type
= TREE_TYPE (inb
->btin_fntype
);
8479 /* Accept function imported as procedure, common and convenient. */
8480 if (VOID_TYPE_P (ada_return_type
)
8481 && !VOID_TYPE_P (btin_return_type
))
8484 /* Check return types compatibility otherwise. Note that this
8485 handles void/void as well. */
8486 if (intrin_types_incompatible_p (btin_return_type
, ada_return_type
))
8488 post_error ("?intrinsic binding type mismatch on return value!",
8496 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8497 compatible. Issue relevant warnings when they are not.
8499 This is intended as a light check to diagnose the most obvious cases, not
8500 as a full fledged type compatibility predicate. It is the programmer's
8501 responsibility to ensure correctness of the Ada declarations in Imports,
8502 especially when binding straight to a compiler internal. */
8505 intrin_profiles_compatible_p (intrin_binding_t
* inb
)
8507 /* Check compatibility on return values and argument lists, each responsible
8508 for posting warnings as appropriate. Ensure use of the proper sloc for
8511 bool arglists_compatible_p
, return_compatible_p
;
8512 location_t saved_location
= input_location
;
8514 Sloc_to_locus (Sloc (inb
->gnat_entity
), &input_location
);
8516 return_compatible_p
= intrin_return_compatible_p (inb
);
8517 arglists_compatible_p
= intrin_arglists_compatible_p (inb
);
8519 input_location
= saved_location
;
8521 return return_compatible_p
&& arglists_compatible_p
;
8524 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
8525 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
8526 specified size for this field. POS_LIST is a position list describing
8527 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
8531 create_field_decl_from (tree old_field
, tree field_type
, tree record_type
,
8532 tree size
, tree pos_list
,
8533 VEC(subst_pair
,heap
) *subst_list
)
8535 tree t
= TREE_VALUE (purpose_member (old_field
, pos_list
));
8536 tree pos
= TREE_VEC_ELT (t
, 0), bitpos
= TREE_VEC_ELT (t
, 2);
8537 unsigned int offset_align
= tree_low_cst (TREE_VEC_ELT (t
, 1), 1);
8538 tree new_pos
, new_field
;
8542 if (CONTAINS_PLACEHOLDER_P (pos
))
8543 FOR_EACH_VEC_ELT_REVERSE (subst_pair
, subst_list
, ix
, s
)
8544 pos
= SUBSTITUTE_IN_EXPR (pos
, s
->discriminant
, s
->replacement
);
8546 /* If the position is now a constant, we can set it as the position of the
8547 field when we make it. Otherwise, we need to deal with it specially. */
8548 if (TREE_CONSTANT (pos
))
8549 new_pos
= bit_from_pos (pos
, bitpos
);
8551 new_pos
= NULL_TREE
;
8554 = create_field_decl (DECL_NAME (old_field
), field_type
, record_type
,
8555 size
, new_pos
, DECL_PACKED (old_field
),
8556 !DECL_NONADDRESSABLE_P (old_field
));
8560 normalize_offset (&pos
, &bitpos
, offset_align
);
8561 DECL_FIELD_OFFSET (new_field
) = pos
;
8562 DECL_FIELD_BIT_OFFSET (new_field
) = bitpos
;
8563 SET_DECL_OFFSET_ALIGN (new_field
, offset_align
);
8564 DECL_SIZE (new_field
) = size
;
8565 DECL_SIZE_UNIT (new_field
)
8566 = convert (sizetype
,
8567 size_binop (CEIL_DIV_EXPR
, size
, bitsize_unit_node
));
8568 layout_decl (new_field
, DECL_OFFSET_ALIGN (new_field
));
8571 DECL_INTERNAL_P (new_field
) = DECL_INTERNAL_P (old_field
);
8572 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field
, old_field
);
8573 DECL_DISCRIMINANT_NUMBER (new_field
) = DECL_DISCRIMINANT_NUMBER (old_field
);
8574 TREE_THIS_VOLATILE (new_field
) = TREE_THIS_VOLATILE (old_field
);
8579 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8582 get_rep_part (tree record_type
)
8584 tree field
= TYPE_FIELDS (record_type
);
8586 /* The REP part is the first field, internal, another record, and its name
8587 doesn't start with an underscore (i.e. is not generated by the FE). */
8588 if (DECL_INTERNAL_P (field
)
8589 && TREE_CODE (TREE_TYPE (field
)) == RECORD_TYPE
8590 && IDENTIFIER_POINTER (DECL_NAME (field
)) [0] != '_')
8596 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8599 get_variant_part (tree record_type
)
8603 /* The variant part is the only internal field that is a qualified union. */
8604 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
8605 if (DECL_INTERNAL_P (field
)
8606 && TREE_CODE (TREE_TYPE (field
)) == QUAL_UNION_TYPE
)
8612 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8613 the list of variants to be used and RECORD_TYPE is the type of the parent.
8614 POS_LIST is a position list describing the layout of fields present in
8615 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8619 create_variant_part_from (tree old_variant_part
,
8620 VEC(variant_desc
,heap
) *variant_list
,
8621 tree record_type
, tree pos_list
,
8622 VEC(subst_pair
,heap
) *subst_list
)
8624 tree offset
= DECL_FIELD_OFFSET (old_variant_part
);
8625 tree old_union_type
= TREE_TYPE (old_variant_part
);
8626 tree new_union_type
, new_variant_part
;
8627 tree union_field_list
= NULL_TREE
;
8631 /* First create the type of the variant part from that of the old one. */
8632 new_union_type
= make_node (QUAL_UNION_TYPE
);
8633 TYPE_NAME (new_union_type
) = DECL_NAME (TYPE_NAME (old_union_type
));
8635 /* If the position of the variant part is constant, subtract it from the
8636 size of the type of the parent to get the new size. This manual CSE
8637 reduces the code size when not optimizing. */
8638 if (TREE_CODE (offset
) == INTEGER_CST
)
8640 tree bitpos
= DECL_FIELD_BIT_OFFSET (old_variant_part
);
8641 tree first_bit
= bit_from_pos (offset
, bitpos
);
8642 TYPE_SIZE (new_union_type
)
8643 = size_binop (MINUS_EXPR
, TYPE_SIZE (record_type
), first_bit
);
8644 TYPE_SIZE_UNIT (new_union_type
)
8645 = size_binop (MINUS_EXPR
, TYPE_SIZE_UNIT (record_type
),
8646 byte_from_pos (offset
, bitpos
));
8647 SET_TYPE_ADA_SIZE (new_union_type
,
8648 size_binop (MINUS_EXPR
, TYPE_ADA_SIZE (record_type
),
8650 TYPE_ALIGN (new_union_type
) = TYPE_ALIGN (old_union_type
);
8651 relate_alias_sets (new_union_type
, old_union_type
, ALIAS_SET_COPY
);
8654 copy_and_substitute_in_size (new_union_type
, old_union_type
, subst_list
);
8656 /* Now finish up the new variants and populate the union type. */
8657 FOR_EACH_VEC_ELT_REVERSE (variant_desc
, variant_list
, ix
, v
)
8659 tree old_field
= v
->field
, new_field
;
8660 tree old_variant
, old_variant_subpart
, new_variant
, field_list
;
8662 /* Skip variants that don't belong to this nesting level. */
8663 if (DECL_CONTEXT (old_field
) != old_union_type
)
8666 /* Retrieve the list of fields already added to the new variant. */
8667 new_variant
= v
->record
;
8668 field_list
= TYPE_FIELDS (new_variant
);
8670 /* If the old variant had a variant subpart, we need to create a new
8671 variant subpart and add it to the field list. */
8672 old_variant
= v
->type
;
8673 old_variant_subpart
= get_variant_part (old_variant
);
8674 if (old_variant_subpart
)
8676 tree new_variant_subpart
8677 = create_variant_part_from (old_variant_subpart
, variant_list
,
8678 new_variant
, pos_list
, subst_list
);
8679 DECL_CHAIN (new_variant_subpart
) = field_list
;
8680 field_list
= new_variant_subpart
;
8683 /* Finish up the new variant and create the field. No need for debug
8684 info thanks to the XVS type. */
8685 finish_record_type (new_variant
, nreverse (field_list
), 2, false);
8686 compute_record_mode (new_variant
);
8687 create_type_decl (TYPE_NAME (new_variant
), new_variant
, NULL
,
8688 true, false, Empty
);
8691 = create_field_decl_from (old_field
, new_variant
, new_union_type
,
8692 TYPE_SIZE (new_variant
),
8693 pos_list
, subst_list
);
8694 DECL_QUALIFIER (new_field
) = v
->qual
;
8695 DECL_INTERNAL_P (new_field
) = 1;
8696 DECL_CHAIN (new_field
) = union_field_list
;
8697 union_field_list
= new_field
;
8700 /* Finish up the union type and create the variant part. No need for debug
8701 info thanks to the XVS type. */
8702 finish_record_type (new_union_type
, union_field_list
, 2, false);
8703 compute_record_mode (new_union_type
);
8704 create_type_decl (TYPE_NAME (new_union_type
), new_union_type
, NULL
,
8705 true, false, Empty
);
8708 = create_field_decl_from (old_variant_part
, new_union_type
, record_type
,
8709 TYPE_SIZE (new_union_type
),
8710 pos_list
, subst_list
);
8711 DECL_INTERNAL_P (new_variant_part
) = 1;
8713 /* With multiple discriminants it is possible for an inner variant to be
8714 statically selected while outer ones are not; in this case, the list
8715 of fields of the inner variant is not flattened and we end up with a
8716 qualified union with a single member. Drop the useless container. */
8717 if (!DECL_CHAIN (union_field_list
))
8719 DECL_CONTEXT (union_field_list
) = record_type
;
8720 DECL_FIELD_OFFSET (union_field_list
)
8721 = DECL_FIELD_OFFSET (new_variant_part
);
8722 DECL_FIELD_BIT_OFFSET (union_field_list
)
8723 = DECL_FIELD_BIT_OFFSET (new_variant_part
);
8724 SET_DECL_OFFSET_ALIGN (union_field_list
,
8725 DECL_OFFSET_ALIGN (new_variant_part
));
8726 new_variant_part
= union_field_list
;
8729 return new_variant_part
;
8732 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8733 which are both RECORD_TYPE, after applying the substitutions described
8737 copy_and_substitute_in_size (tree new_type
, tree old_type
,
8738 VEC(subst_pair
,heap
) *subst_list
)
8743 TYPE_SIZE (new_type
) = TYPE_SIZE (old_type
);
8744 TYPE_SIZE_UNIT (new_type
) = TYPE_SIZE_UNIT (old_type
);
8745 SET_TYPE_ADA_SIZE (new_type
, TYPE_ADA_SIZE (old_type
));
8746 TYPE_ALIGN (new_type
) = TYPE_ALIGN (old_type
);
8747 relate_alias_sets (new_type
, old_type
, ALIAS_SET_COPY
);
8749 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type
)))
8750 FOR_EACH_VEC_ELT_REVERSE (subst_pair
, subst_list
, ix
, s
)
8751 TYPE_SIZE (new_type
)
8752 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type
),
8753 s
->discriminant
, s
->replacement
);
8755 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type
)))
8756 FOR_EACH_VEC_ELT_REVERSE (subst_pair
, subst_list
, ix
, s
)
8757 TYPE_SIZE_UNIT (new_type
)
8758 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type
),
8759 s
->discriminant
, s
->replacement
);
8761 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type
)))
8762 FOR_EACH_VEC_ELT_REVERSE (subst_pair
, subst_list
, ix
, s
)
8764 (new_type
, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type
),
8765 s
->discriminant
, s
->replacement
));
8767 /* Finalize the size. */
8768 TYPE_SIZE (new_type
) = variable_size (TYPE_SIZE (new_type
));
8769 TYPE_SIZE_UNIT (new_type
) = variable_size (TYPE_SIZE_UNIT (new_type
));
8772 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8773 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8774 updated by replacing F with R.
8776 The function doesn't update the layout of the type, i.e. it assumes
8777 that the substitution is purely formal. That's why the replacement
8778 value R must itself contain a PLACEHOLDER_EXPR. */
8781 substitute_in_type (tree t
, tree f
, tree r
)
8785 gcc_assert (CONTAINS_PLACEHOLDER_P (r
));
8787 switch (TREE_CODE (t
))
8794 /* First the domain types of arrays. */
8795 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t
))
8796 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t
)))
8798 tree low
= SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t
), f
, r
);
8799 tree high
= SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t
), f
, r
);
8801 if (low
== TYPE_GCC_MIN_VALUE (t
) && high
== TYPE_GCC_MAX_VALUE (t
))
8805 TYPE_GCC_MIN_VALUE (nt
) = low
;
8806 TYPE_GCC_MAX_VALUE (nt
) = high
;
8808 if (TREE_CODE (t
) == INTEGER_TYPE
&& TYPE_INDEX_TYPE (t
))
8810 (nt
, substitute_in_type (TYPE_INDEX_TYPE (t
), f
, r
));
8815 /* Then the subtypes. */
8816 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t
))
8817 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t
)))
8819 tree low
= SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t
), f
, r
);
8820 tree high
= SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t
), f
, r
);
8822 if (low
== TYPE_RM_MIN_VALUE (t
) && high
== TYPE_RM_MAX_VALUE (t
))
8826 SET_TYPE_RM_MIN_VALUE (nt
, low
);
8827 SET_TYPE_RM_MAX_VALUE (nt
, high
);
8835 nt
= substitute_in_type (TREE_TYPE (t
), f
, r
);
8836 if (nt
== TREE_TYPE (t
))
8839 return build_complex_type (nt
);
8842 /* These should never show up here. */
8847 tree component
= substitute_in_type (TREE_TYPE (t
), f
, r
);
8848 tree domain
= substitute_in_type (TYPE_DOMAIN (t
), f
, r
);
8850 if (component
== TREE_TYPE (t
) && domain
== TYPE_DOMAIN (t
))
8853 nt
= build_nonshared_array_type (component
, domain
);
8854 TYPE_ALIGN (nt
) = TYPE_ALIGN (t
);
8855 TYPE_USER_ALIGN (nt
) = TYPE_USER_ALIGN (t
);
8856 SET_TYPE_MODE (nt
, TYPE_MODE (t
));
8857 TYPE_SIZE (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t
), f
, r
);
8858 TYPE_SIZE_UNIT (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t
), f
, r
);
8859 TYPE_NONALIASED_COMPONENT (nt
) = TYPE_NONALIASED_COMPONENT (t
);
8860 TYPE_MULTI_ARRAY_P (nt
) = TYPE_MULTI_ARRAY_P (t
);
8861 TYPE_CONVENTION_FORTRAN_P (nt
) = TYPE_CONVENTION_FORTRAN_P (t
);
8867 case QUAL_UNION_TYPE
:
8869 bool changed_field
= false;
8872 /* Start out with no fields, make new fields, and chain them
8873 in. If we haven't actually changed the type of any field,
8874 discard everything we've done and return the old type. */
8876 TYPE_FIELDS (nt
) = NULL_TREE
;
8878 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
8880 tree new_field
= copy_node (field
), new_n
;
8882 new_n
= substitute_in_type (TREE_TYPE (field
), f
, r
);
8883 if (new_n
!= TREE_TYPE (field
))
8885 TREE_TYPE (new_field
) = new_n
;
8886 changed_field
= true;
8889 new_n
= SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field
), f
, r
);
8890 if (new_n
!= DECL_FIELD_OFFSET (field
))
8892 DECL_FIELD_OFFSET (new_field
) = new_n
;
8893 changed_field
= true;
8896 /* Do the substitution inside the qualifier, if any. */
8897 if (TREE_CODE (t
) == QUAL_UNION_TYPE
)
8899 new_n
= SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field
), f
, r
);
8900 if (new_n
!= DECL_QUALIFIER (field
))
8902 DECL_QUALIFIER (new_field
) = new_n
;
8903 changed_field
= true;
8907 DECL_CONTEXT (new_field
) = nt
;
8908 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field
, field
);
8910 DECL_CHAIN (new_field
) = TYPE_FIELDS (nt
);
8911 TYPE_FIELDS (nt
) = new_field
;
8917 TYPE_FIELDS (nt
) = nreverse (TYPE_FIELDS (nt
));
8918 TYPE_SIZE (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t
), f
, r
);
8919 TYPE_SIZE_UNIT (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t
), f
, r
);
8920 SET_TYPE_ADA_SIZE (nt
, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t
), f
, r
));
8929 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8930 needed to represent the object. */
8933 rm_size (tree gnu_type
)
8935 /* For integral types, we store the RM size explicitly. */
8936 if (INTEGRAL_TYPE_P (gnu_type
) && TYPE_RM_SIZE (gnu_type
))
8937 return TYPE_RM_SIZE (gnu_type
);
8939 /* Return the RM size of the actual data plus the size of the template. */
8940 if (TREE_CODE (gnu_type
) == RECORD_TYPE
8941 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
8943 size_binop (PLUS_EXPR
,
8944 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)))),
8945 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
8947 /* For record types, we store the size explicitly. */
8948 if ((TREE_CODE (gnu_type
) == RECORD_TYPE
8949 || TREE_CODE (gnu_type
) == UNION_TYPE
8950 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
8951 && !TYPE_FAT_POINTER_P (gnu_type
)
8952 && TYPE_ADA_SIZE (gnu_type
))
8953 return TYPE_ADA_SIZE (gnu_type
);
8955 /* For other types, this is just the size. */
8956 return TYPE_SIZE (gnu_type
);
8959 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8960 fully-qualified name, possibly with type information encoding.
8961 Otherwise, return the name. */
8964 get_entity_name (Entity_Id gnat_entity
)
8966 Get_Encoded_Name (gnat_entity
);
8967 return get_identifier_with_length (Name_Buffer
, Name_Len
);
8970 /* Return an identifier representing the external name to be used for
8971 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8972 and the specified suffix. */
8975 create_concat_name (Entity_Id gnat_entity
, const char *suffix
)
8977 Entity_Kind kind
= Ekind (gnat_entity
);
8981 String_Template temp
= {1, (int) strlen (suffix
)};
8982 Fat_Pointer fp
= {suffix
, &temp
};
8983 Get_External_Name_With_Suffix (gnat_entity
, fp
);
8986 Get_External_Name (gnat_entity
, 0);
8988 /* A variable using the Stdcall convention lives in a DLL. We adjust
8989 its name to use the jump table, the _imp__NAME contains the address
8990 for the NAME variable. */
8991 if ((kind
== E_Variable
|| kind
== E_Constant
)
8992 && Has_Stdcall_Convention (gnat_entity
))
8994 const int len
= 6 + Name_Len
;
8995 char *new_name
= (char *) alloca (len
+ 1);
8996 strcpy (new_name
, "_imp__");
8997 strcat (new_name
, Name_Buffer
);
8998 return get_identifier_with_length (new_name
, len
);
9001 return get_identifier_with_length (Name_Buffer
, Name_Len
);
9004 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
9005 string, return a new IDENTIFIER_NODE that is the concatenation of
9006 the name followed by "___" and the specified suffix. */
9009 concat_name (tree gnu_name
, const char *suffix
)
9011 const int len
= IDENTIFIER_LENGTH (gnu_name
) + 3 + strlen (suffix
);
9012 char *new_name
= (char *) alloca (len
+ 1);
9013 strcpy (new_name
, IDENTIFIER_POINTER (gnu_name
));
9014 strcat (new_name
, "___");
9015 strcat (new_name
, suffix
);
9016 return get_identifier_with_length (new_name
, len
);
9019 #include "gt-ada-decl.h"