1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2012, 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 /* "stdcall" and "thiscall" conventions should be processed in a specific way
54 on 32-bit x86/Windows only. The macros below are helpers to avoid having
55 to 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)
61 #define Has_Thiscall_Convention(E) \
62 (!TARGET_64BIT && is_cplusplus_method (E))
64 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
65 #define Has_Thiscall_Convention(E) (is_cplusplus_method (E))
68 #define Has_Stdcall_Convention(E) 0
69 #define Has_Thiscall_Convention(E) 0
72 /* Stack realignment is necessary for functions with foreign conventions when
73 the ABI doesn't mandate as much as what the compiler assumes - that is, up
74 to PREFERRED_STACK_BOUNDARY.
76 Such realignment can be requested with a dedicated function type attribute
77 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
78 characterize the situations where the attribute should be set. We rely on
79 compiler configuration settings for 'main' to decide. */
81 #ifdef MAIN_STACK_BOUNDARY
82 #define FOREIGN_FORCE_REALIGN_STACK \
83 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
85 #define FOREIGN_FORCE_REALIGN_STACK 0
90 struct incomplete
*next
;
95 /* These variables are used to defer recursively expanding incomplete types
96 while we are processing an array, a record or a subprogram type. */
97 static int defer_incomplete_level
= 0;
98 static struct incomplete
*defer_incomplete_list
;
100 /* This variable is used to delay expanding From_With_Type types until the
102 static struct incomplete
*defer_limited_with
;
104 typedef struct subst_pair_d
{
110 typedef struct variant_desc_d
{
111 /* The type of the variant. */
114 /* The associated field. */
117 /* The value of the qualifier. */
120 /* The type of the variant after transformation. */
125 /* A hash table used to cache the result of annotate_value. */
126 static GTY ((if_marked ("tree_int_map_marked_p"),
127 param_is (struct tree_int_map
))) htab_t annotate_value_cache
;
129 static bool allocatable_size_p (tree
, bool);
130 static void prepend_one_attribute_to (struct attrib
**,
131 enum attr_type
, tree
, tree
, Node_Id
);
132 static void prepend_attributes (Entity_Id
, struct attrib
**);
133 static tree
elaborate_expression (Node_Id
, Entity_Id
, tree
, bool, bool, bool);
134 static bool type_has_variable_size (tree
);
135 static tree
elaborate_expression_1 (tree
, Entity_Id
, tree
, bool, bool);
136 static tree
elaborate_expression_2 (tree
, Entity_Id
, tree
, bool, bool,
138 static tree
gnat_to_gnu_component_type (Entity_Id
, bool, bool);
139 static tree
gnat_to_gnu_param (Entity_Id
, Mechanism_Type
, Entity_Id
, bool,
141 static tree
gnat_to_gnu_field (Entity_Id
, tree
, int, bool, bool);
142 static bool same_discriminant_p (Entity_Id
, Entity_Id
);
143 static bool array_type_has_nonaliased_component (tree
, Entity_Id
);
144 static bool compile_time_known_address_p (Node_Id
);
145 static bool cannot_be_superflat_p (Node_Id
);
146 static bool constructor_address_p (tree
);
147 static void components_to_record (tree
, Node_Id
, tree
, int, bool, bool, bool,
148 bool, bool, bool, bool, bool, tree
, tree
*);
149 static Uint
annotate_value (tree
);
150 static void annotate_rep (Entity_Id
, tree
);
151 static tree
build_position_list (tree
, bool, tree
, tree
, unsigned int, tree
);
152 static vec
<subst_pair
> build_subst_list (Entity_Id
, Entity_Id
, bool);
153 static vec
<variant_desc
> build_variant_list (tree
,
156 static tree
validate_size (Uint
, tree
, Entity_Id
, enum tree_code
, bool, bool);
157 static void set_rm_size (Uint
, tree
, Entity_Id
);
158 static unsigned int validate_alignment (Uint
, Entity_Id
, unsigned int);
159 static void check_ok_for_atomic (tree
, Entity_Id
, bool);
160 static tree
create_field_decl_from (tree
, tree
, tree
, tree
, tree
,
162 static tree
create_rep_part (tree
, tree
, tree
);
163 static tree
get_rep_part (tree
);
164 static tree
create_variant_part_from (tree
, vec
<variant_desc
> , tree
,
165 tree
, vec
<subst_pair
> );
166 static void copy_and_substitute_in_size (tree
, tree
, vec
<subst_pair
> );
168 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
169 to pass around calls performing profile compatibility checks. */
172 Entity_Id gnat_entity
; /* The Ada subprogram entity. */
173 tree ada_fntype
; /* The corresponding GCC type node. */
174 tree btin_fntype
; /* The GCC builtin function type node. */
177 static bool intrin_profiles_compatible_p (intrin_binding_t
*);
179 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
180 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
181 and associate the ..._DECL node with the input GNAT defining identifier.
183 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
184 initial value (in GCC tree form). This is optional for a variable. For
185 a renamed entity, GNU_EXPR gives the object being renamed.
187 DEFINITION is nonzero if this call is intended for a definition. This is
188 used for separate compilation where it is necessary to know whether an
189 external declaration or a definition must be created if the GCC equivalent
190 was not created previously. The value of 1 is normally used for a nonzero
191 DEFINITION, but a value of 2 is used in special circumstances, defined in
195 gnat_to_gnu_entity (Entity_Id gnat_entity
, tree gnu_expr
, int definition
)
197 /* Contains the kind of the input GNAT node. */
198 const Entity_Kind kind
= Ekind (gnat_entity
);
199 /* True if this is a type. */
200 const bool is_type
= IN (kind
, Type_Kind
);
201 /* True if debug info is requested for this entity. */
202 const bool debug_info_p
= Needs_Debug_Info (gnat_entity
);
203 /* True if this entity is to be considered as imported. */
204 const bool imported_p
205 = (Is_Imported (gnat_entity
) && No (Address_Clause (gnat_entity
)));
206 /* For a type, contains the equivalent GNAT node to be used in gigi. */
207 Entity_Id gnat_equiv_type
= Empty
;
208 /* Temporary used to walk the GNAT tree. */
210 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
211 This node will be associated with the GNAT node by calling at the end
212 of the `switch' statement. */
213 tree gnu_decl
= NULL_TREE
;
214 /* Contains the GCC type to be used for the GCC node. */
215 tree gnu_type
= NULL_TREE
;
216 /* Contains the GCC size tree to be used for the GCC node. */
217 tree gnu_size
= NULL_TREE
;
218 /* Contains the GCC name to be used for the GCC node. */
219 tree gnu_entity_name
;
220 /* True if we have already saved gnu_decl as a GNAT association. */
222 /* True if we incremented defer_incomplete_level. */
223 bool this_deferred
= false;
224 /* True if we incremented force_global. */
225 bool this_global
= false;
226 /* True if we should check to see if elaborated during processing. */
227 bool maybe_present
= false;
228 /* True if we made GNU_DECL and its type here. */
229 bool this_made_decl
= false;
230 /* Size and alignment of the GCC node, if meaningful. */
231 unsigned int esize
= 0, align
= 0;
232 /* Contains the list of attributes directly attached to the entity. */
233 struct attrib
*attr_list
= NULL
;
235 /* Since a use of an Itype is a definition, process it as such if it
236 is not in a with'ed unit. */
239 && Is_Itype (gnat_entity
)
240 && !present_gnu_tree (gnat_entity
)
241 && In_Extended_Main_Code_Unit (gnat_entity
))
243 /* Ensure that we are in a subprogram mentioned in the Scope chain of
244 this entity, our current scope is global, or we encountered a task
245 or entry (where we can't currently accurately check scoping). */
246 if (!current_function_decl
247 || DECL_ELABORATION_PROC_P (current_function_decl
))
249 process_type (gnat_entity
);
250 return get_gnu_tree (gnat_entity
);
253 for (gnat_temp
= Scope (gnat_entity
);
255 gnat_temp
= Scope (gnat_temp
))
257 if (Is_Type (gnat_temp
))
258 gnat_temp
= Underlying_Type (gnat_temp
);
260 if (Ekind (gnat_temp
) == E_Subprogram_Body
)
262 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp
)));
264 if (IN (Ekind (gnat_temp
), Subprogram_Kind
)
265 && Present (Protected_Body_Subprogram (gnat_temp
)))
266 gnat_temp
= Protected_Body_Subprogram (gnat_temp
);
268 if (Ekind (gnat_temp
) == E_Entry
269 || Ekind (gnat_temp
) == E_Entry_Family
270 || Ekind (gnat_temp
) == E_Task_Type
271 || (IN (Ekind (gnat_temp
), Subprogram_Kind
)
272 && present_gnu_tree (gnat_temp
)
273 && (current_function_decl
274 == gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0))))
276 process_type (gnat_entity
);
277 return get_gnu_tree (gnat_entity
);
281 /* This abort means the Itype has an incorrect scope, i.e. that its
282 scope does not correspond to the subprogram it is declared in. */
286 /* If we've already processed this entity, return what we got last time.
287 If we are defining the node, we should not have already processed it.
288 In that case, we will abort below when we try to save a new GCC tree
289 for this object. We also need to handle the case of getting a dummy
290 type when a Full_View exists. */
291 if ((!definition
|| (is_type
&& imported_p
))
292 && present_gnu_tree (gnat_entity
))
294 gnu_decl
= get_gnu_tree (gnat_entity
);
296 if (TREE_CODE (gnu_decl
) == TYPE_DECL
297 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
))
298 && IN (kind
, Incomplete_Or_Private_Kind
)
299 && Present (Full_View (gnat_entity
)))
302 = gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 0);
303 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
304 save_gnu_tree (gnat_entity
, gnu_decl
, false);
310 /* If this is a numeric or enumeral type, or an access type, a nonzero
311 Esize must be specified unless it was specified by the programmer. */
312 gcc_assert (!Unknown_Esize (gnat_entity
)
313 || Has_Size_Clause (gnat_entity
)
314 || (!IN (kind
, Numeric_Kind
)
315 && !IN (kind
, Enumeration_Kind
)
316 && (!IN (kind
, Access_Kind
)
317 || kind
== E_Access_Protected_Subprogram_Type
318 || kind
== E_Anonymous_Access_Protected_Subprogram_Type
319 || kind
== E_Access_Subtype
)));
321 /* The RM size must be specified for all discrete and fixed-point types. */
322 gcc_assert (!(IN (kind
, Discrete_Or_Fixed_Point_Kind
)
323 && Unknown_RM_Size (gnat_entity
)));
325 /* If we get here, it means we have not yet done anything with this entity.
326 If we are not defining it, it must be a type or an entity that is defined
327 elsewhere or externally, otherwise we should have defined it already. */
328 gcc_assert (definition
329 || type_annotate_only
331 || kind
== E_Discriminant
332 || kind
== E_Component
334 || (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
335 || Is_Public (gnat_entity
));
337 /* Get the name of the entity and set up the line number and filename of
338 the original definition for use in any decl we make. */
339 gnu_entity_name
= get_entity_name (gnat_entity
);
340 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
342 /* For cases when we are not defining (i.e., we are referencing from
343 another compilation unit) public entities, show we are at global level
344 for the purpose of computing scopes. Don't do this for components or
345 discriminants since the relevant test is whether or not the record is
348 && kind
!= E_Component
349 && kind
!= E_Discriminant
350 && Is_Public (gnat_entity
)
351 && !Is_Statically_Allocated (gnat_entity
))
352 force_global
++, this_global
= true;
354 /* Handle any attributes directly attached to the entity. */
355 if (Has_Gigi_Rep_Item (gnat_entity
))
356 prepend_attributes (gnat_entity
, &attr_list
);
358 /* Do some common processing for types. */
361 /* Compute the equivalent type to be used in gigi. */
362 gnat_equiv_type
= Gigi_Equivalent_Type (gnat_entity
);
364 /* Machine_Attributes on types are expected to be propagated to
365 subtypes. The corresponding Gigi_Rep_Items are only attached
366 to the first subtype though, so we handle the propagation here. */
367 if (Base_Type (gnat_entity
) != gnat_entity
368 && !Is_First_Subtype (gnat_entity
)
369 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity
))))
370 prepend_attributes (First_Subtype (Base_Type (gnat_entity
)),
373 /* Compute a default value for the size of an elementary type. */
374 if (Known_Esize (gnat_entity
) && Is_Elementary_Type (gnat_entity
))
376 unsigned int max_esize
;
378 gcc_assert (UI_Is_In_Int_Range (Esize (gnat_entity
)));
379 esize
= UI_To_Int (Esize (gnat_entity
));
381 if (IN (kind
, Float_Kind
))
382 max_esize
= fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE
);
383 else if (IN (kind
, Access_Kind
))
384 max_esize
= POINTER_SIZE
* 2;
386 max_esize
= LONG_LONG_TYPE_SIZE
;
388 if (esize
> max_esize
)
396 /* If this is a use of a deferred constant without address clause,
397 get its full definition. */
399 && No (Address_Clause (gnat_entity
))
400 && Present (Full_View (gnat_entity
)))
403 = gnat_to_gnu_entity (Full_View (gnat_entity
), gnu_expr
, 0);
408 /* If we have an external constant that we are not defining, get the
409 expression that is was defined to represent. We may throw it away
410 later if it is not a constant. But do not retrieve the expression
411 if it is an allocator because the designated type might be dummy
414 && !No_Initialization (Declaration_Node (gnat_entity
))
415 && Present (Expression (Declaration_Node (gnat_entity
)))
416 && Nkind (Expression (Declaration_Node (gnat_entity
)))
419 bool went_into_elab_proc
= false;
420 int save_force_global
= force_global
;
422 /* The expression may contain N_Expression_With_Actions nodes and
423 thus object declarations from other units. In this case, even
424 though the expression will eventually be discarded since not a
425 constant, the declarations would be stuck either in the global
426 varpool or in the current scope. Therefore we force the local
427 context and create a fake scope that we'll zap at the end. */
428 if (!current_function_decl
)
430 current_function_decl
= get_elaboration_procedure ();
431 went_into_elab_proc
= true;
436 gnu_expr
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
439 force_global
= save_force_global
;
440 if (went_into_elab_proc
)
441 current_function_decl
= NULL_TREE
;
444 /* Ignore deferred constant definitions without address clause since
445 they are processed fully in the front-end. If No_Initialization
446 is set, this is not a deferred constant but a constant whose value
447 is built manually. And constants that are renamings are handled
451 && No (Address_Clause (gnat_entity
))
452 && !No_Initialization (Declaration_Node (gnat_entity
))
453 && No (Renamed_Object (gnat_entity
)))
455 gnu_decl
= error_mark_node
;
460 /* Ignore constant definitions already marked with the error node. See
461 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
464 && present_gnu_tree (gnat_entity
)
465 && get_gnu_tree (gnat_entity
) == error_mark_node
)
467 maybe_present
= true;
474 /* We used to special case VMS exceptions here to directly map them to
475 their associated condition code. Since this code had to be masked
476 dynamically to strip off the severity bits, this caused trouble in
477 the GCC/ZCX case because the "type" pointers we store in the tables
478 have to be static. We now don't special case here anymore, and let
479 the regular processing take place, which leaves us with a regular
480 exception data object for VMS exceptions too. The condition code
481 mapping is taken care of by the front end and the bitmasking by the
488 /* The GNAT record where the component was defined. */
489 Entity_Id gnat_record
= Underlying_Type (Scope (gnat_entity
));
491 /* If the variable is an inherited record component (in the case of
492 extended record types), just return the inherited entity, which
493 must be a FIELD_DECL. Likewise for discriminants.
494 For discriminants of untagged records which have explicit
495 stored discriminants, return the entity for the corresponding
496 stored discriminant. Also use Original_Record_Component
497 if the record has a private extension. */
498 if (Present (Original_Record_Component (gnat_entity
))
499 && Original_Record_Component (gnat_entity
) != gnat_entity
)
502 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity
),
503 gnu_expr
, definition
);
508 /* If the enclosing record has explicit stored discriminants,
509 then it is an untagged record. If the Corresponding_Discriminant
510 is not empty then this must be a renamed discriminant and its
511 Original_Record_Component must point to the corresponding explicit
512 stored discriminant (i.e. we should have taken the previous
514 else if (Present (Corresponding_Discriminant (gnat_entity
))
515 && Is_Tagged_Type (gnat_record
))
517 /* A tagged record has no explicit stored discriminants. */
518 gcc_assert (First_Discriminant (gnat_record
)
519 == First_Stored_Discriminant (gnat_record
));
521 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity
),
522 gnu_expr
, definition
);
527 else if (Present (CR_Discriminant (gnat_entity
))
528 && type_annotate_only
)
530 gnu_decl
= gnat_to_gnu_entity (CR_Discriminant (gnat_entity
),
531 gnu_expr
, definition
);
536 /* If the enclosing record has explicit stored discriminants, then
537 it is an untagged record. If the Corresponding_Discriminant
538 is not empty then this must be a renamed discriminant and its
539 Original_Record_Component must point to the corresponding explicit
540 stored discriminant (i.e. we should have taken the first
542 else if (Present (Corresponding_Discriminant (gnat_entity
))
543 && (First_Discriminant (gnat_record
)
544 != First_Stored_Discriminant (gnat_record
)))
547 /* Otherwise, if we are not defining this and we have no GCC type
548 for the containing record, make one for it. Then we should
549 have made our own equivalent. */
550 else if (!definition
&& !present_gnu_tree (gnat_record
))
552 /* ??? If this is in a record whose scope is a protected
553 type and we have an Original_Record_Component, use it.
554 This is a workaround for major problems in protected type
556 Entity_Id Scop
= Scope (Scope (gnat_entity
));
557 if ((Is_Protected_Type (Scop
)
558 || (Is_Private_Type (Scop
)
559 && Present (Full_View (Scop
))
560 && Is_Protected_Type (Full_View (Scop
))))
561 && Present (Original_Record_Component (gnat_entity
)))
564 = gnat_to_gnu_entity (Original_Record_Component
571 gnat_to_gnu_entity (Scope (gnat_entity
), NULL_TREE
, 0);
572 gnu_decl
= get_gnu_tree (gnat_entity
);
578 /* Here we have no GCC type and this is a reference rather than a
579 definition. This should never happen. Most likely the cause is
580 reference before declaration in the gnat tree for gnat_entity. */
584 case E_Loop_Parameter
:
585 case E_Out_Parameter
:
588 /* Simple variables, loop variables, Out parameters and exceptions. */
592 = ((kind
== E_Constant
|| kind
== E_Variable
)
593 && Is_True_Constant (gnat_entity
)
594 && !Treat_As_Volatile (gnat_entity
)
595 && (((Nkind (Declaration_Node (gnat_entity
))
596 == N_Object_Declaration
)
597 && Present (Expression (Declaration_Node (gnat_entity
))))
598 || Present (Renamed_Object (gnat_entity
))
600 bool inner_const_flag
= const_flag
;
601 bool static_p
= Is_Statically_Allocated (gnat_entity
);
602 bool mutable_p
= false;
603 bool used_by_ref
= false;
604 tree gnu_ext_name
= NULL_TREE
;
605 tree renamed_obj
= NULL_TREE
;
606 tree gnu_object_size
;
608 if (Present (Renamed_Object (gnat_entity
)) && !definition
)
610 if (kind
== E_Exception
)
611 gnu_expr
= gnat_to_gnu_entity (Renamed_Entity (gnat_entity
),
614 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_entity
));
617 /* Get the type after elaborating the renamed object. */
618 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
620 /* If this is a standard exception definition, then use the standard
621 exception type. This is necessary to make sure that imported and
622 exported views of exceptions are properly merged in LTO mode. */
623 if (TREE_CODE (TYPE_NAME (gnu_type
)) == TYPE_DECL
624 && DECL_NAME (TYPE_NAME (gnu_type
)) == exception_data_name_id
)
625 gnu_type
= except_type_node
;
627 /* For a debug renaming declaration, build a debug-only entity. */
628 if (Present (Debug_Renaming_Link (gnat_entity
)))
630 /* Force a non-null value to make sure the symbol is retained. */
631 tree value
= build1 (INDIRECT_REF
, gnu_type
,
633 build_pointer_type (gnu_type
),
634 integer_minus_one_node
));
635 gnu_decl
= build_decl (input_location
,
636 VAR_DECL
, gnu_entity_name
, gnu_type
);
637 SET_DECL_VALUE_EXPR (gnu_decl
, value
);
638 DECL_HAS_VALUE_EXPR_P (gnu_decl
) = 1;
639 gnat_pushdecl (gnu_decl
, gnat_entity
);
643 /* If this is a loop variable, its type should be the base type.
644 This is because the code for processing a loop determines whether
645 a normal loop end test can be done by comparing the bounds of the
646 loop against those of the base type, which is presumed to be the
647 size used for computation. But this is not correct when the size
648 of the subtype is smaller than the type. */
649 if (kind
== E_Loop_Parameter
)
650 gnu_type
= get_base_type (gnu_type
);
652 /* Reject non-renamed objects whose type is an unconstrained array or
653 any object whose type is a dummy type or void. */
654 if ((TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
655 && No (Renamed_Object (gnat_entity
)))
656 || TYPE_IS_DUMMY_P (gnu_type
)
657 || TREE_CODE (gnu_type
) == VOID_TYPE
)
659 gcc_assert (type_annotate_only
);
662 return error_mark_node
;
665 /* If an alignment is specified, use it if valid. Note that exceptions
666 are objects but don't have an alignment. We must do this before we
667 validate the size, since the alignment can affect the size. */
668 if (kind
!= E_Exception
&& Known_Alignment (gnat_entity
))
670 gcc_assert (Present (Alignment (gnat_entity
)));
672 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
673 TYPE_ALIGN (gnu_type
));
675 /* No point in changing the type if there is an address clause
676 as the final type of the object will be a reference type. */
677 if (Present (Address_Clause (gnat_entity
)))
681 tree orig_type
= gnu_type
;
684 = maybe_pad_type (gnu_type
, NULL_TREE
, align
, gnat_entity
,
685 false, false, definition
, true);
687 /* If a padding record was made, declare it now since it will
688 never be declared otherwise. This is necessary to ensure
689 that its subtrees are properly marked. */
690 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
691 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, NULL
, true,
692 debug_info_p
, gnat_entity
);
696 /* If we are defining the object, see if it has a Size and validate it
697 if so. If we are not defining the object and a Size clause applies,
698 simply retrieve the value. We don't want to ignore the clause and
699 it is expected to have been validated already. Then get the new
702 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
,
703 gnat_entity
, VAR_DECL
, false,
704 Has_Size_Clause (gnat_entity
));
705 else if (Has_Size_Clause (gnat_entity
))
706 gnu_size
= UI_To_gnu (Esize (gnat_entity
), bitsizetype
);
711 = make_type_from_size (gnu_type
, gnu_size
,
712 Has_Biased_Representation (gnat_entity
));
714 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0))
715 gnu_size
= NULL_TREE
;
718 /* If this object has self-referential size, it must be a record with
719 a default discriminant. We are supposed to allocate an object of
720 the maximum size in this case, unless it is a constant with an
721 initializing expression, in which case we can get the size from
722 that. Note that the resulting size may still be a variable, so
723 this may end up with an indirect allocation. */
724 if (No (Renamed_Object (gnat_entity
))
725 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
727 if (gnu_expr
&& kind
== E_Constant
)
729 tree size
= TYPE_SIZE (TREE_TYPE (gnu_expr
));
730 if (CONTAINS_PLACEHOLDER_P (size
))
732 /* If the initializing expression is itself a constant,
733 despite having a nominal type with self-referential
734 size, we can get the size directly from it. */
735 if (TREE_CODE (gnu_expr
) == COMPONENT_REF
737 (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
738 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == VAR_DECL
739 && (TREE_READONLY (TREE_OPERAND (gnu_expr
, 0))
740 || DECL_READONLY_ONCE_ELAB
741 (TREE_OPERAND (gnu_expr
, 0))))
742 gnu_size
= DECL_SIZE (TREE_OPERAND (gnu_expr
, 0));
745 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_expr
);
750 /* We may have no GNU_EXPR because No_Initialization is
751 set even though there's an Expression. */
752 else if (kind
== E_Constant
753 && (Nkind (Declaration_Node (gnat_entity
))
754 == N_Object_Declaration
)
755 && Present (Expression (Declaration_Node (gnat_entity
))))
757 = TYPE_SIZE (gnat_to_gnu_type
759 (Expression (Declaration_Node (gnat_entity
)))));
762 gnu_size
= max_size (TYPE_SIZE (gnu_type
), true);
766 /* If we are at global level and the size isn't constant, call
767 elaborate_expression_1 to make a variable for it rather than
768 calculating it each time. */
769 if (global_bindings_p () && !TREE_CONSTANT (gnu_size
))
770 gnu_size
= elaborate_expression_1 (gnu_size
, gnat_entity
,
771 get_identifier ("SIZE"),
775 /* If the size is zero byte, make it one byte since some linkers have
776 troubles with zero-sized objects. If the object will have a
777 template, that will make it nonzero so don't bother. Also avoid
778 doing that for an object renaming or an object with an address
779 clause, as we would lose useful information on the view size
780 (e.g. for null array slices) and we are not allocating the object
783 && integer_zerop (gnu_size
)
784 && !TREE_OVERFLOW (gnu_size
))
785 || (TYPE_SIZE (gnu_type
)
786 && integer_zerop (TYPE_SIZE (gnu_type
))
787 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type
))))
788 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
789 || !Is_Array_Type (Etype (gnat_entity
)))
790 && No (Renamed_Object (gnat_entity
))
791 && No (Address_Clause (gnat_entity
)))
792 gnu_size
= bitsize_unit_node
;
794 /* If this is an object with no specified size and alignment, and
795 if either it is atomic or we are not optimizing alignment for
796 space and it is composite and not an exception, an Out parameter
797 or a reference to another object, and the size of its type is a
798 constant, set the alignment to the smallest one which is not
799 smaller than the size, with an appropriate cap. */
800 if (!gnu_size
&& align
== 0
801 && (Is_Atomic (gnat_entity
)
802 || (!Optimize_Alignment_Space (gnat_entity
)
803 && kind
!= E_Exception
804 && kind
!= E_Out_Parameter
805 && Is_Composite_Type (Etype (gnat_entity
))
806 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
807 && !Is_Exported (gnat_entity
)
809 && No (Renamed_Object (gnat_entity
))
810 && No (Address_Clause (gnat_entity
))))
811 && TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
)
813 unsigned int size_cap
, align_cap
;
815 /* No point in promoting the alignment if this doesn't prevent
816 BLKmode access to the object, in particular block copy, as
817 this will for example disable the NRV optimization for it.
818 No point in jumping through all the hoops needed in order
819 to support BIGGEST_ALIGNMENT if we don't really have to.
820 So we cap to the smallest alignment that corresponds to
821 a known efficient memory access pattern of the target. */
822 if (Is_Atomic (gnat_entity
))
825 align_cap
= BIGGEST_ALIGNMENT
;
829 size_cap
= MAX_FIXED_MODE_SIZE
;
830 align_cap
= get_mode_alignment (ptr_mode
);
833 if (!host_integerp (TYPE_SIZE (gnu_type
), 1)
834 || compare_tree_int (TYPE_SIZE (gnu_type
), size_cap
) > 0)
836 else if (compare_tree_int (TYPE_SIZE (gnu_type
), align_cap
) > 0)
839 align
= ceil_pow2 (tree_low_cst (TYPE_SIZE (gnu_type
), 1));
841 /* But make sure not to under-align the object. */
842 if (align
<= TYPE_ALIGN (gnu_type
))
845 /* And honor the minimum valid atomic alignment, if any. */
846 #ifdef MINIMUM_ATOMIC_ALIGNMENT
847 else if (align
< MINIMUM_ATOMIC_ALIGNMENT
)
848 align
= MINIMUM_ATOMIC_ALIGNMENT
;
852 /* If the object is set to have atomic components, find the component
853 type and validate it.
855 ??? Note that we ignore Has_Volatile_Components on objects; it's
856 not at all clear what to do in that case. */
857 if (Has_Atomic_Components (gnat_entity
))
859 tree gnu_inner
= (TREE_CODE (gnu_type
) == ARRAY_TYPE
860 ? TREE_TYPE (gnu_type
) : gnu_type
);
862 while (TREE_CODE (gnu_inner
) == ARRAY_TYPE
863 && TYPE_MULTI_ARRAY_P (gnu_inner
))
864 gnu_inner
= TREE_TYPE (gnu_inner
);
866 check_ok_for_atomic (gnu_inner
, gnat_entity
, true);
869 /* Now check if the type of the object allows atomic access. Note
870 that we must test the type, even if this object has size and
871 alignment to allow such access, because we will be going inside
872 the padded record to assign to the object. We could fix this by
873 always copying via an intermediate value, but it's not clear it's
875 if (Is_Atomic (gnat_entity
))
876 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
878 /* If this is an aliased object with an unconstrained nominal subtype,
879 make a type that includes the template. */
880 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
881 && Is_Array_Type (Etype (gnat_entity
))
882 && !type_annotate_only
)
885 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity
)));
887 = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array
),
889 concat_name (gnu_entity_name
,
894 /* ??? If this is an object of CW type initialized to a value, try to
895 ensure that the object is sufficient aligned for this value, but
896 without pessimizing the allocation. This is a kludge necessary
897 because we don't support dynamic alignment. */
899 && Ekind (Etype (gnat_entity
)) == E_Class_Wide_Subtype
900 && No (Renamed_Object (gnat_entity
))
901 && No (Address_Clause (gnat_entity
)))
902 align
= get_target_system_allocator_alignment () * BITS_PER_UNIT
;
904 #ifdef MINIMUM_ATOMIC_ALIGNMENT
905 /* If the size is a constant and no alignment is specified, force
906 the alignment to be the minimum valid atomic alignment. The
907 restriction on constant size avoids problems with variable-size
908 temporaries; if the size is variable, there's no issue with
909 atomic access. Also don't do this for a constant, since it isn't
910 necessary and can interfere with constant replacement. Finally,
911 do not do it for Out parameters since that creates an
912 size inconsistency with In parameters. */
914 && MINIMUM_ATOMIC_ALIGNMENT
> TYPE_ALIGN (gnu_type
)
915 && !FLOAT_TYPE_P (gnu_type
)
916 && !const_flag
&& No (Renamed_Object (gnat_entity
))
917 && !imported_p
&& No (Address_Clause (gnat_entity
))
918 && kind
!= E_Out_Parameter
919 && (gnu_size
? TREE_CODE (gnu_size
) == INTEGER_CST
920 : TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
))
921 align
= MINIMUM_ATOMIC_ALIGNMENT
;
924 /* Make a new type with the desired size and alignment, if needed.
925 But do not take into account alignment promotions to compute the
926 size of the object. */
927 gnu_object_size
= gnu_size
? gnu_size
: TYPE_SIZE (gnu_type
);
928 if (gnu_size
|| align
> 0)
930 tree orig_type
= gnu_type
;
932 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
933 false, false, definition
, true);
935 /* If a padding record was made, declare it now since it will
936 never be declared otherwise. This is necessary to ensure
937 that its subtrees are properly marked. */
938 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
939 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, NULL
, true,
940 debug_info_p
, gnat_entity
);
943 /* If this is a renaming, avoid as much as possible to create a new
944 object. However, in several cases, creating it is required.
945 This processing needs to be applied to the raw expression so
946 as to make it more likely to rename the underlying object. */
947 if (Present (Renamed_Object (gnat_entity
)))
949 bool create_normal_object
= false;
951 /* If the renamed object had padding, strip off the reference
952 to the inner object and reset our type. */
953 if ((TREE_CODE (gnu_expr
) == COMPONENT_REF
954 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
955 /* Strip useless conversions around the object. */
956 || gnat_useless_type_conversion (gnu_expr
))
958 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
959 gnu_type
= TREE_TYPE (gnu_expr
);
962 /* Or else, if the renamed object has an unconstrained type with
963 default discriminant, use the padded type. */
964 else if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_expr
))
965 && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_expr
)))
967 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
968 gnu_type
= TREE_TYPE (gnu_expr
);
970 /* Case 1: If this is a constant renaming stemming from a function
971 call, treat it as a normal object whose initial value is what
972 is being renamed. RM 3.3 says that the result of evaluating a
973 function call is a constant object. As a consequence, it can
974 be the inner object of a constant renaming. In this case, the
975 renaming must be fully instantiated, i.e. it cannot be a mere
976 reference to (part of) an existing object. */
979 tree inner_object
= gnu_expr
;
980 while (handled_component_p (inner_object
))
981 inner_object
= TREE_OPERAND (inner_object
, 0);
982 if (TREE_CODE (inner_object
) == CALL_EXPR
)
983 create_normal_object
= true;
986 /* Otherwise, see if we can proceed with a stabilized version of
987 the renamed entity or if we need to make a new object. */
988 if (!create_normal_object
)
990 tree maybe_stable_expr
= NULL_TREE
;
993 /* Case 2: If the renaming entity need not be materialized and
994 the renamed expression is something we can stabilize, use
995 that for the renaming. At the global level, we can only do
996 this if we know no SAVE_EXPRs need be made, because the
997 expression we return might be used in arbitrary conditional
998 branches so we must force the evaluation of the SAVE_EXPRs
999 immediately and this requires a proper function context.
1000 Note that an external constant is at the global level. */
1001 if (!Materialize_Entity (gnat_entity
)
1002 && (!((!definition
&& kind
== E_Constant
)
1003 || global_bindings_p ())
1004 || (staticp (gnu_expr
)
1005 && !TREE_SIDE_EFFECTS (gnu_expr
))))
1008 = gnat_stabilize_reference (gnu_expr
, true, &stable
);
1012 /* ??? No DECL_EXPR is created so we need to mark
1013 the expression manually lest it is shared. */
1014 if ((!definition
&& kind
== E_Constant
)
1015 || global_bindings_p ())
1016 MARK_VISITED (maybe_stable_expr
);
1017 gnu_decl
= maybe_stable_expr
;
1018 save_gnu_tree (gnat_entity
, gnu_decl
, true);
1020 annotate_object (gnat_entity
, gnu_type
, NULL_TREE
,
1022 /* This assertion will fail if the renamed object
1023 isn't aligned enough as to make it possible to
1024 honor the alignment set on the renaming. */
1027 unsigned int renamed_align
1029 ? DECL_ALIGN (gnu_decl
)
1030 : TYPE_ALIGN (TREE_TYPE (gnu_decl
));
1031 gcc_assert (renamed_align
>= align
);
1036 /* The stabilization failed. Keep maybe_stable_expr
1037 untouched here to let the pointer case below know
1038 about that failure. */
1041 /* Case 3: If this is a constant renaming and creating a
1042 new object is allowed and cheap, treat it as a normal
1043 object whose initial value is what is being renamed. */
1045 && !Is_Composite_Type
1046 (Underlying_Type (Etype (gnat_entity
))))
1049 /* Case 4: Make this into a constant pointer to the object we
1050 are to rename and attach the object to the pointer if it is
1051 something we can stabilize.
1053 From the proper scope, attached objects will be referenced
1054 directly instead of indirectly via the pointer to avoid
1055 subtle aliasing problems with non-addressable entities.
1056 They have to be stable because we must not evaluate the
1057 variables in the expression every time the renaming is used.
1058 The pointer is called a "renaming" pointer in this case.
1060 In the rare cases where we cannot stabilize the renamed
1061 object, we just make a "bare" pointer, and the renamed
1062 entity is always accessed indirectly through it. */
1065 /* We need to preserve the volatileness of the renamed
1066 object through the indirection. */
1067 if (TREE_THIS_VOLATILE (gnu_expr
)
1068 && !TYPE_VOLATILE (gnu_type
))
1070 = build_qualified_type (gnu_type
,
1071 (TYPE_QUALS (gnu_type
)
1072 | TYPE_QUAL_VOLATILE
));
1073 gnu_type
= build_reference_type (gnu_type
);
1074 inner_const_flag
= TREE_READONLY (gnu_expr
);
1077 /* If the previous attempt at stabilizing failed, there
1078 is no point in trying again and we reuse the result
1079 without attaching it to the pointer. In this case it
1080 will only be used as the initializing expression of
1081 the pointer and thus needs no special treatment with
1082 regard to multiple evaluations. */
1083 if (maybe_stable_expr
)
1086 /* Otherwise, try to stabilize and attach the expression
1087 to the pointer if the stabilization succeeds.
1089 Note that this might introduce SAVE_EXPRs and we don't
1090 check whether we're at the global level or not. This
1091 is fine since we are building a pointer initializer and
1092 neither the pointer nor the initializing expression can
1093 be accessed before the pointer elaboration has taken
1094 place in a correct program.
1096 These SAVE_EXPRs will be evaluated at the right place
1097 by either the evaluation of the initializer for the
1098 non-global case or the elaboration code for the global
1099 case, and will be attached to the elaboration procedure
1100 in the latter case. */
1104 = gnat_stabilize_reference (gnu_expr
, true, &stable
);
1107 renamed_obj
= maybe_stable_expr
;
1109 /* Attaching is actually performed downstream, as soon
1110 as we have a VAR_DECL for the pointer we make. */
1113 gnu_expr
= build_unary_op (ADDR_EXPR
, gnu_type
,
1116 gnu_size
= NULL_TREE
;
1122 /* Make a volatile version of this object's type if we are to make
1123 the object volatile. We also interpret 13.3(19) conservatively
1124 and disallow any optimizations for such a non-constant object. */
1125 if ((Treat_As_Volatile (gnat_entity
)
1127 && gnu_type
!= except_type_node
1128 && (Is_Exported (gnat_entity
)
1130 || Present (Address_Clause (gnat_entity
)))))
1131 && !TYPE_VOLATILE (gnu_type
))
1132 gnu_type
= build_qualified_type (gnu_type
,
1133 (TYPE_QUALS (gnu_type
)
1134 | TYPE_QUAL_VOLATILE
));
1136 /* If we are defining an aliased object whose nominal subtype is
1137 unconstrained, the object is a record that contains both the
1138 template and the object. If there is an initializer, it will
1139 have already been converted to the right type, but we need to
1140 create the template if there is no initializer. */
1143 && TREE_CODE (gnu_type
) == RECORD_TYPE
1144 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
1145 /* Beware that padding might have been introduced above. */
1146 || (TYPE_PADDING_P (gnu_type
)
1147 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
1149 && TYPE_CONTAINS_TEMPLATE_P
1150 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))))
1153 = TYPE_PADDING_P (gnu_type
)
1154 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
1155 : TYPE_FIELDS (gnu_type
);
1156 vec
<constructor_elt
, va_gc
> *v
;
1158 tree t
= build_template (TREE_TYPE (template_field
),
1159 TREE_TYPE (DECL_CHAIN (template_field
)),
1161 CONSTRUCTOR_APPEND_ELT (v
, template_field
, t
);
1162 gnu_expr
= gnat_build_constructor (gnu_type
, v
);
1165 /* Convert the expression to the type of the object except in the
1166 case where the object's type is unconstrained or the object's type
1167 is a padded record whose field is of self-referential size. In
1168 the former case, converting will generate unnecessary evaluations
1169 of the CONSTRUCTOR to compute the size and in the latter case, we
1170 want to only copy the actual data. Also don't convert to a record
1171 type with a variant part from a record type without one, to keep
1172 the object simpler. */
1174 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1175 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1176 && !(TYPE_IS_PADDING_P (gnu_type
)
1177 && CONTAINS_PLACEHOLDER_P
1178 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))
1179 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1180 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
1181 && get_variant_part (gnu_type
) != NULL_TREE
1182 && get_variant_part (TREE_TYPE (gnu_expr
)) == NULL_TREE
))
1183 gnu_expr
= convert (gnu_type
, gnu_expr
);
1185 /* If this is a pointer that doesn't have an initializing expression,
1186 initialize it to NULL, unless the object is imported. */
1188 && (POINTER_TYPE_P (gnu_type
) || TYPE_IS_FAT_POINTER_P (gnu_type
))
1190 && !Is_Imported (gnat_entity
))
1191 gnu_expr
= integer_zero_node
;
1193 /* If we are defining the object and it has an Address clause, we must
1194 either get the address expression from the saved GCC tree for the
1195 object if it has a Freeze node, or elaborate the address expression
1196 here since the front-end has guaranteed that the elaboration has no
1197 effects in this case. */
1198 if (definition
&& Present (Address_Clause (gnat_entity
)))
1200 Node_Id gnat_expr
= Expression (Address_Clause (gnat_entity
));
1202 = present_gnu_tree (gnat_entity
)
1203 ? get_gnu_tree (gnat_entity
) : gnat_to_gnu (gnat_expr
);
1205 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
1207 /* Ignore the size. It's either meaningless or was handled
1209 gnu_size
= NULL_TREE
;
1210 /* Convert the type of the object to a reference type that can
1211 alias everything as per 13.3(19). */
1213 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1214 gnu_address
= convert (gnu_type
, gnu_address
);
1217 = !Is_Public (gnat_entity
)
1218 || compile_time_known_address_p (gnat_expr
);
1220 /* If this is a deferred constant, the initializer is attached to
1222 if (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
1225 (Expression (Declaration_Node (Full_View (gnat_entity
))));
1227 /* If we don't have an initializing expression for the underlying
1228 variable, the initializing expression for the pointer is the
1229 specified address. Otherwise, we have to make a COMPOUND_EXPR
1230 to assign both the address and the initial value. */
1232 gnu_expr
= gnu_address
;
1235 = build2 (COMPOUND_EXPR
, gnu_type
,
1237 (MODIFY_EXPR
, NULL_TREE
,
1238 build_unary_op (INDIRECT_REF
, NULL_TREE
,
1244 /* If it has an address clause and we are not defining it, mark it
1245 as an indirect object. Likewise for Stdcall objects that are
1247 if ((!definition
&& Present (Address_Clause (gnat_entity
)))
1248 || (Is_Imported (gnat_entity
)
1249 && Has_Stdcall_Convention (gnat_entity
)))
1251 /* Convert the type of the object to a reference type that can
1252 alias everything as per 13.3(19). */
1254 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1255 gnu_size
= NULL_TREE
;
1257 /* No point in taking the address of an initializing expression
1258 that isn't going to be used. */
1259 gnu_expr
= NULL_TREE
;
1261 /* If it has an address clause whose value is known at compile
1262 time, make the object a CONST_DECL. This will avoid a
1263 useless dereference. */
1264 if (Present (Address_Clause (gnat_entity
)))
1266 Node_Id gnat_address
1267 = Expression (Address_Clause (gnat_entity
));
1269 if (compile_time_known_address_p (gnat_address
))
1271 gnu_expr
= gnat_to_gnu (gnat_address
);
1279 /* If we are at top level and this object is of variable size,
1280 make the actual type a hidden pointer to the real type and
1281 make the initializer be a memory allocation and initialization.
1282 Likewise for objects we aren't defining (presumed to be
1283 external references from other packages), but there we do
1284 not set up an initialization.
1286 If the object's size overflows, make an allocator too, so that
1287 Storage_Error gets raised. Note that we will never free
1288 such memory, so we presume it never will get allocated. */
1289 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type
),
1290 global_bindings_p ()
1294 && !allocatable_size_p (convert (sizetype
,
1296 (CEIL_DIV_EXPR
, gnu_size
,
1297 bitsize_unit_node
)),
1298 global_bindings_p ()
1302 gnu_type
= build_reference_type (gnu_type
);
1303 gnu_size
= NULL_TREE
;
1306 /* In case this was a aliased object whose nominal subtype is
1307 unconstrained, the pointer above will be a thin pointer and
1308 build_allocator will automatically make the template.
1310 If we have a template initializer only (that we made above),
1311 pretend there is none and rely on what build_allocator creates
1312 again anyway. Otherwise (if we have a full initializer), get
1313 the data part and feed that to build_allocator.
1315 If we are elaborating a mutable object, tell build_allocator to
1316 ignore a possibly simpler size from the initializer, if any, as
1317 we must allocate the maximum possible size in this case. */
1318 if (definition
&& !imported_p
)
1320 tree gnu_alloc_type
= TREE_TYPE (gnu_type
);
1322 if (TREE_CODE (gnu_alloc_type
) == RECORD_TYPE
1323 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type
))
1326 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type
)));
1328 if (TREE_CODE (gnu_expr
) == CONSTRUCTOR
1329 && 1 == vec_safe_length (CONSTRUCTOR_ELTS (gnu_expr
)))
1333 = build_component_ref
1334 (gnu_expr
, NULL_TREE
,
1335 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr
))),
1339 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type
)) == INTEGER_CST
1340 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type
)))
1341 post_error ("?`Storage_Error` will be raised at run time!",
1345 = build_allocator (gnu_alloc_type
, gnu_expr
, gnu_type
,
1346 Empty
, Empty
, gnat_entity
, mutable_p
);
1351 gnu_expr
= NULL_TREE
;
1356 /* If this object would go into the stack and has an alignment larger
1357 than the largest stack alignment the back-end can honor, resort to
1358 a variable of "aligning type". */
1359 if (!global_bindings_p () && !static_p
&& definition
1360 && !imported_p
&& TYPE_ALIGN (gnu_type
) > BIGGEST_ALIGNMENT
)
1362 /* Create the new variable. No need for extra room before the
1363 aligned field as this is in automatic storage. */
1365 = make_aligning_type (gnu_type
, TYPE_ALIGN (gnu_type
),
1366 TYPE_SIZE_UNIT (gnu_type
),
1367 BIGGEST_ALIGNMENT
, 0);
1369 = create_var_decl (create_concat_name (gnat_entity
, "ALIGN"),
1370 NULL_TREE
, gnu_new_type
, NULL_TREE
, false,
1371 false, false, false, NULL
, gnat_entity
);
1373 /* Initialize the aligned field if we have an initializer. */
1376 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
1378 (gnu_new_var
, NULL_TREE
,
1379 TYPE_FIELDS (gnu_new_type
), false),
1383 /* And setup this entity as a reference to the aligned field. */
1384 gnu_type
= build_reference_type (gnu_type
);
1387 (ADDR_EXPR
, gnu_type
,
1388 build_component_ref (gnu_new_var
, NULL_TREE
,
1389 TYPE_FIELDS (gnu_new_type
), false));
1391 gnu_size
= NULL_TREE
;
1396 /* If this is an aliased object with an unconstrained nominal subtype,
1397 we make its type a thin reference, i.e. the reference counterpart
1398 of a thin pointer, so that it points to the array part. This is
1399 aimed at making it easier for the debugger to decode the object.
1400 Note that we have to do that this late because of the couple of
1401 allocation adjustments that might be made just above. */
1402 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
1403 && Is_Array_Type (Etype (gnat_entity
))
1404 && !type_annotate_only
)
1407 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity
)));
1409 /* In case the object with the template has already been allocated
1410 just above, we have nothing to do here. */
1411 if (!TYPE_IS_THIN_POINTER_P (gnu_type
))
1413 gnu_size
= NULL_TREE
;
1416 if (definition
&& !imported_p
)
1419 = create_var_decl (concat_name (gnu_entity_name
, "UNC"),
1420 NULL_TREE
, gnu_type
, gnu_expr
,
1421 const_flag
, Is_Public (gnat_entity
),
1422 false, static_p
, NULL
, gnat_entity
);
1424 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_unc_var
);
1425 TREE_CONSTANT (gnu_expr
) = 1;
1430 gnu_expr
= NULL_TREE
;
1436 = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array
));
1440 gnu_type
= build_qualified_type (gnu_type
, (TYPE_QUALS (gnu_type
)
1441 | TYPE_QUAL_CONST
));
1443 /* Convert the expression to the type of the object except in the
1444 case where the object's type is unconstrained or the object's type
1445 is a padded record whose field is of self-referential size. In
1446 the former case, converting will generate unnecessary evaluations
1447 of the CONSTRUCTOR to compute the size and in the latter case, we
1448 want to only copy the actual data. Also don't convert to a record
1449 type with a variant part from a record type without one, to keep
1450 the object simpler. */
1452 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1453 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1454 && !(TYPE_IS_PADDING_P (gnu_type
)
1455 && CONTAINS_PLACEHOLDER_P
1456 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))
1457 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1458 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
1459 && get_variant_part (gnu_type
) != NULL_TREE
1460 && get_variant_part (TREE_TYPE (gnu_expr
)) == NULL_TREE
))
1461 gnu_expr
= convert (gnu_type
, gnu_expr
);
1463 /* If this name is external or there was a name specified, use it,
1464 unless this is a VMS exception object since this would conflict
1465 with the symbol we need to export in addition. Don't use the
1466 Interface_Name if there is an address clause (see CD30005). */
1467 if (!Is_VMS_Exception (gnat_entity
)
1468 && ((Present (Interface_Name (gnat_entity
))
1469 && No (Address_Clause (gnat_entity
)))
1470 || (Is_Public (gnat_entity
)
1471 && (!Is_Imported (gnat_entity
)
1472 || Is_Exported (gnat_entity
)))))
1473 gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
1475 /* If this is an aggregate constant initialized to a constant, force it
1476 to be statically allocated. This saves an initialization copy. */
1479 && gnu_expr
&& TREE_CONSTANT (gnu_expr
)
1480 && AGGREGATE_TYPE_P (gnu_type
)
1481 && host_integerp (TYPE_SIZE_UNIT (gnu_type
), 1)
1482 && !(TYPE_IS_PADDING_P (gnu_type
)
1483 && !host_integerp (TYPE_SIZE_UNIT
1484 (TREE_TYPE (TYPE_FIELDS (gnu_type
))), 1)))
1487 /* Now create the variable or the constant and set various flags. */
1489 = create_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
1490 gnu_expr
, const_flag
, Is_Public (gnat_entity
),
1491 imported_p
|| !definition
, static_p
, attr_list
,
1493 DECL_BY_REF_P (gnu_decl
) = used_by_ref
;
1494 DECL_POINTS_TO_READONLY_P (gnu_decl
) = used_by_ref
&& inner_const_flag
;
1495 DECL_CAN_NEVER_BE_NULL_P (gnu_decl
) = Can_Never_Be_Null (gnat_entity
);
1497 /* If we are defining an Out parameter and optimization isn't enabled,
1498 create a fake PARM_DECL for debugging purposes and make it point to
1499 the VAR_DECL. Suppress debug info for the latter but make sure it
1500 will live on the stack so that it can be accessed from within the
1501 debugger through the PARM_DECL. */
1502 if (kind
== E_Out_Parameter
1506 && !flag_generate_lto
)
1508 tree param
= create_param_decl (gnu_entity_name
, gnu_type
, false);
1509 gnat_pushdecl (param
, gnat_entity
);
1510 SET_DECL_VALUE_EXPR (param
, gnu_decl
);
1511 DECL_HAS_VALUE_EXPR_P (param
) = 1;
1512 DECL_IGNORED_P (gnu_decl
) = 1;
1513 TREE_ADDRESSABLE (gnu_decl
) = 1;
1516 /* If this is a loop parameter, set the corresponding flag. */
1517 else if (kind
== E_Loop_Parameter
)
1518 DECL_LOOP_PARM_P (gnu_decl
) = 1;
1520 /* If this is a renaming pointer, attach the renamed object to it and
1521 register it if we are at the global level. Note that an external
1522 constant is at the global level. */
1523 else if (TREE_CODE (gnu_decl
) == VAR_DECL
&& renamed_obj
)
1525 SET_DECL_RENAMED_OBJECT (gnu_decl
, renamed_obj
);
1526 if ((!definition
&& kind
== E_Constant
) || global_bindings_p ())
1528 DECL_RENAMING_GLOBAL_P (gnu_decl
) = 1;
1529 record_global_renaming_pointer (gnu_decl
);
1533 /* If this is a constant and we are defining it or it generates a real
1534 symbol at the object level and we are referencing it, we may want
1535 or need to have a true variable to represent it:
1536 - if optimization isn't enabled, for debugging purposes,
1537 - if the constant is public and not overlaid on something else,
1538 - if its address is taken,
1539 - if either itself or its type is aliased. */
1540 if (TREE_CODE (gnu_decl
) == CONST_DECL
1541 && (definition
|| Sloc (gnat_entity
) > Standard_Location
)
1542 && ((!optimize
&& debug_info_p
)
1543 || (Is_Public (gnat_entity
)
1544 && No (Address_Clause (gnat_entity
)))
1545 || Address_Taken (gnat_entity
)
1546 || Is_Aliased (gnat_entity
)
1547 || Is_Aliased (Etype (gnat_entity
))))
1550 = create_true_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
1551 gnu_expr
, true, Is_Public (gnat_entity
),
1552 !definition
, static_p
, attr_list
,
1555 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl
, gnu_corr_var
);
1557 /* As debugging information will be generated for the variable,
1558 do not generate debugging information for the constant. */
1560 DECL_IGNORED_P (gnu_decl
) = 1;
1562 DECL_IGNORED_P (gnu_corr_var
) = 1;
1565 /* If this is a constant, even if we don't need a true variable, we
1566 may need to avoid returning the initializer in every case. That
1567 can happen for the address of a (constant) constructor because,
1568 upon dereferencing it, the constructor will be reinjected in the
1569 tree, which may not be valid in every case; see lvalue_required_p
1570 for more details. */
1571 if (TREE_CODE (gnu_decl
) == CONST_DECL
)
1572 DECL_CONST_ADDRESS_P (gnu_decl
) = constructor_address_p (gnu_expr
);
1574 /* If this object is declared in a block that contains a block with an
1575 exception handler, and we aren't using the GCC exception mechanism,
1576 we must force this variable in memory in order to avoid an invalid
1578 if (Exception_Mechanism
!= Back_End_Exceptions
1579 && Has_Nested_Block_With_Handler (Scope (gnat_entity
)))
1580 TREE_ADDRESSABLE (gnu_decl
) = 1;
1582 /* If we are defining an object with variable size or an object with
1583 fixed size that will be dynamically allocated, and we are using the
1584 setjmp/longjmp exception mechanism, update the setjmp buffer. */
1586 && Exception_Mechanism
== Setjmp_Longjmp
1587 && get_block_jmpbuf_decl ()
1588 && DECL_SIZE_UNIT (gnu_decl
)
1589 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl
)) != INTEGER_CST
1590 || (flag_stack_check
== GENERIC_STACK_CHECK
1591 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl
),
1592 STACK_CHECK_MAX_VAR_SIZE
) > 0)))
1593 add_stmt_with_node (build_call_n_expr
1594 (update_setjmp_buf_decl
, 1,
1595 build_unary_op (ADDR_EXPR
, NULL_TREE
,
1596 get_block_jmpbuf_decl ())),
1599 /* Back-annotate Esize and Alignment of the object if not already
1600 known. Note that we pick the values of the type, not those of
1601 the object, to shield ourselves from low-level platform-dependent
1602 adjustments like alignment promotion. This is both consistent with
1603 all the treatment above, where alignment and size are set on the
1604 type of the object and not on the object directly, and makes it
1605 possible to support all confirming representation clauses. */
1606 annotate_object (gnat_entity
, TREE_TYPE (gnu_decl
), gnu_object_size
,
1607 used_by_ref
, false);
1612 /* Return a TYPE_DECL for "void" that we previously made. */
1613 gnu_decl
= TYPE_NAME (void_type_node
);
1616 case E_Enumeration_Type
:
1617 /* A special case: for the types Character and Wide_Character in
1618 Standard, we do not list all the literals. So if the literals
1619 are not specified, make this an unsigned type. */
1620 if (No (First_Literal (gnat_entity
)))
1622 gnu_type
= make_unsigned_type (esize
);
1623 TYPE_NAME (gnu_type
) = gnu_entity_name
;
1625 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1626 This is needed by the DWARF-2 back-end to distinguish between
1627 unsigned integer types and character types. */
1628 TYPE_STRING_FLAG (gnu_type
) = 1;
1633 /* We have a list of enumeral constants in First_Literal. We make a
1634 CONST_DECL for each one and build into GNU_LITERAL_LIST the list to
1635 be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST
1636 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1637 value of the literal. But when we have a regular boolean type, we
1638 simplify this a little by using a BOOLEAN_TYPE. */
1639 bool is_boolean
= Is_Boolean_Type (gnat_entity
)
1640 && !Has_Non_Standard_Rep (gnat_entity
);
1641 tree gnu_literal_list
= NULL_TREE
;
1642 Entity_Id gnat_literal
;
1644 if (Is_Unsigned_Type (gnat_entity
))
1645 gnu_type
= make_unsigned_type (esize
);
1647 gnu_type
= make_signed_type (esize
);
1649 TREE_SET_CODE (gnu_type
, is_boolean
? BOOLEAN_TYPE
: ENUMERAL_TYPE
);
1651 for (gnat_literal
= First_Literal (gnat_entity
);
1652 Present (gnat_literal
);
1653 gnat_literal
= Next_Literal (gnat_literal
))
1656 = UI_To_gnu (Enumeration_Rep (gnat_literal
), gnu_type
);
1658 = create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
1659 gnu_type
, gnu_value
, true, false, false,
1660 false, NULL
, gnat_literal
);
1661 /* Do not generate debug info for individual enumerators. */
1662 DECL_IGNORED_P (gnu_literal
) = 1;
1663 save_gnu_tree (gnat_literal
, gnu_literal
, false);
1664 gnu_literal_list
= tree_cons (DECL_NAME (gnu_literal
),
1665 gnu_value
, gnu_literal_list
);
1669 TYPE_VALUES (gnu_type
) = nreverse (gnu_literal_list
);
1671 /* Note that the bounds are updated at the end of this function
1672 to avoid an infinite recursion since they refer to the type. */
1676 case E_Signed_Integer_Type
:
1677 case E_Ordinary_Fixed_Point_Type
:
1678 case E_Decimal_Fixed_Point_Type
:
1679 /* For integer types, just make a signed type the appropriate number
1681 gnu_type
= make_signed_type (esize
);
1684 case E_Modular_Integer_Type
:
1686 /* For modular types, make the unsigned type of the proper number
1687 of bits and then set up the modulus, if required. */
1688 tree gnu_modulus
, gnu_high
= NULL_TREE
;
1690 /* Packed array types are supposed to be subtypes only. */
1691 gcc_assert (!Is_Packed_Array_Type (gnat_entity
));
1693 gnu_type
= make_unsigned_type (esize
);
1695 /* Get the modulus in this type. If it overflows, assume it is because
1696 it is equal to 2**Esize. Note that there is no overflow checking
1697 done on unsigned type, so we detect the overflow by looking for
1698 a modulus of zero, which is otherwise invalid. */
1699 gnu_modulus
= UI_To_gnu (Modulus (gnat_entity
), gnu_type
);
1701 if (!integer_zerop (gnu_modulus
))
1703 TYPE_MODULAR_P (gnu_type
) = 1;
1704 SET_TYPE_MODULUS (gnu_type
, gnu_modulus
);
1705 gnu_high
= fold_build2 (MINUS_EXPR
, gnu_type
, gnu_modulus
,
1706 convert (gnu_type
, integer_one_node
));
1709 /* If the upper bound is not maximal, make an extra subtype. */
1711 && !tree_int_cst_equal (gnu_high
, TYPE_MAX_VALUE (gnu_type
)))
1713 tree gnu_subtype
= make_unsigned_type (esize
);
1714 SET_TYPE_RM_MAX_VALUE (gnu_subtype
, gnu_high
);
1715 TREE_TYPE (gnu_subtype
) = gnu_type
;
1716 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
1717 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "UMT");
1718 gnu_type
= gnu_subtype
;
1723 case E_Signed_Integer_Subtype
:
1724 case E_Enumeration_Subtype
:
1725 case E_Modular_Integer_Subtype
:
1726 case E_Ordinary_Fixed_Point_Subtype
:
1727 case E_Decimal_Fixed_Point_Subtype
:
1729 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1730 not want to call create_range_type since we would like each subtype
1731 node to be distinct. ??? Historically this was in preparation for
1732 when memory aliasing is implemented, but that's obsolete now given
1733 the call to relate_alias_sets below.
1735 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1736 this fact is used by the arithmetic conversion functions.
1738 We elaborate the Ancestor_Subtype if it is not in the current unit
1739 and one of our bounds is non-static. We do this to ensure consistent
1740 naming in the case where several subtypes share the same bounds, by
1741 elaborating the first such subtype first, thus using its name. */
1744 && Present (Ancestor_Subtype (gnat_entity
))
1745 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1746 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1747 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1748 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
), gnu_expr
, 0);
1750 /* Set the precision to the Esize except for bit-packed arrays. */
1751 if (Is_Packed_Array_Type (gnat_entity
)
1752 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1753 esize
= UI_To_Int (RM_Size (gnat_entity
));
1755 /* This should be an unsigned type if the base type is unsigned or
1756 if the lower bound is constant and non-negative or if the type
1758 if (Is_Unsigned_Type (Etype (gnat_entity
))
1759 || Is_Unsigned_Type (gnat_entity
)
1760 || Has_Biased_Representation (gnat_entity
))
1761 gnu_type
= make_unsigned_type (esize
);
1763 gnu_type
= make_signed_type (esize
);
1764 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1766 SET_TYPE_RM_MIN_VALUE
1768 convert (TREE_TYPE (gnu_type
),
1769 elaborate_expression (Type_Low_Bound (gnat_entity
),
1770 gnat_entity
, get_identifier ("L"),
1772 Needs_Debug_Info (gnat_entity
))));
1774 SET_TYPE_RM_MAX_VALUE
1776 convert (TREE_TYPE (gnu_type
),
1777 elaborate_expression (Type_High_Bound (gnat_entity
),
1778 gnat_entity
, get_identifier ("U"),
1780 Needs_Debug_Info (gnat_entity
))));
1782 /* One of the above calls might have caused us to be elaborated,
1783 so don't blow up if so. */
1784 if (present_gnu_tree (gnat_entity
))
1786 maybe_present
= true;
1790 TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1791 = Has_Biased_Representation (gnat_entity
);
1793 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1794 TYPE_STUB_DECL (gnu_type
)
1795 = create_type_stub_decl (gnu_entity_name
, gnu_type
);
1797 /* Inherit our alias set from what we're a subtype of. Subtypes
1798 are not different types and a pointer can designate any instance
1799 within a subtype hierarchy. */
1800 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
1802 /* For a packed array, make the original array type a parallel type. */
1804 && Is_Packed_Array_Type (gnat_entity
)
1805 && present_gnu_tree (Original_Array_Type (gnat_entity
)))
1806 add_parallel_type (gnu_type
,
1808 (Original_Array_Type (gnat_entity
)));
1812 /* We have to handle clauses that under-align the type specially. */
1813 if ((Present (Alignment_Clause (gnat_entity
))
1814 || (Is_Packed_Array_Type (gnat_entity
)
1816 (Alignment_Clause (Original_Array_Type (gnat_entity
)))))
1817 && UI_Is_In_Int_Range (Alignment (gnat_entity
)))
1819 align
= UI_To_Int (Alignment (gnat_entity
)) * BITS_PER_UNIT
;
1820 if (align
>= TYPE_ALIGN (gnu_type
))
1824 /* If the type we are dealing with represents a bit-packed array,
1825 we need to have the bits left justified on big-endian targets
1826 and right justified on little-endian targets. We also need to
1827 ensure that when the value is read (e.g. for comparison of two
1828 such values), we only get the good bits, since the unused bits
1829 are uninitialized. Both goals are accomplished by wrapping up
1830 the modular type in an enclosing record type. */
1831 if (Is_Packed_Array_Type (gnat_entity
)
1832 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1834 tree gnu_field_type
, gnu_field
;
1836 /* Set the RM size before wrapping up the original type. */
1837 SET_TYPE_RM_SIZE (gnu_type
,
1838 UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
));
1839 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
) = 1;
1841 /* Create a stripped-down declaration, mainly for debugging. */
1842 create_type_decl (gnu_entity_name
, gnu_type
, NULL
, true,
1843 debug_info_p
, gnat_entity
);
1845 /* Now save it and build the enclosing record type. */
1846 gnu_field_type
= gnu_type
;
1848 gnu_type
= make_node (RECORD_TYPE
);
1849 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "JM");
1850 TYPE_PACKED (gnu_type
) = 1;
1851 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_field_type
);
1852 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_field_type
);
1853 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_RM_SIZE (gnu_field_type
));
1855 /* Propagate the alignment of the modular type to the record type,
1856 unless there is an alignment clause that under-aligns the type.
1857 This means that bit-packed arrays are given "ceil" alignment for
1858 their size by default, which may seem counter-intuitive but makes
1859 it possible to overlay them on modular types easily. */
1860 TYPE_ALIGN (gnu_type
)
1861 = align
> 0 ? align
: TYPE_ALIGN (gnu_field_type
);
1863 relate_alias_sets (gnu_type
, gnu_field_type
, ALIAS_SET_COPY
);
1865 /* Don't declare the field as addressable since we won't be taking
1866 its address and this would prevent create_field_decl from making
1869 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type
,
1870 gnu_type
, NULL_TREE
, bitsize_zero_node
, 1, 0);
1872 /* Do not emit debug info until after the parallel type is added. */
1873 finish_record_type (gnu_type
, gnu_field
, 2, false);
1874 compute_record_mode (gnu_type
);
1875 TYPE_JUSTIFIED_MODULAR_P (gnu_type
) = 1;
1879 /* Make the original array type a parallel type. */
1880 if (present_gnu_tree (Original_Array_Type (gnat_entity
)))
1881 add_parallel_type (gnu_type
,
1883 (Original_Array_Type (gnat_entity
)));
1885 rest_of_record_type_compilation (gnu_type
);
1889 /* If the type we are dealing with has got a smaller alignment than the
1890 natural one, we need to wrap it up in a record type and under-align
1891 the latter. We reuse the padding machinery for this purpose. */
1894 tree gnu_field_type
, gnu_field
;
1896 /* Set the RM size before wrapping up the type. */
1897 SET_TYPE_RM_SIZE (gnu_type
,
1898 UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
));
1900 /* Create a stripped-down declaration, mainly for debugging. */
1901 create_type_decl (gnu_entity_name
, gnu_type
, NULL
, true,
1902 debug_info_p
, gnat_entity
);
1904 /* Now save it and build the enclosing record type. */
1905 gnu_field_type
= gnu_type
;
1907 gnu_type
= make_node (RECORD_TYPE
);
1908 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "PAD");
1909 TYPE_PACKED (gnu_type
) = 1;
1910 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_field_type
);
1911 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_field_type
);
1912 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_RM_SIZE (gnu_field_type
));
1913 TYPE_ALIGN (gnu_type
) = align
;
1914 relate_alias_sets (gnu_type
, gnu_field_type
, ALIAS_SET_COPY
);
1916 /* Don't declare the field as addressable since we won't be taking
1917 its address and this would prevent create_field_decl from making
1920 = create_field_decl (get_identifier ("F"), gnu_field_type
,
1921 gnu_type
, NULL_TREE
, bitsize_zero_node
, 1, 0);
1923 finish_record_type (gnu_type
, gnu_field
, 2, debug_info_p
);
1924 compute_record_mode (gnu_type
);
1925 TYPE_PADDING_P (gnu_type
) = 1;
1930 case E_Floating_Point_Type
:
1931 /* If this is a VAX floating-point type, use an integer of the proper
1932 size. All the operations will be handled with ASM statements. */
1933 if (Vax_Float (gnat_entity
))
1935 gnu_type
= make_signed_type (esize
);
1936 TYPE_VAX_FLOATING_POINT_P (gnu_type
) = 1;
1937 SET_TYPE_DIGITS_VALUE (gnu_type
,
1938 UI_To_gnu (Digits_Value (gnat_entity
),
1943 /* The type of the Low and High bounds can be our type if this is
1944 a type from Standard, so set them at the end of the function. */
1945 gnu_type
= make_node (REAL_TYPE
);
1946 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1947 layout_type (gnu_type
);
1950 case E_Floating_Point_Subtype
:
1951 if (Vax_Float (gnat_entity
))
1953 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1959 && Present (Ancestor_Subtype (gnat_entity
))
1960 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1961 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1962 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1963 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1966 gnu_type
= make_node (REAL_TYPE
);
1967 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1968 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1969 TYPE_GCC_MIN_VALUE (gnu_type
)
1970 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type
));
1971 TYPE_GCC_MAX_VALUE (gnu_type
)
1972 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type
));
1973 layout_type (gnu_type
);
1975 SET_TYPE_RM_MIN_VALUE
1977 convert (TREE_TYPE (gnu_type
),
1978 elaborate_expression (Type_Low_Bound (gnat_entity
),
1979 gnat_entity
, get_identifier ("L"),
1981 Needs_Debug_Info (gnat_entity
))));
1983 SET_TYPE_RM_MAX_VALUE
1985 convert (TREE_TYPE (gnu_type
),
1986 elaborate_expression (Type_High_Bound (gnat_entity
),
1987 gnat_entity
, get_identifier ("U"),
1989 Needs_Debug_Info (gnat_entity
))));
1991 /* One of the above calls might have caused us to be elaborated,
1992 so don't blow up if so. */
1993 if (present_gnu_tree (gnat_entity
))
1995 maybe_present
= true;
1999 /* Inherit our alias set from what we're a subtype of, as for
2000 integer subtypes. */
2001 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
2005 /* Array and String Types and Subtypes
2007 Unconstrained array types are represented by E_Array_Type and
2008 constrained array types are represented by E_Array_Subtype. There
2009 are no actual objects of an unconstrained array type; all we have
2010 are pointers to that type.
2012 The following fields are defined on array types and subtypes:
2014 Component_Type Component type of the array.
2015 Number_Dimensions Number of dimensions (an int).
2016 First_Index Type of first index. */
2021 const bool convention_fortran_p
2022 = (Convention (gnat_entity
) == Convention_Fortran
);
2023 const int ndim
= Number_Dimensions (gnat_entity
);
2024 tree gnu_template_type
;
2025 tree gnu_ptr_template
;
2026 tree gnu_template_reference
, gnu_template_fields
, gnu_fat_type
;
2027 tree
*gnu_index_types
= XALLOCAVEC (tree
, ndim
);
2028 tree
*gnu_temp_fields
= XALLOCAVEC (tree
, ndim
);
2029 tree gnu_max_size
= size_one_node
, gnu_max_size_unit
, tem
, t
;
2030 Entity_Id gnat_index
, gnat_name
;
2034 /* Create the type for the component now, as it simplifies breaking
2035 type reference loops. */
2037 = gnat_to_gnu_component_type (gnat_entity
, definition
, debug_info_p
);
2038 if (present_gnu_tree (gnat_entity
))
2040 /* As a side effect, the type may have been translated. */
2041 maybe_present
= true;
2045 /* We complete an existing dummy fat pointer type in place. This both
2046 avoids further complex adjustments in update_pointer_to and yields
2047 better debugging information in DWARF by leveraging the support for
2048 incomplete declarations of "tagged" types in the DWARF back-end. */
2049 gnu_type
= get_dummy_type (gnat_entity
);
2050 if (gnu_type
&& TYPE_POINTER_TO (gnu_type
))
2052 gnu_fat_type
= TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type
));
2053 TYPE_NAME (gnu_fat_type
) = NULL_TREE
;
2054 /* Save the contents of the dummy type for update_pointer_to. */
2055 TYPE_POINTER_TO (gnu_type
) = copy_type (gnu_fat_type
);
2057 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type
)));
2058 gnu_template_type
= TREE_TYPE (gnu_ptr_template
);
2062 gnu_fat_type
= make_node (RECORD_TYPE
);
2063 gnu_template_type
= make_node (RECORD_TYPE
);
2064 gnu_ptr_template
= build_pointer_type (gnu_template_type
);
2067 /* Make a node for the array. If we are not defining the array
2068 suppress expanding incomplete types. */
2069 gnu_type
= make_node (UNCONSTRAINED_ARRAY_TYPE
);
2073 defer_incomplete_level
++;
2074 this_deferred
= true;
2077 /* Build the fat pointer type. Use a "void *" object instead of
2078 a pointer to the array type since we don't have the array type
2079 yet (it will reference the fat pointer via the bounds). */
2081 = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node
,
2082 gnu_fat_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2084 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template
,
2085 gnu_fat_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2087 if (COMPLETE_TYPE_P (gnu_fat_type
))
2089 /* We are going to lay it out again so reset the alias set. */
2090 alias_set_type alias_set
= TYPE_ALIAS_SET (gnu_fat_type
);
2091 TYPE_ALIAS_SET (gnu_fat_type
) = -1;
2092 finish_fat_pointer_type (gnu_fat_type
, tem
);
2093 TYPE_ALIAS_SET (gnu_fat_type
) = alias_set
;
2094 for (t
= gnu_fat_type
; t
; t
= TYPE_NEXT_VARIANT (t
))
2096 TYPE_FIELDS (t
) = tem
;
2097 SET_TYPE_UNCONSTRAINED_ARRAY (t
, gnu_type
);
2102 finish_fat_pointer_type (gnu_fat_type
, tem
);
2103 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type
, gnu_type
);
2106 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2107 is the fat pointer. This will be used to access the individual
2108 fields once we build them. */
2109 tem
= build3 (COMPONENT_REF
, gnu_ptr_template
,
2110 build0 (PLACEHOLDER_EXPR
, gnu_fat_type
),
2111 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type
)), NULL_TREE
);
2112 gnu_template_reference
2113 = build_unary_op (INDIRECT_REF
, gnu_template_type
, tem
);
2114 TREE_READONLY (gnu_template_reference
) = 1;
2115 TREE_THIS_NOTRAP (gnu_template_reference
) = 1;
2117 /* Now create the GCC type for each index and add the fields for that
2118 index to the template. */
2119 for (index
= (convention_fortran_p
? ndim
- 1 : 0),
2120 gnat_index
= First_Index (gnat_entity
);
2121 0 <= index
&& index
< ndim
;
2122 index
+= (convention_fortran_p
? - 1 : 1),
2123 gnat_index
= Next_Index (gnat_index
))
2125 char field_name
[16];
2126 tree gnu_index_base_type
2127 = get_unpadded_type (Base_Type (Etype (gnat_index
)));
2128 tree gnu_lb_field
, gnu_hb_field
, gnu_orig_min
, gnu_orig_max
;
2129 tree gnu_min
, gnu_max
, gnu_high
;
2131 /* Make the FIELD_DECLs for the low and high bounds of this
2132 type and then make extractions of these fields from the
2134 sprintf (field_name
, "LB%d", index
);
2135 gnu_lb_field
= create_field_decl (get_identifier (field_name
),
2136 gnu_index_base_type
,
2137 gnu_template_type
, NULL_TREE
,
2139 Sloc_to_locus (Sloc (gnat_entity
),
2140 &DECL_SOURCE_LOCATION (gnu_lb_field
));
2142 field_name
[0] = 'U';
2143 gnu_hb_field
= create_field_decl (get_identifier (field_name
),
2144 gnu_index_base_type
,
2145 gnu_template_type
, NULL_TREE
,
2147 Sloc_to_locus (Sloc (gnat_entity
),
2148 &DECL_SOURCE_LOCATION (gnu_hb_field
));
2150 gnu_temp_fields
[index
] = chainon (gnu_lb_field
, gnu_hb_field
);
2152 /* We can't use build_component_ref here since the template type
2153 isn't complete yet. */
2154 gnu_orig_min
= build3 (COMPONENT_REF
, gnu_index_base_type
,
2155 gnu_template_reference
, gnu_lb_field
,
2157 gnu_orig_max
= build3 (COMPONENT_REF
, gnu_index_base_type
,
2158 gnu_template_reference
, gnu_hb_field
,
2160 TREE_READONLY (gnu_orig_min
) = TREE_READONLY (gnu_orig_max
) = 1;
2162 gnu_min
= convert (sizetype
, gnu_orig_min
);
2163 gnu_max
= convert (sizetype
, gnu_orig_max
);
2165 /* Compute the size of this dimension. See the E_Array_Subtype
2166 case below for the rationale. */
2168 = build3 (COND_EXPR
, sizetype
,
2169 build2 (GE_EXPR
, boolean_type_node
,
2170 gnu_orig_max
, gnu_orig_min
),
2172 size_binop (MINUS_EXPR
, gnu_min
, size_one_node
));
2174 /* Make a range type with the new range in the Ada base type.
2175 Then make an index type with the size range in sizetype. */
2176 gnu_index_types
[index
]
2177 = create_index_type (gnu_min
, gnu_high
,
2178 create_range_type (gnu_index_base_type
,
2183 /* Update the maximum size of the array in elements. */
2186 tree gnu_index_type
= get_unpadded_type (Etype (gnat_index
));
2188 = convert (sizetype
, TYPE_MIN_VALUE (gnu_index_type
));
2190 = convert (sizetype
, TYPE_MAX_VALUE (gnu_index_type
));
2192 = size_binop (MAX_EXPR
,
2193 size_binop (PLUS_EXPR
, size_one_node
,
2194 size_binop (MINUS_EXPR
,
2198 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2199 && TREE_OVERFLOW (gnu_this_max
))
2200 gnu_max_size
= NULL_TREE
;
2203 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2206 TYPE_NAME (gnu_index_types
[index
])
2207 = create_concat_name (gnat_entity
, field_name
);
2210 /* Install all the fields into the template. */
2211 TYPE_NAME (gnu_template_type
)
2212 = create_concat_name (gnat_entity
, "XUB");
2213 gnu_template_fields
= NULL_TREE
;
2214 for (index
= 0; index
< ndim
; index
++)
2216 = chainon (gnu_template_fields
, gnu_temp_fields
[index
]);
2217 finish_record_type (gnu_template_type
, gnu_template_fields
, 0,
2219 TYPE_READONLY (gnu_template_type
) = 1;
2221 /* If Component_Size is not already specified, annotate it with the
2222 size of the component. */
2223 if (Unknown_Component_Size (gnat_entity
))
2224 Set_Component_Size (gnat_entity
,
2225 annotate_value (TYPE_SIZE (comp_type
)));
2227 /* Compute the maximum size of the array in units and bits. */
2230 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2231 TYPE_SIZE_UNIT (comp_type
));
2232 gnu_max_size
= size_binop (MULT_EXPR
,
2233 convert (bitsizetype
, gnu_max_size
),
2234 TYPE_SIZE (comp_type
));
2237 gnu_max_size_unit
= NULL_TREE
;
2239 /* Now build the array type. */
2241 for (index
= ndim
- 1; index
>= 0; index
--)
2243 tem
= build_nonshared_array_type (tem
, gnu_index_types
[index
]);
2244 TYPE_MULTI_ARRAY_P (tem
) = (index
> 0);
2245 if (array_type_has_nonaliased_component (tem
, gnat_entity
))
2246 TYPE_NONALIASED_COMPONENT (tem
) = 1;
2248 /* If it is passed by reference, force BLKmode to ensure that
2249 objects of this type will always be put in memory. */
2250 if (TYPE_MODE (tem
) != BLKmode
2251 && Is_By_Reference_Type (gnat_entity
))
2252 SET_TYPE_MODE (tem
, BLKmode
);
2255 /* If an alignment is specified, use it if valid. But ignore it
2256 for the original type of packed array types. If the alignment
2257 was requested with an explicit alignment clause, state so. */
2258 if (No (Packed_Array_Type (gnat_entity
))
2259 && Known_Alignment (gnat_entity
))
2262 = validate_alignment (Alignment (gnat_entity
), gnat_entity
,
2264 if (Present (Alignment_Clause (gnat_entity
)))
2265 TYPE_USER_ALIGN (tem
) = 1;
2268 TYPE_CONVENTION_FORTRAN_P (tem
) = convention_fortran_p
;
2270 /* Adjust the type of the pointer-to-array field of the fat pointer
2271 and record the aliasing relationships if necessary. */
2272 TREE_TYPE (TYPE_FIELDS (gnu_fat_type
)) = build_pointer_type (tem
);
2273 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type
))
2274 record_component_aliases (gnu_fat_type
);
2276 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2277 corresponding fat pointer. */
2278 TREE_TYPE (gnu_type
) = gnu_fat_type
;
2279 TYPE_POINTER_TO (gnu_type
) = gnu_fat_type
;
2280 TYPE_REFERENCE_TO (gnu_type
) = gnu_fat_type
;
2281 SET_TYPE_MODE (gnu_type
, BLKmode
);
2282 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (tem
);
2284 /* If the maximum size doesn't overflow, use it. */
2286 && TREE_CODE (gnu_max_size
) == INTEGER_CST
2287 && !TREE_OVERFLOW (gnu_max_size
)
2288 && TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2289 && !TREE_OVERFLOW (gnu_max_size_unit
))
2291 TYPE_SIZE (tem
) = size_binop (MIN_EXPR
, gnu_max_size
,
2293 TYPE_SIZE_UNIT (tem
) = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2294 TYPE_SIZE_UNIT (tem
));
2297 create_type_decl (create_concat_name (gnat_entity
, "XUA"),
2298 tem
, NULL
, !Comes_From_Source (gnat_entity
),
2299 debug_info_p
, gnat_entity
);
2301 /* Give the fat pointer type a name. If this is a packed type, tell
2302 the debugger how to interpret the underlying bits. */
2303 if (Present (Packed_Array_Type (gnat_entity
)))
2304 gnat_name
= Packed_Array_Type (gnat_entity
);
2306 gnat_name
= gnat_entity
;
2307 create_type_decl (create_concat_name (gnat_name
, "XUP"),
2308 gnu_fat_type
, NULL
, !Comes_From_Source (gnat_entity
),
2309 debug_info_p
, gnat_entity
);
2311 /* Create the type to be designated by thin pointers: a record type for
2312 the array and its template. We used to shift the fields to have the
2313 template at a negative offset, but this was somewhat of a kludge; we
2314 now shift thin pointer values explicitly but only those which have a
2315 TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE. */
2316 tem
= build_unc_object_type (gnu_template_type
, tem
,
2317 create_concat_name (gnat_name
, "XUT"),
2320 SET_TYPE_UNCONSTRAINED_ARRAY (tem
, gnu_type
);
2321 TYPE_OBJECT_RECORD_TYPE (gnu_type
) = tem
;
2325 case E_String_Subtype
:
2326 case E_Array_Subtype
:
2328 /* This is the actual data type for array variables. Multidimensional
2329 arrays are implemented as arrays of arrays. Note that arrays which
2330 have sparse enumeration subtypes as index components create sparse
2331 arrays, which is obviously space inefficient but so much easier to
2334 Also note that the subtype never refers to the unconstrained array
2335 type, which is somewhat at variance with Ada semantics.
2337 First check to see if this is simply a renaming of the array type.
2338 If so, the result is the array type. */
2340 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
2341 if (!Is_Constrained (gnat_entity
))
2345 Entity_Id gnat_index
, gnat_base_index
;
2346 const bool convention_fortran_p
2347 = (Convention (gnat_entity
) == Convention_Fortran
);
2348 const int ndim
= Number_Dimensions (gnat_entity
);
2349 tree gnu_base_type
= gnu_type
;
2350 tree
*gnu_index_types
= XALLOCAVEC (tree
, ndim
);
2351 tree gnu_max_size
= size_one_node
, gnu_max_size_unit
;
2352 bool need_index_type_struct
= false;
2355 /* First create the GCC type for each index and find out whether
2356 special types are needed for debugging information. */
2357 for (index
= (convention_fortran_p
? ndim
- 1 : 0),
2358 gnat_index
= First_Index (gnat_entity
),
2360 = First_Index (Implementation_Base_Type (gnat_entity
));
2361 0 <= index
&& index
< ndim
;
2362 index
+= (convention_fortran_p
? - 1 : 1),
2363 gnat_index
= Next_Index (gnat_index
),
2364 gnat_base_index
= Next_Index (gnat_base_index
))
2366 tree gnu_index_type
= get_unpadded_type (Etype (gnat_index
));
2367 tree gnu_orig_min
= TYPE_MIN_VALUE (gnu_index_type
);
2368 tree gnu_orig_max
= TYPE_MAX_VALUE (gnu_index_type
);
2369 tree gnu_min
= convert (sizetype
, gnu_orig_min
);
2370 tree gnu_max
= convert (sizetype
, gnu_orig_max
);
2371 tree gnu_base_index_type
2372 = get_unpadded_type (Etype (gnat_base_index
));
2373 tree gnu_base_orig_min
= TYPE_MIN_VALUE (gnu_base_index_type
);
2374 tree gnu_base_orig_max
= TYPE_MAX_VALUE (gnu_base_index_type
);
2377 /* See if the base array type is already flat. If it is, we
2378 are probably compiling an ACATS test but it will cause the
2379 code below to malfunction if we don't handle it specially. */
2380 if (TREE_CODE (gnu_base_orig_min
) == INTEGER_CST
2381 && TREE_CODE (gnu_base_orig_max
) == INTEGER_CST
2382 && tree_int_cst_lt (gnu_base_orig_max
, gnu_base_orig_min
))
2384 gnu_min
= size_one_node
;
2385 gnu_max
= size_zero_node
;
2389 /* Similarly, if one of the values overflows in sizetype and the
2390 range is null, use 1..0 for the sizetype bounds. */
2391 else if (TREE_CODE (gnu_min
) == INTEGER_CST
2392 && TREE_CODE (gnu_max
) == INTEGER_CST
2393 && (TREE_OVERFLOW (gnu_min
) || TREE_OVERFLOW (gnu_max
))
2394 && tree_int_cst_lt (gnu_orig_max
, gnu_orig_min
))
2396 gnu_min
= size_one_node
;
2397 gnu_max
= size_zero_node
;
2401 /* If the minimum and maximum values both overflow in sizetype,
2402 but the difference in the original type does not overflow in
2403 sizetype, ignore the overflow indication. */
2404 else if (TREE_CODE (gnu_min
) == INTEGER_CST
2405 && TREE_CODE (gnu_max
) == INTEGER_CST
2406 && TREE_OVERFLOW (gnu_min
) && TREE_OVERFLOW (gnu_max
)
2409 fold_build2 (MINUS_EXPR
, gnu_index_type
,
2413 TREE_OVERFLOW (gnu_min
) = 0;
2414 TREE_OVERFLOW (gnu_max
) = 0;
2418 /* Compute the size of this dimension in the general case. We
2419 need to provide GCC with an upper bound to use but have to
2420 deal with the "superflat" case. There are three ways to do
2421 this. If we can prove that the array can never be superflat,
2422 we can just use the high bound of the index type. */
2423 else if ((Nkind (gnat_index
) == N_Range
2424 && cannot_be_superflat_p (gnat_index
))
2425 /* Packed Array Types are never superflat. */
2426 || Is_Packed_Array_Type (gnat_entity
))
2429 /* Otherwise, if the high bound is constant but the low bound is
2430 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2431 lower bound. Note that the comparison must be done in the
2432 original type to avoid any overflow during the conversion. */
2433 else if (TREE_CODE (gnu_max
) == INTEGER_CST
2434 && TREE_CODE (gnu_min
) != INTEGER_CST
)
2438 = build_cond_expr (sizetype
,
2439 build_binary_op (GE_EXPR
,
2444 size_binop (PLUS_EXPR
, gnu_max
,
2448 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2449 in all the other cases. Note that, here as well as above,
2450 the condition used in the comparison must be equivalent to
2451 the condition (length != 0). This is relied upon in order
2452 to optimize array comparisons in compare_arrays. */
2455 = build_cond_expr (sizetype
,
2456 build_binary_op (GE_EXPR
,
2461 size_binop (MINUS_EXPR
, gnu_min
,
2464 /* Reuse the index type for the range type. Then make an index
2465 type with the size range in sizetype. */
2466 gnu_index_types
[index
]
2467 = create_index_type (gnu_min
, gnu_high
, gnu_index_type
,
2470 /* Update the maximum size of the array in elements. Here we
2471 see if any constraint on the index type of the base type
2472 can be used in the case of self-referential bound on the
2473 index type of the subtype. We look for a non-"infinite"
2474 and non-self-referential bound from any type involved and
2475 handle each bound separately. */
2478 tree gnu_base_min
= convert (sizetype
, gnu_base_orig_min
);
2479 tree gnu_base_max
= convert (sizetype
, gnu_base_orig_max
);
2480 tree gnu_base_index_base_type
2481 = get_base_type (gnu_base_index_type
);
2482 tree gnu_base_base_min
2483 = convert (sizetype
,
2484 TYPE_MIN_VALUE (gnu_base_index_base_type
));
2485 tree gnu_base_base_max
2486 = convert (sizetype
,
2487 TYPE_MAX_VALUE (gnu_base_index_base_type
));
2489 if (!CONTAINS_PLACEHOLDER_P (gnu_min
)
2490 || !(TREE_CODE (gnu_base_min
) == INTEGER_CST
2491 && !TREE_OVERFLOW (gnu_base_min
)))
2492 gnu_base_min
= gnu_min
;
2494 if (!CONTAINS_PLACEHOLDER_P (gnu_max
)
2495 || !(TREE_CODE (gnu_base_max
) == INTEGER_CST
2496 && !TREE_OVERFLOW (gnu_base_max
)))
2497 gnu_base_max
= gnu_max
;
2499 if ((TREE_CODE (gnu_base_min
) == INTEGER_CST
2500 && TREE_OVERFLOW (gnu_base_min
))
2501 || operand_equal_p (gnu_base_min
, gnu_base_base_min
, 0)
2502 || (TREE_CODE (gnu_base_max
) == INTEGER_CST
2503 && TREE_OVERFLOW (gnu_base_max
))
2504 || operand_equal_p (gnu_base_max
, gnu_base_base_max
, 0))
2505 gnu_max_size
= NULL_TREE
;
2509 = size_binop (MAX_EXPR
,
2510 size_binop (PLUS_EXPR
, size_one_node
,
2511 size_binop (MINUS_EXPR
,
2516 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2517 && TREE_OVERFLOW (gnu_this_max
))
2518 gnu_max_size
= NULL_TREE
;
2521 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2525 /* We need special types for debugging information to point to
2526 the index types if they have variable bounds, are not integer
2527 types, are biased or are wider than sizetype. */
2528 if (!integer_onep (gnu_orig_min
)
2529 || TREE_CODE (gnu_orig_max
) != INTEGER_CST
2530 || TREE_CODE (gnu_index_type
) != INTEGER_TYPE
2531 || (TREE_TYPE (gnu_index_type
)
2532 && TREE_CODE (TREE_TYPE (gnu_index_type
))
2534 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type
)
2535 || compare_tree_int (rm_size (gnu_index_type
),
2536 TYPE_PRECISION (sizetype
)) > 0)
2537 need_index_type_struct
= true;
2540 /* Then flatten: create the array of arrays. For an array type
2541 used to implement a packed array, get the component type from
2542 the original array type since the representation clauses that
2543 can affect it are on the latter. */
2544 if (Is_Packed_Array_Type (gnat_entity
)
2545 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
2547 gnu_type
= gnat_to_gnu_type (Original_Array_Type (gnat_entity
));
2548 for (index
= ndim
- 1; index
>= 0; index
--)
2549 gnu_type
= TREE_TYPE (gnu_type
);
2551 /* One of the above calls might have caused us to be elaborated,
2552 so don't blow up if so. */
2553 if (present_gnu_tree (gnat_entity
))
2555 maybe_present
= true;
2561 gnu_type
= gnat_to_gnu_component_type (gnat_entity
, definition
,
2564 /* One of the above calls might have caused us to be elaborated,
2565 so don't blow up if so. */
2566 if (present_gnu_tree (gnat_entity
))
2568 maybe_present
= true;
2573 /* Compute the maximum size of the array in units and bits. */
2576 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2577 TYPE_SIZE_UNIT (gnu_type
));
2578 gnu_max_size
= size_binop (MULT_EXPR
,
2579 convert (bitsizetype
, gnu_max_size
),
2580 TYPE_SIZE (gnu_type
));
2583 gnu_max_size_unit
= NULL_TREE
;
2585 /* Now build the array type. */
2586 for (index
= ndim
- 1; index
>= 0; index
--)
2588 gnu_type
= build_nonshared_array_type (gnu_type
,
2589 gnu_index_types
[index
]);
2590 TYPE_MULTI_ARRAY_P (gnu_type
) = (index
> 0);
2591 if (array_type_has_nonaliased_component (gnu_type
, gnat_entity
))
2592 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2594 /* See the E_Array_Type case for the rationale. */
2595 if (TYPE_MODE (gnu_type
) != BLKmode
2596 && Is_By_Reference_Type (gnat_entity
))
2597 SET_TYPE_MODE (gnu_type
, BLKmode
);
2600 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2601 TYPE_STUB_DECL (gnu_type
)
2602 = create_type_stub_decl (gnu_entity_name
, gnu_type
);
2604 /* If we are at file level and this is a multi-dimensional array,
2605 we need to make a variable corresponding to the stride of the
2606 inner dimensions. */
2607 if (global_bindings_p () && ndim
> 1)
2609 tree gnu_st_name
= get_identifier ("ST");
2612 for (gnu_arr_type
= TREE_TYPE (gnu_type
);
2613 TREE_CODE (gnu_arr_type
) == ARRAY_TYPE
;
2614 gnu_arr_type
= TREE_TYPE (gnu_arr_type
),
2615 gnu_st_name
= concat_name (gnu_st_name
, "ST"))
2617 tree eltype
= TREE_TYPE (gnu_arr_type
);
2619 TYPE_SIZE (gnu_arr_type
)
2620 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type
),
2621 gnat_entity
, gnu_st_name
,
2624 /* ??? For now, store the size as a multiple of the
2625 alignment of the element type in bytes so that we
2626 can see the alignment from the tree. */
2627 TYPE_SIZE_UNIT (gnu_arr_type
)
2628 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type
),
2630 concat_name (gnu_st_name
, "A_U"),
2632 TYPE_ALIGN (eltype
));
2634 /* ??? create_type_decl is not invoked on the inner types so
2635 the MULT_EXPR node built above will never be marked. */
2636 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type
));
2640 /* If we need to write out a record type giving the names of the
2641 bounds for debugging purposes, do it now and make the record
2642 type a parallel type. This is not needed for a packed array
2643 since the bounds are conveyed by the original array type. */
2644 if (need_index_type_struct
2646 && !Is_Packed_Array_Type (gnat_entity
))
2648 tree gnu_bound_rec
= make_node (RECORD_TYPE
);
2649 tree gnu_field_list
= NULL_TREE
;
2652 TYPE_NAME (gnu_bound_rec
)
2653 = create_concat_name (gnat_entity
, "XA");
2655 for (index
= ndim
- 1; index
>= 0; index
--)
2657 tree gnu_index
= TYPE_INDEX_TYPE (gnu_index_types
[index
]);
2658 tree gnu_index_name
= TYPE_NAME (gnu_index
);
2660 if (TREE_CODE (gnu_index_name
) == TYPE_DECL
)
2661 gnu_index_name
= DECL_NAME (gnu_index_name
);
2663 /* Make sure to reference the types themselves, and not just
2664 their names, as the debugger may fall back on them. */
2665 gnu_field
= create_field_decl (gnu_index_name
, gnu_index
,
2666 gnu_bound_rec
, NULL_TREE
,
2668 DECL_CHAIN (gnu_field
) = gnu_field_list
;
2669 gnu_field_list
= gnu_field
;
2672 finish_record_type (gnu_bound_rec
, gnu_field_list
, 0, true);
2673 add_parallel_type (gnu_type
, gnu_bound_rec
);
2676 /* If this is a packed array type, make the original array type a
2677 parallel type. Otherwise, do it for the base array type if it
2678 isn't artificial to make sure it is kept in the debug info. */
2681 if (Is_Packed_Array_Type (gnat_entity
)
2682 && present_gnu_tree (Original_Array_Type (gnat_entity
)))
2683 add_parallel_type (gnu_type
,
2685 (Original_Array_Type (gnat_entity
)));
2689 = gnat_to_gnu_entity (Etype (gnat_entity
), NULL_TREE
, 0);
2690 if (!DECL_ARTIFICIAL (gnu_base_decl
))
2691 add_parallel_type (gnu_type
,
2692 TREE_TYPE (TREE_TYPE (gnu_base_decl
)));
2696 TYPE_CONVENTION_FORTRAN_P (gnu_type
) = convention_fortran_p
;
2697 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
2698 = (Is_Packed_Array_Type (gnat_entity
)
2699 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
2701 /* If the size is self-referential and the maximum size doesn't
2702 overflow, use it. */
2703 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
2705 && !(TREE_CODE (gnu_max_size
) == INTEGER_CST
2706 && TREE_OVERFLOW (gnu_max_size
))
2707 && !(TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2708 && TREE_OVERFLOW (gnu_max_size_unit
)))
2710 TYPE_SIZE (gnu_type
) = size_binop (MIN_EXPR
, gnu_max_size
,
2711 TYPE_SIZE (gnu_type
));
2712 TYPE_SIZE_UNIT (gnu_type
)
2713 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2714 TYPE_SIZE_UNIT (gnu_type
));
2717 /* Set our alias set to that of our base type. This gives all
2718 array subtypes the same alias set. */
2719 relate_alias_sets (gnu_type
, gnu_base_type
, ALIAS_SET_COPY
);
2721 /* If this is a packed type, make this type the same as the packed
2722 array type, but do some adjusting in the type first. */
2723 if (Present (Packed_Array_Type (gnat_entity
)))
2725 Entity_Id gnat_index
;
2728 /* First finish the type we had been making so that we output
2729 debugging information for it. */
2730 if (Treat_As_Volatile (gnat_entity
))
2732 = build_qualified_type (gnu_type
,
2733 TYPE_QUALS (gnu_type
)
2734 | TYPE_QUAL_VOLATILE
);
2736 /* Make it artificial only if the base type was artificial too.
2737 That's sort of "morally" true and will make it possible for
2738 the debugger to look it up by name in DWARF, which is needed
2739 in order to decode the packed array type. */
2741 = create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
2742 !Comes_From_Source (Etype (gnat_entity
))
2743 && !Comes_From_Source (gnat_entity
),
2744 debug_info_p
, gnat_entity
);
2746 /* Save it as our equivalent in case the call below elaborates
2748 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2750 gnu_decl
= gnat_to_gnu_entity (Packed_Array_Type (gnat_entity
),
2752 this_made_decl
= true;
2753 gnu_type
= TREE_TYPE (gnu_decl
);
2754 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
2756 gnu_inner
= gnu_type
;
2757 while (TREE_CODE (gnu_inner
) == RECORD_TYPE
2758 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner
)
2759 || TYPE_PADDING_P (gnu_inner
)))
2760 gnu_inner
= TREE_TYPE (TYPE_FIELDS (gnu_inner
));
2762 /* We need to attach the index type to the type we just made so
2763 that the actual bounds can later be put into a template. */
2764 if ((TREE_CODE (gnu_inner
) == ARRAY_TYPE
2765 && !TYPE_ACTUAL_BOUNDS (gnu_inner
))
2766 || (TREE_CODE (gnu_inner
) == INTEGER_TYPE
2767 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner
)))
2769 if (TREE_CODE (gnu_inner
) == INTEGER_TYPE
)
2771 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2772 TYPE_MODULUS for modular types so we make an extra
2773 subtype if necessary. */
2774 if (TYPE_MODULAR_P (gnu_inner
))
2777 = make_unsigned_type (TYPE_PRECISION (gnu_inner
));
2778 TREE_TYPE (gnu_subtype
) = gnu_inner
;
2779 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
2780 SET_TYPE_RM_MIN_VALUE (gnu_subtype
,
2781 TYPE_MIN_VALUE (gnu_inner
));
2782 SET_TYPE_RM_MAX_VALUE (gnu_subtype
,
2783 TYPE_MAX_VALUE (gnu_inner
));
2784 gnu_inner
= gnu_subtype
;
2787 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner
) = 1;
2789 #ifdef ENABLE_CHECKING
2790 /* Check for other cases of overloading. */
2791 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner
));
2795 for (gnat_index
= First_Index (gnat_entity
);
2796 Present (gnat_index
);
2797 gnat_index
= Next_Index (gnat_index
))
2798 SET_TYPE_ACTUAL_BOUNDS
2800 tree_cons (NULL_TREE
,
2801 get_unpadded_type (Etype (gnat_index
)),
2802 TYPE_ACTUAL_BOUNDS (gnu_inner
)));
2804 if (Convention (gnat_entity
) != Convention_Fortran
)
2805 SET_TYPE_ACTUAL_BOUNDS
2806 (gnu_inner
, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner
)));
2808 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2809 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
2810 TREE_TYPE (TYPE_FIELDS (gnu_type
)) = gnu_inner
;
2815 /* Abort if packed array with no Packed_Array_Type field set. */
2816 gcc_assert (!Is_Packed (gnat_entity
));
2820 case E_String_Literal_Subtype
:
2821 /* Create the type for a string literal. */
2823 Entity_Id gnat_full_type
2824 = (IN (Ekind (Etype (gnat_entity
)), Private_Kind
)
2825 && Present (Full_View (Etype (gnat_entity
)))
2826 ? Full_View (Etype (gnat_entity
)) : Etype (gnat_entity
));
2827 tree gnu_string_type
= get_unpadded_type (gnat_full_type
);
2828 tree gnu_string_array_type
2829 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type
))));
2830 tree gnu_string_index_type
2831 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2832 (TYPE_DOMAIN (gnu_string_array_type
))));
2833 tree gnu_lower_bound
2834 = convert (gnu_string_index_type
,
2835 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity
)));
2837 = UI_To_gnu (String_Literal_Length (gnat_entity
),
2838 gnu_string_index_type
);
2839 tree gnu_upper_bound
2840 = build_binary_op (PLUS_EXPR
, gnu_string_index_type
,
2842 int_const_binop (MINUS_EXPR
, gnu_length
,
2845 = create_index_type (convert (sizetype
, gnu_lower_bound
),
2846 convert (sizetype
, gnu_upper_bound
),
2847 create_range_type (gnu_string_index_type
,
2853 = build_nonshared_array_type (gnat_to_gnu_type
2854 (Component_Type (gnat_entity
)),
2856 if (array_type_has_nonaliased_component (gnu_type
, gnat_entity
))
2857 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2858 relate_alias_sets (gnu_type
, gnu_string_type
, ALIAS_SET_COPY
);
2862 /* Record Types and Subtypes
2864 The following fields are defined on record types:
2866 Has_Discriminants True if the record has discriminants
2867 First_Discriminant Points to head of list of discriminants
2868 First_Entity Points to head of list of fields
2869 Is_Tagged_Type True if the record is tagged
2871 Implementation of Ada records and discriminated records:
2873 A record type definition is transformed into the equivalent of a C
2874 struct definition. The fields that are the discriminants which are
2875 found in the Full_Type_Declaration node and the elements of the
2876 Component_List found in the Record_Type_Definition node. The
2877 Component_List can be a recursive structure since each Variant of
2878 the Variant_Part of the Component_List has a Component_List.
2880 Processing of a record type definition comprises starting the list of
2881 field declarations here from the discriminants and the calling the
2882 function components_to_record to add the rest of the fields from the
2883 component list and return the gnu type node. The function
2884 components_to_record will call itself recursively as it traverses
2888 if (Has_Complex_Representation (gnat_entity
))
2891 = build_complex_type
2893 (Etype (Defining_Entity
2894 (First (Component_Items
2897 (Declaration_Node (gnat_entity
)))))))));
2903 Node_Id full_definition
= Declaration_Node (gnat_entity
);
2904 Node_Id record_definition
= Type_Definition (full_definition
);
2905 Entity_Id gnat_field
;
2906 tree gnu_field
, gnu_field_list
= NULL_TREE
, gnu_get_parent
;
2907 /* Set PACKED in keeping with gnat_to_gnu_field. */
2909 = Is_Packed (gnat_entity
)
2911 : Component_Alignment (gnat_entity
) == Calign_Storage_Unit
2913 : (Known_Alignment (gnat_entity
)
2914 || (Strict_Alignment (gnat_entity
)
2915 && Known_RM_Size (gnat_entity
)))
2918 bool has_discr
= Has_Discriminants (gnat_entity
);
2919 bool has_rep
= Has_Specified_Layout (gnat_entity
);
2920 bool all_rep
= has_rep
;
2922 = (Is_Tagged_Type (gnat_entity
)
2923 && Nkind (record_definition
) == N_Derived_Type_Definition
);
2924 bool is_unchecked_union
= Is_Unchecked_Union (gnat_entity
);
2926 /* See if all fields have a rep clause. Stop when we find one
2929 for (gnat_field
= First_Entity (gnat_entity
);
2930 Present (gnat_field
);
2931 gnat_field
= Next_Entity (gnat_field
))
2932 if ((Ekind (gnat_field
) == E_Component
2933 || Ekind (gnat_field
) == E_Discriminant
)
2934 && No (Component_Clause (gnat_field
)))
2940 /* If this is a record extension, go a level further to find the
2941 record definition. Also, verify we have a Parent_Subtype. */
2944 if (!type_annotate_only
2945 || Present (Record_Extension_Part (record_definition
)))
2946 record_definition
= Record_Extension_Part (record_definition
);
2948 gcc_assert (type_annotate_only
2949 || Present (Parent_Subtype (gnat_entity
)));
2952 /* Make a node for the record. If we are not defining the record,
2953 suppress expanding incomplete types. */
2954 gnu_type
= make_node (tree_code_for_record_type (gnat_entity
));
2955 TYPE_NAME (gnu_type
) = gnu_entity_name
;
2956 TYPE_PACKED (gnu_type
) = (packed
!= 0) || has_rep
;
2960 defer_incomplete_level
++;
2961 this_deferred
= true;
2964 /* If both a size and rep clause was specified, put the size in
2965 the record type now so that it can get the proper mode. */
2966 if (has_rep
&& Known_RM_Size (gnat_entity
))
2967 TYPE_SIZE (gnu_type
)
2968 = UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
);
2970 /* Always set the alignment here so that it can be used to
2971 set the mode, if it is making the alignment stricter. If
2972 it is invalid, it will be checked again below. If this is to
2973 be Atomic, choose a default alignment of a word unless we know
2974 the size and it's smaller. */
2975 if (Known_Alignment (gnat_entity
))
2976 TYPE_ALIGN (gnu_type
)
2977 = validate_alignment (Alignment (gnat_entity
), gnat_entity
, 0);
2978 else if (Is_Atomic (gnat_entity
) && Known_Esize (gnat_entity
))
2980 unsigned int size
= UI_To_Int (Esize (gnat_entity
));
2981 TYPE_ALIGN (gnu_type
)
2982 = size
>= BITS_PER_WORD
? BITS_PER_WORD
: ceil_pow2 (size
);
2984 /* If a type needs strict alignment, the minimum size will be the
2985 type size instead of the RM size (see validate_size). Cap the
2986 alignment, lest it causes this type size to become too large. */
2987 else if (Strict_Alignment (gnat_entity
) && Known_RM_Size (gnat_entity
))
2989 unsigned int raw_size
= UI_To_Int (RM_Size (gnat_entity
));
2990 unsigned int raw_align
= raw_size
& -raw_size
;
2991 if (raw_align
< BIGGEST_ALIGNMENT
)
2992 TYPE_ALIGN (gnu_type
) = raw_align
;
2995 TYPE_ALIGN (gnu_type
) = 0;
2997 /* If we have a Parent_Subtype, make a field for the parent. If
2998 this record has rep clauses, force the position to zero. */
2999 if (Present (Parent_Subtype (gnat_entity
)))
3001 Entity_Id gnat_parent
= Parent_Subtype (gnat_entity
);
3002 tree gnu_dummy_parent_type
= make_node (RECORD_TYPE
);
3005 /* A major complexity here is that the parent subtype will
3006 reference our discriminants in its Discriminant_Constraint
3007 list. But those must reference the parent component of this
3008 record which is of the parent subtype we have not built yet!
3009 To break the circle we first build a dummy COMPONENT_REF which
3010 represents the "get to the parent" operation and initialize
3011 each of those discriminants to a COMPONENT_REF of the above
3012 dummy parent referencing the corresponding discriminant of the
3013 base type of the parent subtype. */
3014 gnu_get_parent
= build3 (COMPONENT_REF
, gnu_dummy_parent_type
,
3015 build0 (PLACEHOLDER_EXPR
, gnu_type
),
3016 build_decl (input_location
,
3017 FIELD_DECL
, NULL_TREE
,
3018 gnu_dummy_parent_type
),
3022 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3023 Present (gnat_field
);
3024 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3025 if (Present (Corresponding_Discriminant (gnat_field
)))
3028 = gnat_to_gnu_field_decl (Corresponding_Discriminant
3032 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3033 gnu_get_parent
, gnu_field
, NULL_TREE
),
3037 /* Then we build the parent subtype. If it has discriminants but
3038 the type itself has unknown discriminants, this means that it
3039 doesn't contain information about how the discriminants are
3040 derived from those of the ancestor type, so it cannot be used
3041 directly. Instead it is built by cloning the parent subtype
3042 of the underlying record view of the type, for which the above
3043 derivation of discriminants has been made explicit. */
3044 if (Has_Discriminants (gnat_parent
)
3045 && Has_Unknown_Discriminants (gnat_entity
))
3047 Entity_Id gnat_uview
= Underlying_Record_View (gnat_entity
);
3049 /* If we are defining the type, the underlying record
3050 view must already have been elaborated at this point.
3051 Otherwise do it now as its parent subtype cannot be
3052 technically elaborated on its own. */
3054 gcc_assert (present_gnu_tree (gnat_uview
));
3056 gnat_to_gnu_entity (gnat_uview
, NULL_TREE
, 0);
3058 gnu_parent
= gnat_to_gnu_type (Parent_Subtype (gnat_uview
));
3060 /* Substitute the "get to the parent" of the type for that
3061 of its underlying record view in the cloned type. */
3062 for (gnat_field
= First_Stored_Discriminant (gnat_uview
);
3063 Present (gnat_field
);
3064 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3065 if (Present (Corresponding_Discriminant (gnat_field
)))
3067 tree gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
3069 = build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3070 gnu_get_parent
, gnu_field
, NULL_TREE
);
3072 = substitute_in_type (gnu_parent
, gnu_field
, gnu_ref
);
3076 gnu_parent
= gnat_to_gnu_type (gnat_parent
);
3078 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
3079 initially built. The discriminants must reference the fields
3080 of the parent subtype and not those of its base type for the
3081 placeholder machinery to properly work. */
3084 /* The actual parent subtype is the full view. */
3085 if (IN (Ekind (gnat_parent
), Private_Kind
))
3087 if (Present (Full_View (gnat_parent
)))
3088 gnat_parent
= Full_View (gnat_parent
);
3090 gnat_parent
= Underlying_Full_View (gnat_parent
);
3093 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3094 Present (gnat_field
);
3095 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3096 if (Present (Corresponding_Discriminant (gnat_field
)))
3098 Entity_Id field
= Empty
;
3099 for (field
= First_Stored_Discriminant (gnat_parent
);
3101 field
= Next_Stored_Discriminant (field
))
3102 if (same_discriminant_p (gnat_field
, field
))
3104 gcc_assert (Present (field
));
3105 TREE_OPERAND (get_gnu_tree (gnat_field
), 1)
3106 = gnat_to_gnu_field_decl (field
);
3110 /* The "get to the parent" COMPONENT_REF must be given its
3112 TREE_TYPE (gnu_get_parent
) = gnu_parent
;
3114 /* ...and reference the _Parent field of this record. */
3116 = create_field_decl (parent_name_id
,
3117 gnu_parent
, gnu_type
,
3119 ? TYPE_SIZE (gnu_parent
) : NULL_TREE
,
3121 ? bitsize_zero_node
: NULL_TREE
,
3123 DECL_INTERNAL_P (gnu_field
) = 1;
3124 TREE_OPERAND (gnu_get_parent
, 1) = gnu_field
;
3125 TYPE_FIELDS (gnu_type
) = gnu_field
;
3128 /* Make the fields for the discriminants and put them into the record
3129 unless it's an Unchecked_Union. */
3131 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3132 Present (gnat_field
);
3133 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3135 /* If this is a record extension and this discriminant is the
3136 renaming of another discriminant, we've handled it above. */
3137 if (Present (Parent_Subtype (gnat_entity
))
3138 && Present (Corresponding_Discriminant (gnat_field
)))
3142 = gnat_to_gnu_field (gnat_field
, gnu_type
, packed
, definition
,
3145 /* Make an expression using a PLACEHOLDER_EXPR from the
3146 FIELD_DECL node just created and link that with the
3147 corresponding GNAT defining identifier. */
3148 save_gnu_tree (gnat_field
,
3149 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3150 build0 (PLACEHOLDER_EXPR
, gnu_type
),
3151 gnu_field
, NULL_TREE
),
3154 if (!is_unchecked_union
)
3156 DECL_CHAIN (gnu_field
) = gnu_field_list
;
3157 gnu_field_list
= gnu_field
;
3161 /* Add the fields into the record type and finish it up. */
3162 components_to_record (gnu_type
, Component_List (record_definition
),
3163 gnu_field_list
, packed
, definition
, false,
3164 all_rep
, is_unchecked_union
,
3165 !Comes_From_Source (gnat_entity
), debug_info_p
,
3166 false, OK_To_Reorder_Components (gnat_entity
),
3167 all_rep
? NULL_TREE
: bitsize_zero_node
, NULL
);
3169 /* If it is passed by reference, force BLKmode to ensure that objects
3170 of this type will always be put in memory. */
3171 if (TYPE_MODE (gnu_type
) != BLKmode
3172 && Is_By_Reference_Type (gnat_entity
))
3173 SET_TYPE_MODE (gnu_type
, BLKmode
);
3175 /* We used to remove the associations of the discriminants and _Parent
3176 for validity checking but we may need them if there's a Freeze_Node
3177 for a subtype used in this record. */
3178 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
3180 /* Fill in locations of fields. */
3181 annotate_rep (gnat_entity
, gnu_type
);
3183 /* If there are any entities in the chain corresponding to components
3184 that we did not elaborate, ensure we elaborate their types if they
3186 for (gnat_temp
= First_Entity (gnat_entity
);
3187 Present (gnat_temp
);
3188 gnat_temp
= Next_Entity (gnat_temp
))
3189 if ((Ekind (gnat_temp
) == E_Component
3190 || Ekind (gnat_temp
) == E_Discriminant
)
3191 && Is_Itype (Etype (gnat_temp
))
3192 && !present_gnu_tree (gnat_temp
))
3193 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
3195 /* If this is a record type associated with an exception definition,
3196 equate its fields to those of the standard exception type. This
3197 will make it possible to convert between them. */
3198 if (gnu_entity_name
== exception_data_name_id
)
3201 for (gnu_field
= TYPE_FIELDS (gnu_type
),
3202 gnu_std_field
= TYPE_FIELDS (except_type_node
);
3204 gnu_field
= DECL_CHAIN (gnu_field
),
3205 gnu_std_field
= DECL_CHAIN (gnu_std_field
))
3206 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field
, gnu_std_field
);
3207 gcc_assert (!gnu_std_field
);
3212 case E_Class_Wide_Subtype
:
3213 /* If an equivalent type is present, that is what we should use.
3214 Otherwise, fall through to handle this like a record subtype
3215 since it may have constraints. */
3216 if (gnat_equiv_type
!= gnat_entity
)
3218 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
3219 maybe_present
= true;
3223 /* ... fall through ... */
3225 case E_Record_Subtype
:
3226 /* If Cloned_Subtype is Present it means this record subtype has
3227 identical layout to that type or subtype and we should use
3228 that GCC type for this one. The front end guarantees that
3229 the component list is shared. */
3230 if (Present (Cloned_Subtype (gnat_entity
)))
3232 gnu_decl
= gnat_to_gnu_entity (Cloned_Subtype (gnat_entity
),
3234 maybe_present
= true;
3238 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3239 changing the type, make a new type with each field having the type of
3240 the field in the new subtype but the position computed by transforming
3241 every discriminant reference according to the constraints. We don't
3242 see any difference between private and non-private type here since
3243 derivations from types should have been deferred until the completion
3244 of the private type. */
3247 Entity_Id gnat_base_type
= Implementation_Base_Type (gnat_entity
);
3252 defer_incomplete_level
++;
3253 this_deferred
= true;
3256 gnu_base_type
= gnat_to_gnu_type (gnat_base_type
);
3258 if (present_gnu_tree (gnat_entity
))
3260 maybe_present
= true;
3264 /* If this is a record subtype associated with a dispatch table,
3265 strip the suffix. This is necessary to make sure 2 different
3266 subtypes associated with the imported and exported views of a
3267 dispatch table are properly merged in LTO mode. */
3268 if (Is_Dispatch_Table_Entity (gnat_entity
))
3271 Get_Encoded_Name (gnat_entity
);
3272 p
= strchr (Name_Buffer
, '_');
3274 strcpy (p
+2, "dtS");
3275 gnu_entity_name
= get_identifier (Name_Buffer
);
3278 /* When the subtype has discriminants and these discriminants affect
3279 the initial shape it has inherited, factor them in. But for an
3280 Unchecked_Union (it must be an Itype), just return the type.
3281 We can't just test Is_Constrained because private subtypes without
3282 discriminants of types with discriminants with default expressions
3283 are Is_Constrained but aren't constrained! */
3284 if (IN (Ekind (gnat_base_type
), Record_Kind
)
3285 && !Is_Unchecked_Union (gnat_base_type
)
3286 && !Is_For_Access_Subtype (gnat_entity
)
3287 && Is_Constrained (gnat_entity
)
3288 && Has_Discriminants (gnat_entity
)
3289 && Present (Discriminant_Constraint (gnat_entity
))
3290 && Stored_Constraint (gnat_entity
) != No_Elist
)
3292 vec
<subst_pair
> gnu_subst_list
3293 = build_subst_list (gnat_entity
, gnat_base_type
, definition
);
3294 tree gnu_unpad_base_type
, gnu_rep_part
, gnu_variant_part
, t
;
3295 tree gnu_pos_list
, gnu_field_list
= NULL_TREE
;
3296 bool selected_variant
= false;
3297 Entity_Id gnat_field
;
3298 vec
<variant_desc
> gnu_variant_list
;
3300 gnu_type
= make_node (RECORD_TYPE
);
3301 TYPE_NAME (gnu_type
) = gnu_entity_name
;
3302 TYPE_PACKED (gnu_type
) = TYPE_PACKED (gnu_base_type
);
3304 /* Set the size, alignment and alias set of the new type to
3305 match that of the old one, doing required substitutions. */
3306 copy_and_substitute_in_size (gnu_type
, gnu_base_type
,
3309 if (TYPE_IS_PADDING_P (gnu_base_type
))
3310 gnu_unpad_base_type
= TREE_TYPE (TYPE_FIELDS (gnu_base_type
));
3312 gnu_unpad_base_type
= gnu_base_type
;
3314 /* Look for a variant part in the base type. */
3315 gnu_variant_part
= get_variant_part (gnu_unpad_base_type
);
3317 /* If there is a variant part, we must compute whether the
3318 constraints statically select a particular variant. If
3319 so, we simply drop the qualified union and flatten the
3320 list of fields. Otherwise we'll build a new qualified
3321 union for the variants that are still relevant. */
3322 if (gnu_variant_part
)
3328 = build_variant_list (TREE_TYPE (gnu_variant_part
),
3332 /* If all the qualifiers are unconditionally true, the
3333 innermost variant is statically selected. */
3334 selected_variant
= true;
3335 FOR_EACH_VEC_ELT (gnu_variant_list
, i
, v
)
3336 if (!integer_onep (v
->qual
))
3338 selected_variant
= false;
3342 /* Otherwise, create the new variants. */
3343 if (!selected_variant
)
3344 FOR_EACH_VEC_ELT (gnu_variant_list
, i
, v
)
3346 tree old_variant
= v
->type
;
3347 tree new_variant
= make_node (RECORD_TYPE
);
3349 = concat_name (DECL_NAME (gnu_variant_part
),
3351 (DECL_NAME (v
->field
)));
3352 TYPE_NAME (new_variant
)
3353 = concat_name (TYPE_NAME (gnu_type
),
3354 IDENTIFIER_POINTER (suffix
));
3355 copy_and_substitute_in_size (new_variant
, old_variant
,
3357 v
->new_type
= new_variant
;
3362 gnu_variant_list
.create (0);
3363 selected_variant
= false;
3367 = build_position_list (gnu_unpad_base_type
,
3368 gnu_variant_list
.exists ()
3369 && !selected_variant
,
3370 size_zero_node
, bitsize_zero_node
,
3371 BIGGEST_ALIGNMENT
, NULL_TREE
);
3373 for (gnat_field
= First_Entity (gnat_entity
);
3374 Present (gnat_field
);
3375 gnat_field
= Next_Entity (gnat_field
))
3376 if ((Ekind (gnat_field
) == E_Component
3377 || Ekind (gnat_field
) == E_Discriminant
)
3378 && !(Present (Corresponding_Discriminant (gnat_field
))
3379 && Is_Tagged_Type (gnat_base_type
))
3380 && Underlying_Type (Scope (Original_Record_Component
3384 Name_Id gnat_name
= Chars (gnat_field
);
3385 Entity_Id gnat_old_field
3386 = Original_Record_Component (gnat_field
);
3388 = gnat_to_gnu_field_decl (gnat_old_field
);
3389 tree gnu_context
= DECL_CONTEXT (gnu_old_field
);
3390 tree gnu_field
, gnu_field_type
, gnu_size
;
3391 tree gnu_cont_type
, gnu_last
= NULL_TREE
;
3393 /* If the type is the same, retrieve the GCC type from the
3394 old field to take into account possible adjustments. */
3395 if (Etype (gnat_field
) == Etype (gnat_old_field
))
3396 gnu_field_type
= TREE_TYPE (gnu_old_field
);
3398 gnu_field_type
= gnat_to_gnu_type (Etype (gnat_field
));
3400 /* If there was a component clause, the field types must be
3401 the same for the type and subtype, so copy the data from
3402 the old field to avoid recomputation here. Also if the
3403 field is justified modular and the optimization in
3404 gnat_to_gnu_field was applied. */
3405 if (Present (Component_Clause (gnat_old_field
))
3406 || (TREE_CODE (gnu_field_type
) == RECORD_TYPE
3407 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
3408 && TREE_TYPE (TYPE_FIELDS (gnu_field_type
))
3409 == TREE_TYPE (gnu_old_field
)))
3411 gnu_size
= DECL_SIZE (gnu_old_field
);
3412 gnu_field_type
= TREE_TYPE (gnu_old_field
);
3415 /* If the old field was packed and of constant size, we
3416 have to get the old size here, as it might differ from
3417 what the Etype conveys and the latter might overlap
3418 onto the following field. Try to arrange the type for
3419 possible better packing along the way. */
3420 else if (DECL_PACKED (gnu_old_field
)
3421 && TREE_CODE (DECL_SIZE (gnu_old_field
))
3424 gnu_size
= DECL_SIZE (gnu_old_field
);
3425 if (RECORD_OR_UNION_TYPE_P (gnu_field_type
)
3426 && !TYPE_FAT_POINTER_P (gnu_field_type
)
3427 && host_integerp (TYPE_SIZE (gnu_field_type
), 1))
3429 = make_packable_type (gnu_field_type
, true);
3433 gnu_size
= TYPE_SIZE (gnu_field_type
);
3435 /* If the context of the old field is the base type or its
3436 REP part (if any), put the field directly in the new
3437 type; otherwise look up the context in the variant list
3438 and put the field either in the new type if there is a
3439 selected variant or in one of the new variants. */
3440 if (gnu_context
== gnu_unpad_base_type
3441 || ((gnu_rep_part
= get_rep_part (gnu_unpad_base_type
))
3442 && gnu_context
== TREE_TYPE (gnu_rep_part
)))
3443 gnu_cont_type
= gnu_type
;
3450 FOR_EACH_VEC_ELT (gnu_variant_list
, i
, v
)
3451 if (gnu_context
== v
->type
3452 || ((gnu_rep_part
= get_rep_part (v
->type
))
3453 && gnu_context
== TREE_TYPE (gnu_rep_part
)))
3460 if (selected_variant
)
3461 gnu_cont_type
= gnu_type
;
3463 gnu_cont_type
= v
->new_type
;
3466 /* The front-end may pass us "ghost" components if
3467 it fails to recognize that a constrained subtype
3468 is statically constrained. Discard them. */
3472 /* Now create the new field modeled on the old one. */
3474 = create_field_decl_from (gnu_old_field
, gnu_field_type
,
3475 gnu_cont_type
, gnu_size
,
3476 gnu_pos_list
, gnu_subst_list
);
3478 /* Put it in one of the new variants directly. */
3479 if (gnu_cont_type
!= gnu_type
)
3481 DECL_CHAIN (gnu_field
) = TYPE_FIELDS (gnu_cont_type
);
3482 TYPE_FIELDS (gnu_cont_type
) = gnu_field
;
3485 /* To match the layout crafted in components_to_record,
3486 if this is the _Tag or _Parent field, put it before
3487 any other fields. */
3488 else if (gnat_name
== Name_uTag
3489 || gnat_name
== Name_uParent
)
3490 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
3492 /* Similarly, if this is the _Controller field, put
3493 it before the other fields except for the _Tag or
3495 else if (gnat_name
== Name_uController
&& gnu_last
)
3497 DECL_CHAIN (gnu_field
) = DECL_CHAIN (gnu_last
);
3498 DECL_CHAIN (gnu_last
) = gnu_field
;
3501 /* Otherwise, if this is a regular field, put it after
3502 the other fields. */
3505 DECL_CHAIN (gnu_field
) = gnu_field_list
;
3506 gnu_field_list
= gnu_field
;
3508 gnu_last
= gnu_field
;
3511 save_gnu_tree (gnat_field
, gnu_field
, false);
3514 /* If there is a variant list and no selected variant, we need
3515 to create the nest of variant parts from the old nest. */
3516 if (gnu_variant_list
.exists () && !selected_variant
)
3518 tree new_variant_part
3519 = create_variant_part_from (gnu_variant_part
,
3520 gnu_variant_list
, gnu_type
,
3521 gnu_pos_list
, gnu_subst_list
);
3522 DECL_CHAIN (new_variant_part
) = gnu_field_list
;
3523 gnu_field_list
= new_variant_part
;
3526 /* Now go through the entities again looking for Itypes that
3527 we have not elaborated but should (e.g., Etypes of fields
3528 that have Original_Components). */
3529 for (gnat_field
= First_Entity (gnat_entity
);
3530 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
3531 if ((Ekind (gnat_field
) == E_Discriminant
3532 || Ekind (gnat_field
) == E_Component
)
3533 && !present_gnu_tree (Etype (gnat_field
)))
3534 gnat_to_gnu_entity (Etype (gnat_field
), NULL_TREE
, 0);
3536 /* Do not emit debug info for the type yet since we're going to
3538 finish_record_type (gnu_type
, nreverse (gnu_field_list
), 2,
3540 compute_record_mode (gnu_type
);
3542 /* See the E_Record_Type case for the rationale. */
3543 if (TYPE_MODE (gnu_type
) != BLKmode
3544 && Is_By_Reference_Type (gnat_entity
))
3545 SET_TYPE_MODE (gnu_type
, BLKmode
);
3547 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
3549 /* Fill in locations of fields. */
3550 annotate_rep (gnat_entity
, gnu_type
);
3552 /* If debugging information is being written for the type, write
3553 a record that shows what we are a subtype of and also make a
3554 variable that indicates our size, if still variable. */
3557 tree gnu_subtype_marker
= make_node (RECORD_TYPE
);
3558 tree gnu_unpad_base_name
= TYPE_NAME (gnu_unpad_base_type
);
3559 tree gnu_size_unit
= TYPE_SIZE_UNIT (gnu_type
);
3561 if (TREE_CODE (gnu_unpad_base_name
) == TYPE_DECL
)
3562 gnu_unpad_base_name
= DECL_NAME (gnu_unpad_base_name
);
3564 TYPE_NAME (gnu_subtype_marker
)
3565 = create_concat_name (gnat_entity
, "XVS");
3566 finish_record_type (gnu_subtype_marker
,
3567 create_field_decl (gnu_unpad_base_name
,
3568 build_reference_type
3569 (gnu_unpad_base_type
),
3571 NULL_TREE
, NULL_TREE
,
3575 add_parallel_type (gnu_type
, gnu_subtype_marker
);
3578 && TREE_CODE (gnu_size_unit
) != INTEGER_CST
3579 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit
))
3580 TYPE_SIZE_UNIT (gnu_subtype_marker
)
3581 = create_var_decl (create_concat_name (gnat_entity
,
3583 NULL_TREE
, sizetype
, gnu_size_unit
,
3584 false, false, false, false, NULL
,
3588 gnu_variant_list
.release ();
3589 gnu_subst_list
.release ();
3591 /* Now we can finalize it. */
3592 rest_of_record_type_compilation (gnu_type
);
3595 /* Otherwise, go down all the components in the new type and make
3596 them equivalent to those in the base type. */
3599 gnu_type
= gnu_base_type
;
3601 for (gnat_temp
= First_Entity (gnat_entity
);
3602 Present (gnat_temp
);
3603 gnat_temp
= Next_Entity (gnat_temp
))
3604 if ((Ekind (gnat_temp
) == E_Discriminant
3605 && !Is_Unchecked_Union (gnat_base_type
))
3606 || Ekind (gnat_temp
) == E_Component
)
3607 save_gnu_tree (gnat_temp
,
3608 gnat_to_gnu_field_decl
3609 (Original_Record_Component (gnat_temp
)),
3615 case E_Access_Subprogram_Type
:
3616 /* Use the special descriptor type for dispatch tables if needed,
3617 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3618 Note that we are only required to do so for static tables in
3619 order to be compatible with the C++ ABI, but Ada 2005 allows
3620 to extend library level tagged types at the local level so
3621 we do it in the non-static case as well. */
3622 if (TARGET_VTABLE_USES_DESCRIPTORS
3623 && Is_Dispatch_Table_Entity (gnat_entity
))
3625 gnu_type
= fdesc_type_node
;
3626 gnu_size
= TYPE_SIZE (gnu_type
);
3630 /* ... fall through ... */
3632 case E_Anonymous_Access_Subprogram_Type
:
3633 /* If we are not defining this entity, and we have incomplete
3634 entities being processed above us, make a dummy type and
3635 fill it in later. */
3636 if (!definition
&& defer_incomplete_level
!= 0)
3638 struct incomplete
*p
= XNEW (struct incomplete
);
3641 = build_pointer_type
3642 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
3643 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
3644 !Comes_From_Source (gnat_entity
),
3645 debug_info_p
, gnat_entity
);
3646 this_made_decl
= true;
3647 gnu_type
= TREE_TYPE (gnu_decl
);
3648 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3651 p
->old_type
= TREE_TYPE (gnu_type
);
3652 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3653 p
->next
= defer_incomplete_list
;
3654 defer_incomplete_list
= p
;
3658 /* ... fall through ... */
3660 case E_Allocator_Type
:
3662 case E_Access_Attribute_Type
:
3663 case E_Anonymous_Access_Type
:
3664 case E_General_Access_Type
:
3666 /* The designated type and its equivalent type for gigi. */
3667 Entity_Id gnat_desig_type
= Directly_Designated_Type (gnat_entity
);
3668 Entity_Id gnat_desig_equiv
= Gigi_Equivalent_Type (gnat_desig_type
);
3669 /* Whether it comes from a limited with. */
3670 bool is_from_limited_with
3671 = (IN (Ekind (gnat_desig_equiv
), Incomplete_Kind
)
3672 && From_With_Type (gnat_desig_equiv
));
3673 /* The "full view" of the designated type. If this is an incomplete
3674 entity from a limited with, treat its non-limited view as the full
3675 view. Otherwise, if this is an incomplete or private type, use the
3676 full view. In the former case, we might point to a private type,
3677 in which case, we need its full view. Also, we want to look at the
3678 actual type used for the representation, so this takes a total of
3680 Entity_Id gnat_desig_full_direct_first
3681 = (is_from_limited_with
3682 ? Non_Limited_View (gnat_desig_equiv
)
3683 : (IN (Ekind (gnat_desig_equiv
), Incomplete_Or_Private_Kind
)
3684 ? Full_View (gnat_desig_equiv
) : Empty
));
3685 Entity_Id gnat_desig_full_direct
3686 = ((is_from_limited_with
3687 && Present (gnat_desig_full_direct_first
)
3688 && IN (Ekind (gnat_desig_full_direct_first
), Private_Kind
))
3689 ? Full_View (gnat_desig_full_direct_first
)
3690 : gnat_desig_full_direct_first
);
3691 Entity_Id gnat_desig_full
3692 = Gigi_Equivalent_Type (gnat_desig_full_direct
);
3693 /* The type actually used to represent the designated type, either
3694 gnat_desig_full or gnat_desig_equiv. */
3695 Entity_Id gnat_desig_rep
;
3696 /* True if this is a pointer to an unconstrained array. */
3697 bool is_unconstrained_array
;
3698 /* We want to know if we'll be seeing the freeze node for any
3699 incomplete type we may be pointing to. */
3701 = (Present (gnat_desig_full
)
3702 ? In_Extended_Main_Code_Unit (gnat_desig_full
)
3703 : In_Extended_Main_Code_Unit (gnat_desig_type
));
3704 /* True if we make a dummy type here. */
3705 bool made_dummy
= false;
3706 /* The mode to be used for the pointer type. */
3707 enum machine_mode p_mode
= mode_for_size (esize
, MODE_INT
, 0);
3708 /* The GCC type used for the designated type. */
3709 tree gnu_desig_type
= NULL_TREE
;
3711 if (!targetm
.valid_pointer_mode (p_mode
))
3714 /* If either the designated type or its full view is an unconstrained
3715 array subtype, replace it with the type it's a subtype of. This
3716 avoids problems with multiple copies of unconstrained array types.
3717 Likewise, if the designated type is a subtype of an incomplete
3718 record type, use the parent type to avoid order of elaboration
3719 issues. This can lose some code efficiency, but there is no
3721 if (Ekind (gnat_desig_equiv
) == E_Array_Subtype
3722 && !Is_Constrained (gnat_desig_equiv
))
3723 gnat_desig_equiv
= Etype (gnat_desig_equiv
);
3724 if (Present (gnat_desig_full
)
3725 && ((Ekind (gnat_desig_full
) == E_Array_Subtype
3726 && !Is_Constrained (gnat_desig_full
))
3727 || (Ekind (gnat_desig_full
) == E_Record_Subtype
3728 && Ekind (Etype (gnat_desig_full
)) == E_Record_Type
)))
3729 gnat_desig_full
= Etype (gnat_desig_full
);
3731 /* Set the type that's actually the representation of the designated
3732 type and also flag whether we have a unconstrained array. */
3734 = Present (gnat_desig_full
) ? gnat_desig_full
: gnat_desig_equiv
;
3735 is_unconstrained_array
3736 = Is_Array_Type (gnat_desig_rep
) && !Is_Constrained (gnat_desig_rep
);
3738 /* If we are pointing to an incomplete type whose completion is an
3739 unconstrained array, make dummy fat and thin pointer types to it.
3740 Likewise if the type itself is dummy or an unconstrained array. */
3741 if (is_unconstrained_array
3742 && (Present (gnat_desig_full
)
3743 || (present_gnu_tree (gnat_desig_equiv
)
3745 (TREE_TYPE (get_gnu_tree (gnat_desig_equiv
))))
3747 && defer_incomplete_level
!= 0
3748 && !present_gnu_tree (gnat_desig_equiv
))
3750 && is_from_limited_with
3751 && Present (Freeze_Node (gnat_desig_equiv
)))))
3753 if (present_gnu_tree (gnat_desig_rep
))
3754 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_rep
));
3757 gnu_desig_type
= make_dummy_type (gnat_desig_rep
);
3761 /* If the call above got something that has a pointer, the pointer
3762 is our type. This could have happened either because the type
3763 was elaborated or because somebody else executed the code. */
3764 if (!TYPE_POINTER_TO (gnu_desig_type
))
3765 build_dummy_unc_pointer_types (gnat_desig_equiv
, gnu_desig_type
);
3766 gnu_type
= TYPE_POINTER_TO (gnu_desig_type
);
3769 /* If we already know what the full type is, use it. */
3770 else if (Present (gnat_desig_full
)
3771 && present_gnu_tree (gnat_desig_full
))
3772 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_full
));
3774 /* Get the type of the thing we are to point to and build a pointer to
3775 it. If it is a reference to an incomplete or private type with a
3776 full view that is a record, make a dummy type node and get the
3777 actual type later when we have verified it is safe. */
3778 else if ((!in_main_unit
3779 && !present_gnu_tree (gnat_desig_equiv
)
3780 && Present (gnat_desig_full
)
3781 && !present_gnu_tree (gnat_desig_full
)
3782 && Is_Record_Type (gnat_desig_full
))
3783 /* Likewise if we are pointing to a record or array and we are
3784 to defer elaborating incomplete types. We do this as this
3785 access type may be the full view of a private type. Note
3786 that the unconstrained array case is handled above. */
3787 || ((!in_main_unit
|| imported_p
)
3788 && defer_incomplete_level
!= 0
3789 && !present_gnu_tree (gnat_desig_equiv
)
3790 && (Is_Record_Type (gnat_desig_rep
)
3791 || Is_Array_Type (gnat_desig_rep
)))
3792 /* If this is a reference from a limited_with type back to our
3793 main unit and there's a freeze node for it, either we have
3794 already processed the declaration and made the dummy type,
3795 in which case we just reuse the latter, or we have not yet,
3796 in which case we make the dummy type and it will be reused
3797 when the declaration is finally processed. In both cases,
3798 the pointer eventually created below will be automatically
3799 adjusted when the freeze node is processed. Note that the
3800 unconstrained array case is handled above. */
3802 && is_from_limited_with
3803 && Present (Freeze_Node (gnat_desig_rep
))))
3805 gnu_desig_type
= make_dummy_type (gnat_desig_equiv
);
3809 /* Otherwise handle the case of a pointer to itself. */
3810 else if (gnat_desig_equiv
== gnat_entity
)
3813 = build_pointer_type_for_mode (void_type_node
, p_mode
,
3814 No_Strict_Aliasing (gnat_entity
));
3815 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
) = gnu_type
;
3818 /* If expansion is disabled, the equivalent type of a concurrent type
3819 is absent, so build a dummy pointer type. */
3820 else if (type_annotate_only
&& No (gnat_desig_equiv
))
3821 gnu_type
= ptr_void_type_node
;
3823 /* Finally, handle the default case where we can just elaborate our
3826 gnu_desig_type
= gnat_to_gnu_type (gnat_desig_equiv
);
3828 /* It is possible that a call to gnat_to_gnu_type above resolved our
3829 type. If so, just return it. */
3830 if (present_gnu_tree (gnat_entity
))
3832 maybe_present
= true;
3836 /* If we haven't done it yet, build the pointer type the usual way. */
3839 /* Modify the designated type if we are pointing only to constant
3840 objects, but don't do it for unconstrained arrays. */
3841 if (Is_Access_Constant (gnat_entity
)
3842 && TREE_CODE (gnu_desig_type
) != UNCONSTRAINED_ARRAY_TYPE
)
3845 = build_qualified_type
3847 TYPE_QUALS (gnu_desig_type
) | TYPE_QUAL_CONST
);
3849 /* Some extra processing is required if we are building a
3850 pointer to an incomplete type (in the GCC sense). We might
3851 have such a type if we just made a dummy, or directly out
3852 of the call to gnat_to_gnu_type above if we are processing
3853 an access type for a record component designating the
3854 record type itself. */
3855 if (TYPE_MODE (gnu_desig_type
) == VOIDmode
)
3857 /* We must ensure that the pointer to variant we make will
3858 be processed by update_pointer_to when the initial type
3859 is completed. Pretend we made a dummy and let further
3860 processing act as usual. */
3863 /* We must ensure that update_pointer_to will not retrieve
3864 the dummy variant when building a properly qualified
3865 version of the complete type. We take advantage of the
3866 fact that get_qualified_type is requiring TYPE_NAMEs to
3867 match to influence build_qualified_type and then also
3868 update_pointer_to here. */
3869 TYPE_NAME (gnu_desig_type
)
3870 = create_concat_name (gnat_desig_type
, "INCOMPLETE_CST");
3875 = build_pointer_type_for_mode (gnu_desig_type
, p_mode
,
3876 No_Strict_Aliasing (gnat_entity
));
3879 /* If we are not defining this object and we have made a dummy pointer,
3880 save our current definition, evaluate the actual type, and replace
3881 the tentative type we made with the actual one. If we are to defer
3882 actually looking up the actual type, make an entry in the deferred
3883 list. If this is from a limited with, we may have to defer to the
3884 end of the current unit. */
3885 if ((!in_main_unit
|| is_from_limited_with
) && made_dummy
)
3887 tree gnu_old_desig_type
;
3889 if (TYPE_IS_FAT_POINTER_P (gnu_type
))
3891 gnu_old_desig_type
= TYPE_UNCONSTRAINED_ARRAY (gnu_type
);
3892 if (esize
== POINTER_SIZE
)
3893 gnu_type
= build_pointer_type
3894 (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type
));
3897 gnu_old_desig_type
= TREE_TYPE (gnu_type
);
3899 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
3900 !Comes_From_Source (gnat_entity
),
3901 debug_info_p
, gnat_entity
);
3902 this_made_decl
= true;
3903 gnu_type
= TREE_TYPE (gnu_decl
);
3904 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3907 /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
3908 update gnu_old_desig_type directly, in which case it will not be
3909 a dummy type any more when we get into update_pointer_to.
3911 This can happen e.g. when the designated type is a record type,
3912 because their elaboration starts with an initial node from
3913 make_dummy_type, which may be the same node as the one we got.
3915 Besides, variants of this non-dummy type might have been created
3916 along the way. update_pointer_to is expected to properly take
3917 care of those situations. */
3918 if (defer_incomplete_level
== 0 && !is_from_limited_with
)
3920 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type
),
3921 gnat_to_gnu_type (gnat_desig_equiv
));
3925 struct incomplete
*p
= XNEW (struct incomplete
);
3926 struct incomplete
**head
3927 = (is_from_limited_with
3928 ? &defer_limited_with
: &defer_incomplete_list
);
3929 p
->old_type
= gnu_old_desig_type
;
3930 p
->full_type
= gnat_desig_equiv
;
3938 case E_Access_Protected_Subprogram_Type
:
3939 case E_Anonymous_Access_Protected_Subprogram_Type
:
3940 if (type_annotate_only
&& No (gnat_equiv_type
))
3941 gnu_type
= ptr_void_type_node
;
3944 /* The run-time representation is the equivalent type. */
3945 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
3946 maybe_present
= true;
3949 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3950 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3951 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
)))
3952 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity
))))
3953 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3958 case E_Access_Subtype
:
3960 /* We treat this as identical to its base type; any constraint is
3961 meaningful only to the front-end.
3963 The designated type must be elaborated as well, if it does
3964 not have its own freeze node. Designated (sub)types created
3965 for constrained components of records with discriminants are
3966 not frozen by the front-end and thus not elaborated by gigi,
3967 because their use may appear before the base type is frozen,
3968 and because it is not clear that they are needed anywhere in
3969 gigi. With the current model, there is no correct place where
3970 they could be elaborated. */
3972 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3973 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3974 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3975 && Is_Frozen (Directly_Designated_Type (gnat_entity
))
3976 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
))))
3978 /* If we are not defining this entity, and we have incomplete
3979 entities being processed above us, make a dummy type and
3980 elaborate it later. */
3981 if (!definition
&& defer_incomplete_level
!= 0)
3983 struct incomplete
*p
= XNEW (struct incomplete
);
3986 = make_dummy_type (Directly_Designated_Type (gnat_entity
));
3987 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3988 p
->next
= defer_incomplete_list
;
3989 defer_incomplete_list
= p
;
3991 else if (!IN (Ekind (Base_Type
3992 (Directly_Designated_Type (gnat_entity
))),
3993 Incomplete_Or_Private_Kind
))
3994 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3998 maybe_present
= true;
4001 /* Subprogram Entities
4003 The following access functions are defined for subprograms:
4005 Etype Return type or Standard_Void_Type.
4006 First_Formal The first formal parameter.
4007 Is_Imported Indicates that the subprogram has appeared in
4008 an INTERFACE or IMPORT pragma. For now we
4009 assume that the external language is C.
4010 Is_Exported Likewise but for an EXPORT pragma.
4011 Is_Inlined True if the subprogram is to be inlined.
4013 Each parameter is first checked by calling must_pass_by_ref on its
4014 type to determine if it is passed by reference. For parameters which
4015 are copied in, if they are Ada In Out or Out parameters, their return
4016 value becomes part of a record which becomes the return type of the
4017 function (C function - note that this applies only to Ada procedures
4018 so there is no Ada return type). Additional code to store back the
4019 parameters will be generated on the caller side. This transformation
4020 is done here, not in the front-end.
4022 The intended result of the transformation can be seen from the
4023 equivalent source rewritings that follow:
4025 struct temp {int a,b};
4026 procedure P (A,B: In Out ...) is temp P (int A,B)
4029 end P; return {A,B};
4036 For subprogram types we need to perform mainly the same conversions to
4037 GCC form that are needed for procedures and function declarations. The
4038 only difference is that at the end, we make a type declaration instead
4039 of a function declaration. */
4041 case E_Subprogram_Type
:
4045 /* The type returned by a function or else Standard_Void_Type for a
4047 Entity_Id gnat_return_type
= Etype (gnat_entity
);
4048 tree gnu_return_type
;
4049 /* The first GCC parameter declaration (a PARM_DECL node). The
4050 PARM_DECL nodes are chained through the DECL_CHAIN field, so this
4051 actually is the head of this parameter list. */
4052 tree gnu_param_list
= NULL_TREE
;
4053 /* Likewise for the stub associated with an exported procedure. */
4054 tree gnu_stub_param_list
= NULL_TREE
;
4055 /* Non-null for subprograms containing parameters passed by copy-in
4056 copy-out (Ada In Out or Out parameters not passed by reference),
4057 in which case it is the list of nodes used to specify the values
4058 of the In Out/Out parameters that are returned as a record upon
4059 procedure return. The TREE_PURPOSE of an element of this list is
4060 a field of the record and the TREE_VALUE is the PARM_DECL
4061 corresponding to that field. This list will be saved in the
4062 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
4063 tree gnu_cico_list
= NULL_TREE
;
4064 /* List of fields in return type of procedure with copy-in copy-out
4066 tree gnu_field_list
= NULL_TREE
;
4067 /* If an import pragma asks to map this subprogram to a GCC builtin,
4068 this is the builtin DECL node. */
4069 tree gnu_builtin_decl
= NULL_TREE
;
4070 /* For the stub associated with an exported procedure. */
4071 tree gnu_stub_type
= NULL_TREE
, gnu_stub_name
= NULL_TREE
;
4072 tree gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
4073 Entity_Id gnat_param
;
4074 bool inline_flag
= Is_Inlined (gnat_entity
);
4075 bool public_flag
= Is_Public (gnat_entity
) || imported_p
;
4077 = (Is_Public (gnat_entity
) && !definition
) || imported_p
;
4078 bool artificial_flag
= !Comes_From_Source (gnat_entity
);
4079 /* The semantics of "pure" in Ada essentially matches that of "const"
4080 in the back-end. In particular, both properties are orthogonal to
4081 the "nothrow" property if the EH circuitry is explicit in the
4082 internal representation of the back-end. If we are to completely
4083 hide the EH circuitry from it, we need to declare that calls to pure
4084 Ada subprograms that can throw have side effects since they can
4085 trigger an "abnormal" transfer of control flow; thus they can be
4086 neither "const" nor "pure" in the back-end sense. */
4088 = (Exception_Mechanism
== Back_End_Exceptions
4089 && Is_Pure (gnat_entity
));
4090 bool volatile_flag
= No_Return (gnat_entity
);
4091 bool return_by_direct_ref_p
= false;
4092 bool return_by_invisi_ref_p
= false;
4093 bool return_unconstrained_p
= false;
4094 bool has_stub
= false;
4097 /* A parameter may refer to this type, so defer completion of any
4098 incomplete types. */
4099 if (kind
== E_Subprogram_Type
&& !definition
)
4101 defer_incomplete_level
++;
4102 this_deferred
= true;
4105 /* If the subprogram has an alias, it is probably inherited, so
4106 we can use the original one. If the original "subprogram"
4107 is actually an enumeration literal, it may be the first use
4108 of its type, so we must elaborate that type now. */
4109 if (Present (Alias (gnat_entity
)))
4111 if (Ekind (Alias (gnat_entity
)) == E_Enumeration_Literal
)
4112 gnat_to_gnu_entity (Etype (Alias (gnat_entity
)), NULL_TREE
, 0);
4114 gnu_decl
= gnat_to_gnu_entity (Alias (gnat_entity
), gnu_expr
, 0);
4116 /* Elaborate any Itypes in the parameters of this entity. */
4117 for (gnat_temp
= First_Formal_With_Extras (gnat_entity
);
4118 Present (gnat_temp
);
4119 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
4120 if (Is_Itype (Etype (gnat_temp
)))
4121 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
4126 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
4127 corresponding DECL node. Proper generation of calls later on need
4128 proper parameter associations so we don't "break;" here. */
4129 if (Convention (gnat_entity
) == Convention_Intrinsic
4130 && Present (Interface_Name (gnat_entity
)))
4132 gnu_builtin_decl
= builtin_decl_for (gnu_ext_name
);
4134 /* Inability to find the builtin decl most often indicates a
4135 genuine mistake, but imports of unregistered intrinsics are
4136 sometimes issued on purpose to allow hooking in alternate
4137 bodies. We post a warning conditioned on Wshadow in this case,
4138 to let developers be notified on demand without risking false
4139 positives with common default sets of options. */
4141 if (gnu_builtin_decl
== NULL_TREE
&& warn_shadow
)
4142 post_error ("?gcc intrinsic not found for&!", gnat_entity
);
4145 /* ??? What if we don't find the builtin node above ? warn ? err ?
4146 In the current state we neither warn nor err, and calls will just
4147 be handled as for regular subprograms. */
4149 /* Look into the return type and get its associated GCC tree. If it
4150 is not void, compute various flags for the subprogram type. */
4151 if (Ekind (gnat_return_type
) == E_Void
)
4152 gnu_return_type
= void_type_node
;
4155 /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
4156 context may now appear in parameter and result profiles. If
4157 we are only annotating types, break circularities here. */
4158 if (type_annotate_only
4159 && IN (Ekind (gnat_return_type
), Incomplete_Kind
)
4160 && From_With_Type (gnat_return_type
)
4161 && In_Extended_Main_Code_Unit
4162 (Non_Limited_View (gnat_return_type
))
4163 && !present_gnu_tree (Non_Limited_View (gnat_return_type
)))
4164 gnu_return_type
= ptr_void_type_node
;
4166 gnu_return_type
= gnat_to_gnu_type (gnat_return_type
);
4168 /* If this function returns by reference, make the actual return
4169 type the pointer type and make a note of that. */
4170 if (Returns_By_Ref (gnat_entity
))
4172 gnu_return_type
= build_pointer_type (gnu_return_type
);
4173 return_by_direct_ref_p
= true;
4176 /* If we are supposed to return an unconstrained array type, make
4177 the actual return type the fat pointer type. */
4178 else if (TREE_CODE (gnu_return_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4180 gnu_return_type
= TREE_TYPE (gnu_return_type
);
4181 return_unconstrained_p
= true;
4184 /* Likewise, if the return type requires a transient scope, the
4185 return value will be allocated on the secondary stack so the
4186 actual return type is the pointer type. */
4187 else if (Requires_Transient_Scope (gnat_return_type
))
4189 gnu_return_type
= build_pointer_type (gnu_return_type
);
4190 return_unconstrained_p
= true;
4193 /* If the Mechanism is By_Reference, ensure this function uses the
4194 target's by-invisible-reference mechanism, which may not be the
4195 same as above (e.g. it might be passing an extra parameter). */
4196 else if (kind
== E_Function
4197 && Mechanism (gnat_entity
) == By_Reference
)
4198 return_by_invisi_ref_p
= true;
4200 /* Likewise, if the return type is itself By_Reference. */
4201 else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type
))
4202 return_by_invisi_ref_p
= true;
4204 /* If the type is a padded type and the underlying type would not
4205 be passed by reference or the function has a foreign convention,
4206 return the underlying type. */
4207 else if (TYPE_IS_PADDING_P (gnu_return_type
)
4208 && (!default_pass_by_ref
4209 (TREE_TYPE (TYPE_FIELDS (gnu_return_type
)))
4210 || Has_Foreign_Convention (gnat_entity
)))
4211 gnu_return_type
= TREE_TYPE (TYPE_FIELDS (gnu_return_type
));
4213 /* If the return type is unconstrained, that means it must have a
4214 maximum size. Use the padded type as the effective return type.
4215 And ensure the function uses the target's by-invisible-reference
4216 mechanism to avoid copying too much data when it returns. */
4217 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type
)))
4219 tree orig_type
= gnu_return_type
;
4222 = maybe_pad_type (gnu_return_type
,
4223 max_size (TYPE_SIZE (gnu_return_type
),
4225 0, gnat_entity
, false, false, false, true);
4227 /* Declare it now since it will never be declared otherwise.
4228 This is necessary to ensure that its subtrees are properly
4230 if (gnu_return_type
!= orig_type
4231 && !DECL_P (TYPE_NAME (gnu_return_type
)))
4232 create_type_decl (TYPE_NAME (gnu_return_type
),
4233 gnu_return_type
, NULL
, true,
4234 debug_info_p
, gnat_entity
);
4236 return_by_invisi_ref_p
= true;
4239 /* If the return type has a size that overflows, we cannot have
4240 a function that returns that type. This usage doesn't make
4241 sense anyway, so give an error here. */
4242 if (TYPE_SIZE_UNIT (gnu_return_type
)
4243 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type
))
4244 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type
)))
4246 post_error ("cannot return type whose size overflows",
4248 gnu_return_type
= copy_node (gnu_return_type
);
4249 TYPE_SIZE (gnu_return_type
) = bitsize_zero_node
;
4250 TYPE_SIZE_UNIT (gnu_return_type
) = size_zero_node
;
4251 TYPE_MAIN_VARIANT (gnu_return_type
) = gnu_return_type
;
4252 TYPE_NEXT_VARIANT (gnu_return_type
) = NULL_TREE
;
4256 /* Loop over the parameters and get their associated GCC tree. While
4257 doing this, build a copy-in copy-out structure if we need one. */
4258 for (gnat_param
= First_Formal_With_Extras (gnat_entity
), parmnum
= 0;
4259 Present (gnat_param
);
4260 gnat_param
= Next_Formal_With_Extras (gnat_param
), parmnum
++)
4262 Entity_Id gnat_param_type
= Etype (gnat_param
);
4263 tree gnu_param_name
= get_entity_name (gnat_param
);
4264 tree gnu_param_type
, gnu_param
, gnu_field
;
4265 Mechanism_Type mech
= Mechanism (gnat_param
);
4266 bool copy_in_copy_out
= false, fake_param_type
;
4268 /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
4269 context may now appear in parameter and result profiles. If
4270 we are only annotating types, break circularities here. */
4271 if (type_annotate_only
4272 && IN (Ekind (gnat_param_type
), Incomplete_Kind
)
4273 && From_With_Type (Etype (gnat_param_type
))
4274 && In_Extended_Main_Code_Unit
4275 (Non_Limited_View (gnat_param_type
))
4276 && !present_gnu_tree (Non_Limited_View (gnat_param_type
)))
4278 gnu_param_type
= ptr_void_type_node
;
4279 fake_param_type
= true;
4283 gnu_param_type
= gnat_to_gnu_type (gnat_param_type
);
4284 fake_param_type
= false;
4287 /* Builtins are expanded inline and there is no real call sequence
4288 involved. So the type expected by the underlying expander is
4289 always the type of each argument "as is". */
4290 if (gnu_builtin_decl
)
4292 /* Handle the first parameter of a valued procedure specially. */
4293 else if (Is_Valued_Procedure (gnat_entity
) && parmnum
== 0)
4294 mech
= By_Copy_Return
;
4295 /* Otherwise, see if a Mechanism was supplied that forced this
4296 parameter to be passed one way or another. */
4297 else if (mech
== Default
4298 || mech
== By_Copy
|| mech
== By_Reference
)
4300 else if (By_Descriptor_Last
<= mech
&& mech
<= By_Descriptor
)
4301 mech
= By_Descriptor
;
4303 else if (By_Short_Descriptor_Last
<= mech
&&
4304 mech
<= By_Short_Descriptor
)
4305 mech
= By_Short_Descriptor
;
4309 if (TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
4310 || TREE_CODE (TYPE_SIZE (gnu_param_type
)) != INTEGER_CST
4311 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type
),
4313 mech
= By_Reference
;
4319 post_error ("unsupported mechanism for&", gnat_param
);
4323 /* Do not call gnat_to_gnu_param for a fake parameter type since
4324 it will try to use the real type again. */
4325 if (fake_param_type
)
4327 if (Ekind (gnat_param
) == E_Out_Parameter
)
4328 gnu_param
= NULL_TREE
;
4332 = create_param_decl (gnu_param_name
, gnu_param_type
,
4334 Set_Mechanism (gnat_param
,
4335 mech
== Default
? By_Copy
: mech
);
4336 if (Ekind (gnat_param
) == E_In_Out_Parameter
)
4337 copy_in_copy_out
= true;
4342 = gnat_to_gnu_param (gnat_param
, mech
, gnat_entity
,
4343 Has_Foreign_Convention (gnat_entity
),
4346 /* We are returned either a PARM_DECL or a type if no parameter
4347 needs to be passed; in either case, adjust the type. */
4348 if (DECL_P (gnu_param
))
4349 gnu_param_type
= TREE_TYPE (gnu_param
);
4352 gnu_param_type
= gnu_param
;
4353 gnu_param
= NULL_TREE
;
4356 /* The failure of this assertion will very likely come from an
4357 order of elaboration issue for the type of the parameter. */
4358 gcc_assert (kind
== E_Subprogram_Type
4359 || !TYPE_IS_DUMMY_P (gnu_param_type
)
4360 || type_annotate_only
);
4364 /* If it's an exported subprogram, we build a parameter list
4365 in parallel, in case we need to emit a stub for it. */
4366 if (Is_Exported (gnat_entity
))
4369 = chainon (gnu_param
, gnu_stub_param_list
);
4370 /* Change By_Descriptor parameter to By_Reference for
4371 the internal version of an exported subprogram. */
4372 if (mech
== By_Descriptor
|| mech
== By_Short_Descriptor
)
4375 = gnat_to_gnu_param (gnat_param
, By_Reference
,
4381 gnu_param
= copy_node (gnu_param
);
4384 gnu_param_list
= chainon (gnu_param
, gnu_param_list
);
4385 Sloc_to_locus (Sloc (gnat_param
),
4386 &DECL_SOURCE_LOCATION (gnu_param
));
4387 save_gnu_tree (gnat_param
, gnu_param
, false);
4389 /* If a parameter is a pointer, this function may modify
4390 memory through it and thus shouldn't be considered
4391 a const function. Also, the memory may be modified
4392 between two calls, so they can't be CSE'ed. The latter
4393 case also handles by-ref parameters. */
4394 if (POINTER_TYPE_P (gnu_param_type
)
4395 || TYPE_IS_FAT_POINTER_P (gnu_param_type
))
4399 if (copy_in_copy_out
)
4403 tree gnu_new_ret_type
= make_node (RECORD_TYPE
);
4405 /* If this is a function, we also need a field for the
4406 return value to be placed. */
4407 if (TREE_CODE (gnu_return_type
) != VOID_TYPE
)
4410 = create_field_decl (get_identifier ("RETVAL"),
4412 gnu_new_ret_type
, NULL_TREE
,
4414 Sloc_to_locus (Sloc (gnat_entity
),
4415 &DECL_SOURCE_LOCATION (gnu_field
));
4416 gnu_field_list
= gnu_field
;
4418 = tree_cons (gnu_field
, void_type_node
, NULL_TREE
);
4421 gnu_return_type
= gnu_new_ret_type
;
4422 TYPE_NAME (gnu_return_type
) = get_identifier ("RETURN");
4423 /* Set a default alignment to speed up accesses. But we
4424 shouldn't increase the size of the structure too much,
4425 lest it doesn't fit in return registers anymore. */
4426 TYPE_ALIGN (gnu_return_type
)
4427 = get_mode_alignment (ptr_mode
);
4431 = create_field_decl (gnu_param_name
, gnu_param_type
,
4432 gnu_return_type
, NULL_TREE
, NULL_TREE
,
4434 Sloc_to_locus (Sloc (gnat_param
),
4435 &DECL_SOURCE_LOCATION (gnu_field
));
4436 DECL_CHAIN (gnu_field
) = gnu_field_list
;
4437 gnu_field_list
= gnu_field
;
4439 = tree_cons (gnu_field
, gnu_param
, gnu_cico_list
);
4445 /* If we have a CICO list but it has only one entry, we convert
4446 this function into a function that returns this object. */
4447 if (list_length (gnu_cico_list
) == 1)
4448 gnu_return_type
= TREE_TYPE (TREE_PURPOSE (gnu_cico_list
));
4450 /* Do not finalize the return type if the subprogram is stubbed
4451 since structures are incomplete for the back-end. */
4452 else if (Convention (gnat_entity
) != Convention_Stubbed
)
4454 finish_record_type (gnu_return_type
, nreverse (gnu_field_list
),
4457 /* Try to promote the mode of the return type if it is passed
4458 in registers, again to speed up accesses. */
4459 if (TYPE_MODE (gnu_return_type
) == BLKmode
4460 && !targetm
.calls
.return_in_memory (gnu_return_type
,
4464 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type
));
4465 unsigned int i
= BITS_PER_UNIT
;
4466 enum machine_mode mode
;
4470 mode
= mode_for_size (i
, MODE_INT
, 0);
4471 if (mode
!= BLKmode
)
4473 SET_TYPE_MODE (gnu_return_type
, mode
);
4474 TYPE_ALIGN (gnu_return_type
)
4475 = GET_MODE_ALIGNMENT (mode
);
4476 TYPE_SIZE (gnu_return_type
)
4477 = bitsize_int (GET_MODE_BITSIZE (mode
));
4478 TYPE_SIZE_UNIT (gnu_return_type
)
4479 = size_int (GET_MODE_SIZE (mode
));
4484 rest_of_record_type_compilation (gnu_return_type
);
4488 if (Has_Stdcall_Convention (gnat_entity
))
4489 prepend_one_attribute_to
4490 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4491 get_identifier ("stdcall"), NULL_TREE
,
4493 else if (Has_Thiscall_Convention (gnat_entity
))
4494 prepend_one_attribute_to
4495 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4496 get_identifier ("thiscall"), NULL_TREE
,
4499 /* If we should request stack realignment for a foreign convention
4500 subprogram, do so. Note that this applies to task entry points in
4502 if (FOREIGN_FORCE_REALIGN_STACK
4503 && Has_Foreign_Convention (gnat_entity
))
4504 prepend_one_attribute_to
4505 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4506 get_identifier ("force_align_arg_pointer"), NULL_TREE
,
4509 /* The lists have been built in reverse. */
4510 gnu_param_list
= nreverse (gnu_param_list
);
4512 gnu_stub_param_list
= nreverse (gnu_stub_param_list
);
4513 gnu_cico_list
= nreverse (gnu_cico_list
);
4515 if (kind
== E_Function
)
4516 Set_Mechanism (gnat_entity
, return_unconstrained_p
4517 || return_by_direct_ref_p
4518 || return_by_invisi_ref_p
4519 ? By_Reference
: By_Copy
);
4521 = create_subprog_type (gnu_return_type
, gnu_param_list
,
4522 gnu_cico_list
, return_unconstrained_p
,
4523 return_by_direct_ref_p
,
4524 return_by_invisi_ref_p
);
4528 = create_subprog_type (gnu_return_type
, gnu_stub_param_list
,
4529 gnu_cico_list
, return_unconstrained_p
,
4530 return_by_direct_ref_p
,
4531 return_by_invisi_ref_p
);
4533 /* A subprogram (something that doesn't return anything) shouldn't
4534 be considered const since there would be no reason for such a
4535 subprogram. Note that procedures with Out (or In Out) parameters
4536 have already been converted into a function with a return type. */
4537 if (TREE_CODE (gnu_return_type
) == VOID_TYPE
)
4541 = build_qualified_type (gnu_type
,
4542 TYPE_QUALS (gnu_type
)
4543 | (TYPE_QUAL_CONST
* const_flag
)
4544 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
4548 = build_qualified_type (gnu_stub_type
,
4549 TYPE_QUALS (gnu_stub_type
)
4550 | (TYPE_QUAL_CONST
* const_flag
)
4551 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
4553 /* If we have a builtin decl for that function, use it. Check if the
4554 profiles are compatible and warn if they are not. The checker is
4555 expected to post extra diagnostics in this case. */
4556 if (gnu_builtin_decl
)
4558 intrin_binding_t inb
;
4560 inb
.gnat_entity
= gnat_entity
;
4561 inb
.ada_fntype
= gnu_type
;
4562 inb
.btin_fntype
= TREE_TYPE (gnu_builtin_decl
);
4564 if (!intrin_profiles_compatible_p (&inb
))
4566 ("?profile of& doesn''t match the builtin it binds!",
4569 gnu_decl
= gnu_builtin_decl
;
4570 gnu_type
= TREE_TYPE (gnu_builtin_decl
);
4574 /* If there was no specified Interface_Name and the external and
4575 internal names of the subprogram are the same, only use the
4576 internal name to allow disambiguation of nested subprograms. */
4577 if (No (Interface_Name (gnat_entity
))
4578 && gnu_ext_name
== gnu_entity_name
)
4579 gnu_ext_name
= NULL_TREE
;
4581 /* If we are defining the subprogram and it has an Address clause
4582 we must get the address expression from the saved GCC tree for the
4583 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4584 the address expression here since the front-end has guaranteed
4585 in that case that the elaboration has no effects. If there is
4586 an Address clause and we are not defining the object, just
4587 make it a constant. */
4588 if (Present (Address_Clause (gnat_entity
)))
4590 tree gnu_address
= NULL_TREE
;
4594 = (present_gnu_tree (gnat_entity
)
4595 ? get_gnu_tree (gnat_entity
)
4596 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
4598 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
4600 /* Convert the type of the object to a reference type that can
4601 alias everything as per 13.3(19). */
4603 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
4605 gnu_address
= convert (gnu_type
, gnu_address
);
4608 = create_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
4609 gnu_address
, false, Is_Public (gnat_entity
),
4610 extern_flag
, false, NULL
, gnat_entity
);
4611 DECL_BY_REF_P (gnu_decl
) = 1;
4614 else if (kind
== E_Subprogram_Type
)
4616 = create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
4617 artificial_flag
, debug_info_p
, gnat_entity
);
4622 gnu_stub_name
= gnu_ext_name
;
4623 gnu_ext_name
= create_concat_name (gnat_entity
, "internal");
4624 public_flag
= false;
4625 artificial_flag
= true;
4629 = create_subprog_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
4630 gnu_param_list
, inline_flag
, public_flag
,
4631 extern_flag
, artificial_flag
, attr_list
,
4636 = create_subprog_decl (gnu_entity_name
, gnu_stub_name
,
4637 gnu_stub_type
, gnu_stub_param_list
,
4638 inline_flag
, true, extern_flag
,
4639 false, attr_list
, gnat_entity
);
4640 SET_DECL_FUNCTION_STUB (gnu_decl
, gnu_stub_decl
);
4643 /* This is unrelated to the stub built right above. */
4644 DECL_STUBBED_P (gnu_decl
)
4645 = Convention (gnat_entity
) == Convention_Stubbed
;
4650 case E_Incomplete_Type
:
4651 case E_Incomplete_Subtype
:
4652 case E_Private_Type
:
4653 case E_Private_Subtype
:
4654 case E_Limited_Private_Type
:
4655 case E_Limited_Private_Subtype
:
4656 case E_Record_Type_With_Private
:
4657 case E_Record_Subtype_With_Private
:
4659 /* Get the "full view" of this entity. If this is an incomplete
4660 entity from a limited with, treat its non-limited view as the
4661 full view. Otherwise, use either the full view or the underlying
4662 full view, whichever is present. This is used in all the tests
4665 = (IN (kind
, Incomplete_Kind
) && From_With_Type (gnat_entity
))
4666 ? Non_Limited_View (gnat_entity
)
4667 : Present (Full_View (gnat_entity
))
4668 ? Full_View (gnat_entity
)
4669 : Underlying_Full_View (gnat_entity
);
4671 /* If this is an incomplete type with no full view, it must be a Taft
4672 Amendment type, in which case we return a dummy type. Otherwise,
4673 just get the type from its Etype. */
4676 if (kind
== E_Incomplete_Type
)
4678 gnu_type
= make_dummy_type (gnat_entity
);
4679 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4683 gnu_decl
= gnat_to_gnu_entity (Etype (gnat_entity
),
4685 maybe_present
= true;
4690 /* If we already made a type for the full view, reuse it. */
4691 else if (present_gnu_tree (full_view
))
4693 gnu_decl
= get_gnu_tree (full_view
);
4697 /* Otherwise, if we are not defining the type now, get the type
4698 from the full view. But always get the type from the full view
4699 for define on use types, since otherwise we won't see them! */
4700 else if (!definition
4701 || (Is_Itype (full_view
)
4702 && No (Freeze_Node (gnat_entity
)))
4703 || (Is_Itype (gnat_entity
)
4704 && No (Freeze_Node (full_view
))))
4706 gnu_decl
= gnat_to_gnu_entity (full_view
, NULL_TREE
, 0);
4707 maybe_present
= true;
4711 /* For incomplete types, make a dummy type entry which will be
4712 replaced later. Save it as the full declaration's type so
4713 we can do any needed updates when we see it. */
4714 gnu_type
= make_dummy_type (gnat_entity
);
4715 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4716 if (Has_Completion_In_Body (gnat_entity
))
4717 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
4718 save_gnu_tree (full_view
, gnu_decl
, 0);
4722 case E_Class_Wide_Type
:
4723 /* Class-wide types are always transformed into their root type. */
4724 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
4725 maybe_present
= true;
4729 case E_Task_Subtype
:
4730 case E_Protected_Type
:
4731 case E_Protected_Subtype
:
4732 /* Concurrent types are always transformed into their record type. */
4733 if (type_annotate_only
&& No (gnat_equiv_type
))
4734 gnu_type
= void_type_node
;
4736 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
4737 maybe_present
= true;
4741 gnu_decl
= create_label_decl (gnu_entity_name
, gnat_entity
);
4746 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4747 we've already saved it, so we don't try to. */
4748 gnu_decl
= error_mark_node
;
4756 /* If we had a case where we evaluated another type and it might have
4757 defined this one, handle it here. */
4758 if (maybe_present
&& present_gnu_tree (gnat_entity
))
4760 gnu_decl
= get_gnu_tree (gnat_entity
);
4764 /* If we are processing a type and there is either no decl for it or
4765 we just made one, do some common processing for the type, such as
4766 handling alignment and possible padding. */
4767 if (is_type
&& (!gnu_decl
|| this_made_decl
))
4769 /* Tell the middle-end that objects of tagged types are guaranteed to
4770 be properly aligned. This is necessary because conversions to the
4771 class-wide type are translated into conversions to the root type,
4772 which can be less aligned than some of its derived types. */
4773 if (Is_Tagged_Type (gnat_entity
)
4774 || Is_Class_Wide_Equivalent_Type (gnat_entity
))
4775 TYPE_ALIGN_OK (gnu_type
) = 1;
4777 /* Record whether the type is passed by reference. */
4778 if (!VOID_TYPE_P (gnu_type
) && Is_By_Reference_Type (gnat_entity
))
4779 TYPE_BY_REFERENCE_P (gnu_type
) = 1;
4781 /* ??? Don't set the size for a String_Literal since it is either
4782 confirming or we don't handle it properly (if the low bound is
4784 if (!gnu_size
&& kind
!= E_String_Literal_Subtype
)
4786 Uint gnat_size
= Known_Esize (gnat_entity
)
4787 ? Esize (gnat_entity
) : RM_Size (gnat_entity
);
4789 = validate_size (gnat_size
, gnu_type
, gnat_entity
, TYPE_DECL
,
4790 false, Has_Size_Clause (gnat_entity
));
4793 /* If a size was specified, see if we can make a new type of that size
4794 by rearranging the type, for example from a fat to a thin pointer. */
4798 = make_type_from_size (gnu_type
, gnu_size
,
4799 Has_Biased_Representation (gnat_entity
));
4801 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0)
4802 && operand_equal_p (rm_size (gnu_type
), gnu_size
, 0))
4803 gnu_size
= NULL_TREE
;
4806 /* If the alignment hasn't already been processed and this is
4807 not an unconstrained array, see if an alignment is specified.
4808 If not, we pick a default alignment for atomic objects. */
4809 if (align
!= 0 || TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4811 else if (Known_Alignment (gnat_entity
))
4813 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
4814 TYPE_ALIGN (gnu_type
));
4816 /* Warn on suspiciously large alignments. This should catch
4817 errors about the (alignment,byte)/(size,bit) discrepancy. */
4818 if (align
> BIGGEST_ALIGNMENT
&& Has_Alignment_Clause (gnat_entity
))
4822 /* If a size was specified, take it into account. Otherwise
4823 use the RM size for records or unions as the type size has
4824 already been adjusted to the alignment. */
4827 else if (RECORD_OR_UNION_TYPE_P (gnu_type
)
4828 && !TYPE_FAT_POINTER_P (gnu_type
))
4829 size
= rm_size (gnu_type
);
4831 size
= TYPE_SIZE (gnu_type
);
4833 /* Consider an alignment as suspicious if the alignment/size
4834 ratio is greater or equal to the byte/bit ratio. */
4835 if (host_integerp (size
, 1)
4836 && align
>= TREE_INT_CST_LOW (size
) * BITS_PER_UNIT
)
4837 post_error_ne ("?suspiciously large alignment specified for&",
4838 Expression (Alignment_Clause (gnat_entity
)),
4842 else if (Is_Atomic (gnat_entity
) && !gnu_size
4843 && host_integerp (TYPE_SIZE (gnu_type
), 1)
4844 && integer_pow2p (TYPE_SIZE (gnu_type
)))
4845 align
= MIN (BIGGEST_ALIGNMENT
,
4846 tree_low_cst (TYPE_SIZE (gnu_type
), 1));
4847 else if (Is_Atomic (gnat_entity
) && gnu_size
4848 && host_integerp (gnu_size
, 1)
4849 && integer_pow2p (gnu_size
))
4850 align
= MIN (BIGGEST_ALIGNMENT
, tree_low_cst (gnu_size
, 1));
4852 /* See if we need to pad the type. If we did, and made a record,
4853 the name of the new type may be changed. So get it back for
4854 us when we make the new TYPE_DECL below. */
4855 if (gnu_size
|| align
> 0)
4856 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
4857 false, !gnu_decl
, definition
, false);
4859 if (TYPE_IS_PADDING_P (gnu_type
))
4861 gnu_entity_name
= TYPE_NAME (gnu_type
);
4862 if (TREE_CODE (gnu_entity_name
) == TYPE_DECL
)
4863 gnu_entity_name
= DECL_NAME (gnu_entity_name
);
4866 /* Now set the RM size of the type. We cannot do it before padding
4867 because we need to accept arbitrary RM sizes on integral types. */
4868 set_rm_size (RM_Size (gnat_entity
), gnu_type
, gnat_entity
);
4870 /* If we are at global level, GCC will have applied variable_size to
4871 the type, but that won't have done anything. So, if it's not
4872 a constant or self-referential, call elaborate_expression_1 to
4873 make a variable for the size rather than calculating it each time.
4874 Handle both the RM size and the actual size. */
4875 if (global_bindings_p ()
4876 && TYPE_SIZE (gnu_type
)
4877 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
))
4878 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
4880 tree size
= TYPE_SIZE (gnu_type
);
4882 TYPE_SIZE (gnu_type
)
4883 = elaborate_expression_1 (size
, gnat_entity
,
4884 get_identifier ("SIZE"),
4887 /* ??? For now, store the size as a multiple of the alignment in
4888 bytes so that we can see the alignment from the tree. */
4889 TYPE_SIZE_UNIT (gnu_type
)
4890 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type
), gnat_entity
,
4891 get_identifier ("SIZE_A_UNIT"),
4893 TYPE_ALIGN (gnu_type
));
4895 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4896 may not be marked by the call to create_type_decl below. */
4897 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type
));
4899 if (TREE_CODE (gnu_type
) == RECORD_TYPE
)
4901 tree variant_part
= get_variant_part (gnu_type
);
4902 tree ada_size
= TYPE_ADA_SIZE (gnu_type
);
4906 tree union_type
= TREE_TYPE (variant_part
);
4907 tree offset
= DECL_FIELD_OFFSET (variant_part
);
4909 /* If the position of the variant part is constant, subtract
4910 it from the size of the type of the parent to get the new
4911 size. This manual CSE reduces the data size. */
4912 if (TREE_CODE (offset
) == INTEGER_CST
)
4914 tree bitpos
= DECL_FIELD_BIT_OFFSET (variant_part
);
4915 TYPE_SIZE (union_type
)
4916 = size_binop (MINUS_EXPR
, TYPE_SIZE (gnu_type
),
4917 bit_from_pos (offset
, bitpos
));
4918 TYPE_SIZE_UNIT (union_type
)
4919 = size_binop (MINUS_EXPR
, TYPE_SIZE_UNIT (gnu_type
),
4920 byte_from_pos (offset
, bitpos
));
4924 TYPE_SIZE (union_type
)
4925 = elaborate_expression_1 (TYPE_SIZE (union_type
),
4927 get_identifier ("VSIZE"),
4930 /* ??? For now, store the size as a multiple of the
4931 alignment in bytes so that we can see the alignment
4933 TYPE_SIZE_UNIT (union_type
)
4934 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type
),
4939 TYPE_ALIGN (union_type
));
4941 /* ??? For now, store the offset as a multiple of the
4942 alignment in bytes so that we can see the alignment
4944 DECL_FIELD_OFFSET (variant_part
)
4945 = elaborate_expression_2 (offset
,
4947 get_identifier ("VOFFSET"),
4953 DECL_SIZE (variant_part
) = TYPE_SIZE (union_type
);
4954 DECL_SIZE_UNIT (variant_part
) = TYPE_SIZE_UNIT (union_type
);
4957 if (operand_equal_p (ada_size
, size
, 0))
4958 ada_size
= TYPE_SIZE (gnu_type
);
4961 = elaborate_expression_1 (ada_size
, gnat_entity
,
4962 get_identifier ("RM_SIZE"),
4964 SET_TYPE_ADA_SIZE (gnu_type
, ada_size
);
4968 /* If this is a record type or subtype, call elaborate_expression_1 on
4969 any field position. Do this for both global and local types.
4970 Skip any fields that we haven't made trees for to avoid problems with
4971 class wide types. */
4972 if (IN (kind
, Record_Kind
))
4973 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
4974 gnat_temp
= Next_Entity (gnat_temp
))
4975 if (Ekind (gnat_temp
) == E_Component
&& present_gnu_tree (gnat_temp
))
4977 tree gnu_field
= get_gnu_tree (gnat_temp
);
4979 /* ??? For now, store the offset as a multiple of the alignment
4980 in bytes so that we can see the alignment from the tree. */
4981 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field
)))
4983 DECL_FIELD_OFFSET (gnu_field
)
4984 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field
),
4986 get_identifier ("OFFSET"),
4988 DECL_OFFSET_ALIGN (gnu_field
));
4990 /* ??? The context of gnu_field is not necessarily gnu_type
4991 so the MULT_EXPR node built above may not be marked by
4992 the call to create_type_decl below. */
4993 if (global_bindings_p ())
4994 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field
));
4998 if (Treat_As_Volatile (gnat_entity
))
5000 = build_qualified_type (gnu_type
,
5001 TYPE_QUALS (gnu_type
) | TYPE_QUAL_VOLATILE
);
5003 if (Is_Atomic (gnat_entity
))
5004 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
5006 if (Present (Alignment_Clause (gnat_entity
)))
5007 TYPE_USER_ALIGN (gnu_type
) = 1;
5009 if (Universal_Aliasing (gnat_entity
))
5010 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type
)) = 1;
5013 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
, attr_list
,
5014 !Comes_From_Source (gnat_entity
),
5015 debug_info_p
, gnat_entity
);
5018 TREE_TYPE (gnu_decl
) = gnu_type
;
5019 TYPE_STUB_DECL (gnu_type
) = gnu_decl
;
5023 if (is_type
&& !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
)))
5025 gnu_type
= TREE_TYPE (gnu_decl
);
5027 /* If this is a derived type, relate its alias set to that of its parent
5028 to avoid troubles when a call to an inherited primitive is inlined in
5029 a context where a derived object is accessed. The inlined code works
5030 on the parent view so the resulting code may access the same object
5031 using both the parent and the derived alias sets, which thus have to
5032 conflict. As the same issue arises with component references, the
5033 parent alias set also has to conflict with composite types enclosing
5034 derived components. For instance, if we have:
5041 we want T to conflict with both D and R, in addition to R being a
5042 superset of D by record/component construction.
5044 One way to achieve this is to perform an alias set copy from the
5045 parent to the derived type. This is not quite appropriate, though,
5046 as we don't want separate derived types to conflict with each other:
5048 type I1 is new Integer;
5049 type I2 is new Integer;
5051 We want I1 and I2 to both conflict with Integer but we do not want
5052 I1 to conflict with I2, and an alias set copy on derivation would
5055 The option chosen is to make the alias set of the derived type a
5056 superset of that of its parent type. It trivially fulfills the
5057 simple requirement for the Integer derivation example above, and
5058 the component case as well by superset transitivity:
5061 R ----------> D ----------> T
5063 However, for composite types, conversions between derived types are
5064 translated into VIEW_CONVERT_EXPRs so a sequence like:
5066 type Comp1 is new Comp;
5067 type Comp2 is new Comp;
5068 procedure Proc (C : Comp1);
5076 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
5078 and gimplified into:
5085 i.e. generates code involving type punning. Therefore, Comp1 needs
5086 to conflict with Comp2 and an alias set copy is required.
5088 The language rules ensure the parent type is already frozen here. */
5089 if (Is_Derived_Type (gnat_entity
))
5091 tree gnu_parent_type
= gnat_to_gnu_type (Etype (gnat_entity
));
5092 relate_alias_sets (gnu_type
, gnu_parent_type
,
5093 Is_Composite_Type (gnat_entity
)
5094 ? ALIAS_SET_COPY
: ALIAS_SET_SUPERSET
);
5097 /* Back-annotate the Alignment of the type if not already in the
5098 tree. Likewise for sizes. */
5099 if (Unknown_Alignment (gnat_entity
))
5101 unsigned int double_align
, align
;
5102 bool is_capped_double
, align_clause
;
5104 /* If the default alignment of "double" or larger scalar types is
5105 specifically capped and this is not an array with an alignment
5106 clause on the component type, return the cap. */
5107 if ((double_align
= double_float_alignment
) > 0)
5109 = is_double_float_or_array (gnat_entity
, &align_clause
);
5110 else if ((double_align
= double_scalar_alignment
) > 0)
5112 = is_double_scalar_or_array (gnat_entity
, &align_clause
);
5114 is_capped_double
= align_clause
= false;
5116 if (is_capped_double
&& !align_clause
)
5117 align
= double_align
;
5119 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
5121 Set_Alignment (gnat_entity
, UI_From_Int (align
));
5124 if (Unknown_Esize (gnat_entity
) && TYPE_SIZE (gnu_type
))
5126 tree gnu_size
= TYPE_SIZE (gnu_type
);
5128 /* If the size is self-referential, annotate the maximum value. */
5129 if (CONTAINS_PLACEHOLDER_P (gnu_size
))
5130 gnu_size
= max_size (gnu_size
, true);
5132 /* If we are just annotating types and the type is tagged, the tag
5133 and the parent components are not generated by the front-end so
5134 sizes must be adjusted if there is no representation clause. */
5135 if (type_annotate_only
5136 && Is_Tagged_Type (gnat_entity
)
5137 && !VOID_TYPE_P (gnu_type
)
5138 && (!TYPE_FIELDS (gnu_type
)
5139 || integer_zerop (bit_position (TYPE_FIELDS (gnu_type
)))))
5141 tree pointer_size
= bitsize_int (POINTER_SIZE
), offset
;
5144 if (Is_Derived_Type (gnat_entity
))
5146 Entity_Id gnat_parent
= Etype (Base_Type (gnat_entity
));
5147 offset
= UI_To_gnu (Esize (gnat_parent
), bitsizetype
);
5148 Set_Alignment (gnat_entity
, Alignment (gnat_parent
));
5151 offset
= pointer_size
;
5153 if (TYPE_FIELDS (gnu_type
))
5155 = round_up (offset
, DECL_ALIGN (TYPE_FIELDS (gnu_type
)));
5157 gnu_size
= size_binop (PLUS_EXPR
, gnu_size
, offset
);
5158 gnu_size
= round_up (gnu_size
, POINTER_SIZE
);
5159 uint_size
= annotate_value (gnu_size
);
5160 Set_Esize (gnat_entity
, uint_size
);
5161 Set_RM_Size (gnat_entity
, uint_size
);
5164 Set_Esize (gnat_entity
, annotate_value (gnu_size
));
5167 if (Unknown_RM_Size (gnat_entity
) && rm_size (gnu_type
))
5168 Set_RM_Size (gnat_entity
, annotate_value (rm_size (gnu_type
)));
5171 /* If we really have a ..._DECL node, set a couple of flags on it. But we
5172 cannot do so if we are reusing the ..._DECL node made for an equivalent
5173 type or an alias or a renamed object as the predicates don't apply to it
5174 but to GNAT_ENTITY. */
5175 if (DECL_P (gnu_decl
)
5176 && !(is_type
&& gnat_equiv_type
!= gnat_entity
)
5177 && !Present (Alias (gnat_entity
))
5178 && !(Present (Renamed_Object (gnat_entity
)) && saved
))
5180 if (!Comes_From_Source (gnat_entity
))
5181 DECL_ARTIFICIAL (gnu_decl
) = 1;
5184 DECL_IGNORED_P (gnu_decl
) = 1;
5187 /* If we haven't already, associate the ..._DECL node that we just made with
5188 the input GNAT entity node. */
5190 save_gnu_tree (gnat_entity
, gnu_decl
, false);
5192 /* If this is an enumeration or floating-point type, we were not able to set
5193 the bounds since they refer to the type. These are always static. */
5194 if ((kind
== E_Enumeration_Type
&& Present (First_Literal (gnat_entity
)))
5195 || (kind
== E_Floating_Point_Type
&& !Vax_Float (gnat_entity
)))
5197 tree gnu_scalar_type
= gnu_type
;
5198 tree gnu_low_bound
, gnu_high_bound
;
5200 /* If this is a padded type, we need to use the underlying type. */
5201 if (TYPE_IS_PADDING_P (gnu_scalar_type
))
5202 gnu_scalar_type
= TREE_TYPE (TYPE_FIELDS (gnu_scalar_type
));
5204 /* If this is a floating point type and we haven't set a floating
5205 point type yet, use this in the evaluation of the bounds. */
5206 if (!longest_float_type_node
&& kind
== E_Floating_Point_Type
)
5207 longest_float_type_node
= gnu_scalar_type
;
5209 gnu_low_bound
= gnat_to_gnu (Type_Low_Bound (gnat_entity
));
5210 gnu_high_bound
= gnat_to_gnu (Type_High_Bound (gnat_entity
));
5212 if (kind
== E_Enumeration_Type
)
5214 /* Enumeration types have specific RM bounds. */
5215 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type
, gnu_low_bound
);
5216 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type
, gnu_high_bound
);
5220 /* Floating-point types don't have specific RM bounds. */
5221 TYPE_GCC_MIN_VALUE (gnu_scalar_type
) = gnu_low_bound
;
5222 TYPE_GCC_MAX_VALUE (gnu_scalar_type
) = gnu_high_bound
;
5226 /* If we deferred processing of incomplete types, re-enable it. If there
5227 were no other disables and we have deferred types to process, do so. */
5229 && --defer_incomplete_level
== 0
5230 && defer_incomplete_list
)
5232 struct incomplete
*p
, *next
;
5234 /* We are back to level 0 for the deferring of incomplete types.
5235 But processing these incomplete types below may itself require
5236 deferring, so preserve what we have and restart from scratch. */
5237 p
= defer_incomplete_list
;
5238 defer_incomplete_list
= NULL
;
5245 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5246 gnat_to_gnu_type (p
->full_type
));
5251 /* If we are not defining this type, see if it's on one of the lists of
5252 incomplete types. If so, handle the list entry now. */
5253 if (is_type
&& !definition
)
5255 struct incomplete
*p
;
5257 for (p
= defer_incomplete_list
; p
; p
= p
->next
)
5258 if (p
->old_type
&& p
->full_type
== gnat_entity
)
5260 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5261 TREE_TYPE (gnu_decl
));
5262 p
->old_type
= NULL_TREE
;
5265 for (p
= defer_limited_with
; p
; p
= p
->next
)
5266 if (p
->old_type
&& Non_Limited_View (p
->full_type
) == gnat_entity
)
5268 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5269 TREE_TYPE (gnu_decl
));
5270 p
->old_type
= NULL_TREE
;
5277 /* If this is a packed array type whose original array type is itself
5278 an Itype without freeze node, make sure the latter is processed. */
5279 if (Is_Packed_Array_Type (gnat_entity
)
5280 && Is_Itype (Original_Array_Type (gnat_entity
))
5281 && No (Freeze_Node (Original_Array_Type (gnat_entity
)))
5282 && !present_gnu_tree (Original_Array_Type (gnat_entity
)))
5283 gnat_to_gnu_entity (Original_Array_Type (gnat_entity
), NULL_TREE
, 0);
5288 /* Similar, but if the returned value is a COMPONENT_REF, return the
5292 gnat_to_gnu_field_decl (Entity_Id gnat_entity
)
5294 tree gnu_field
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
5296 if (TREE_CODE (gnu_field
) == COMPONENT_REF
)
5297 gnu_field
= TREE_OPERAND (gnu_field
, 1);
5302 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5303 the GCC type corresponding to that entity. */
5306 gnat_to_gnu_type (Entity_Id gnat_entity
)
5310 /* The back end never attempts to annotate generic types. */
5311 if (Is_Generic_Type (gnat_entity
) && type_annotate_only
)
5312 return void_type_node
;
5314 gnu_decl
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
5315 gcc_assert (TREE_CODE (gnu_decl
) == TYPE_DECL
);
5317 return TREE_TYPE (gnu_decl
);
5320 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5321 the unpadded version of the GCC type corresponding to that entity. */
5324 get_unpadded_type (Entity_Id gnat_entity
)
5326 tree type
= gnat_to_gnu_type (gnat_entity
);
5328 if (TYPE_IS_PADDING_P (type
))
5329 type
= TREE_TYPE (TYPE_FIELDS (type
));
5334 /* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
5335 type has been changed to that of the parameterless procedure, except if an
5336 alias is already present, in which case it is returned instead. */
5339 get_minimal_subprog_decl (Entity_Id gnat_entity
)
5341 tree gnu_entity_name
, gnu_ext_name
;
5342 struct attrib
*attr_list
= NULL
;
5344 /* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
5345 of the handling applied here. */
5347 while (Present (Alias (gnat_entity
)))
5349 gnat_entity
= Alias (gnat_entity
);
5350 if (present_gnu_tree (gnat_entity
))
5351 return get_gnu_tree (gnat_entity
);
5354 gnu_entity_name
= get_entity_name (gnat_entity
);
5355 gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
5357 if (Has_Stdcall_Convention (gnat_entity
))
5358 prepend_one_attribute_to (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
5359 get_identifier ("stdcall"), NULL_TREE
,
5361 else if (Has_Thiscall_Convention (gnat_entity
))
5362 prepend_one_attribute_to (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
5363 get_identifier ("thiscall"), NULL_TREE
,
5366 if (No (Interface_Name (gnat_entity
)) && gnu_ext_name
== gnu_entity_name
)
5367 gnu_ext_name
= NULL_TREE
;
5370 create_subprog_decl (gnu_entity_name
, gnu_ext_name
, void_ftype
, NULL_TREE
,
5371 false, true, true, true, attr_list
, gnat_entity
);
5374 /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
5375 a C++ imported method or equivalent.
5377 We use the predicate on 32-bit x86/Windows to find out whether we need to
5378 use the "thiscall" calling convention for GNAT_ENTITY. This convention is
5379 used for C++ methods (functions with METHOD_TYPE) by the back-end. */
5382 is_cplusplus_method (Entity_Id gnat_entity
)
5384 if (Convention (gnat_entity
) != Convention_CPP
)
5387 /* This is the main case: C++ method imported as a primitive operation. */
5388 if (Is_Dispatching_Operation (gnat_entity
))
5391 /* A thunk needs to be handled like its associated primitive operation. */
5392 if (Is_Subprogram (gnat_entity
) && Is_Thunk (gnat_entity
))
5395 /* C++ classes with no virtual functions can be imported as limited
5396 record types, but we need to return true for the constructors. */
5397 if (Is_Constructor (gnat_entity
))
5400 /* This is set on the E_Subprogram_Type built for a dispatching call. */
5401 if (Is_Dispatch_Table_Entity (gnat_entity
))
5407 /* Finalize the processing of From_With_Type incomplete types. */
5410 finalize_from_with_types (void)
5412 struct incomplete
*p
, *next
;
5414 p
= defer_limited_with
;
5415 defer_limited_with
= NULL
;
5422 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5423 gnat_to_gnu_type (p
->full_type
));
5428 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
5429 kind of type (such E_Task_Type) that has a different type which Gigi
5430 uses for its representation. If the type does not have a special type
5431 for its representation, return GNAT_ENTITY. If a type is supposed to
5432 exist, but does not, abort unless annotating types, in which case
5433 return Empty. If GNAT_ENTITY is Empty, return Empty. */
5436 Gigi_Equivalent_Type (Entity_Id gnat_entity
)
5438 Entity_Id gnat_equiv
= gnat_entity
;
5440 if (No (gnat_entity
))
5443 switch (Ekind (gnat_entity
))
5445 case E_Class_Wide_Subtype
:
5446 if (Present (Equivalent_Type (gnat_entity
)))
5447 gnat_equiv
= Equivalent_Type (gnat_entity
);
5450 case E_Access_Protected_Subprogram_Type
:
5451 case E_Anonymous_Access_Protected_Subprogram_Type
:
5452 gnat_equiv
= Equivalent_Type (gnat_entity
);
5455 case E_Class_Wide_Type
:
5456 gnat_equiv
= Root_Type (gnat_entity
);
5460 case E_Task_Subtype
:
5461 case E_Protected_Type
:
5462 case E_Protected_Subtype
:
5463 gnat_equiv
= Corresponding_Record_Type (gnat_entity
);
5470 gcc_assert (Present (gnat_equiv
) || type_annotate_only
);
5475 /* Return a GCC tree for a type corresponding to the component type of the
5476 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5477 is for an array being defined. DEBUG_INFO_P is true if we need to write
5478 debug information for other types that we may create in the process. */
5481 gnat_to_gnu_component_type (Entity_Id gnat_array
, bool definition
,
5484 const Entity_Id gnat_type
= Component_Type (gnat_array
);
5485 tree gnu_type
= gnat_to_gnu_type (gnat_type
);
5488 /* Try to get a smaller form of the component if needed. */
5489 if ((Is_Packed (gnat_array
)
5490 || Has_Component_Size_Clause (gnat_array
))
5491 && !Is_Bit_Packed_Array (gnat_array
)
5492 && !Has_Aliased_Components (gnat_array
)
5493 && !Strict_Alignment (gnat_type
)
5494 && RECORD_OR_UNION_TYPE_P (gnu_type
)
5495 && !TYPE_FAT_POINTER_P (gnu_type
)
5496 && host_integerp (TYPE_SIZE (gnu_type
), 1))
5497 gnu_type
= make_packable_type (gnu_type
, false);
5499 if (Has_Atomic_Components (gnat_array
))
5500 check_ok_for_atomic (gnu_type
, gnat_array
, true);
5502 /* Get and validate any specified Component_Size. */
5504 = validate_size (Component_Size (gnat_array
), gnu_type
, gnat_array
,
5505 Is_Bit_Packed_Array (gnat_array
) ? TYPE_DECL
: VAR_DECL
,
5506 true, Has_Component_Size_Clause (gnat_array
));
5508 /* If the array has aliased components and the component size can be zero,
5509 force at least unit size to ensure that the components have distinct
5512 && Has_Aliased_Components (gnat_array
)
5513 && (integer_zerop (TYPE_SIZE (gnu_type
))
5514 || (TREE_CODE (gnu_type
) == ARRAY_TYPE
5515 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
)))))
5517 = size_binop (MAX_EXPR
, TYPE_SIZE (gnu_type
), bitsize_unit_node
);
5519 /* If the component type is a RECORD_TYPE that has a self-referential size,
5520 then use the maximum size for the component size. */
5522 && TREE_CODE (gnu_type
) == RECORD_TYPE
5523 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
5524 gnu_comp_size
= max_size (TYPE_SIZE (gnu_type
), true);
5526 /* Honor the component size. This is not needed for bit-packed arrays. */
5527 if (gnu_comp_size
&& !Is_Bit_Packed_Array (gnat_array
))
5529 tree orig_type
= gnu_type
;
5530 unsigned int max_align
;
5532 /* If an alignment is specified, use it as a cap on the component type
5533 so that it can be honored for the whole type. But ignore it for the
5534 original type of packed array types. */
5535 if (No (Packed_Array_Type (gnat_array
)) && Known_Alignment (gnat_array
))
5536 max_align
= validate_alignment (Alignment (gnat_array
), gnat_array
, 0);
5540 gnu_type
= make_type_from_size (gnu_type
, gnu_comp_size
, false);
5541 if (max_align
> 0 && TYPE_ALIGN (gnu_type
) > max_align
)
5542 gnu_type
= orig_type
;
5544 orig_type
= gnu_type
;
5546 gnu_type
= maybe_pad_type (gnu_type
, gnu_comp_size
, 0, gnat_array
,
5547 true, false, definition
, true);
5549 /* If a padding record was made, declare it now since it will never be
5550 declared otherwise. This is necessary to ensure that its subtrees
5551 are properly marked. */
5552 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
5553 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, NULL
, true,
5554 debug_info_p
, gnat_array
);
5557 if (Has_Volatile_Components (gnat_array
))
5559 = build_qualified_type (gnu_type
,
5560 TYPE_QUALS (gnu_type
) | TYPE_QUAL_VOLATILE
);
5565 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5566 using MECH as its passing mechanism, to be placed in the parameter
5567 list built for GNAT_SUBPROG. Assume a foreign convention for the
5568 latter if FOREIGN is true. Also set CICO to true if the parameter
5569 must use the copy-in copy-out implementation mechanism.
5571 The returned tree is a PARM_DECL, except for those cases where no
5572 parameter needs to be actually passed to the subprogram; the type
5573 of this "shadow" parameter is then returned instead. */
5576 gnat_to_gnu_param (Entity_Id gnat_param
, Mechanism_Type mech
,
5577 Entity_Id gnat_subprog
, bool foreign
, bool *cico
)
5579 tree gnu_param_name
= get_entity_name (gnat_param
);
5580 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
5581 tree gnu_param_type_alt
= NULL_TREE
;
5582 bool in_param
= (Ekind (gnat_param
) == E_In_Parameter
);
5583 /* The parameter can be indirectly modified if its address is taken. */
5584 bool ro_param
= in_param
&& !Address_Taken (gnat_param
);
5585 bool by_return
= false, by_component_ptr
= false;
5586 bool by_ref
= false, by_double_ref
= false;
5589 /* Copy-return is used only for the first parameter of a valued procedure.
5590 It's a copy mechanism for which a parameter is never allocated. */
5591 if (mech
== By_Copy_Return
)
5593 gcc_assert (Ekind (gnat_param
) == E_Out_Parameter
);
5598 /* If this is either a foreign function or if the underlying type won't
5599 be passed by reference, strip off possible padding type. */
5600 if (TYPE_IS_PADDING_P (gnu_param_type
))
5602 tree unpadded_type
= TREE_TYPE (TYPE_FIELDS (gnu_param_type
));
5604 if (mech
== By_Reference
5606 || (!must_pass_by_ref (unpadded_type
)
5607 && (mech
== By_Copy
|| !default_pass_by_ref (unpadded_type
))))
5608 gnu_param_type
= unpadded_type
;
5611 /* If this is a read-only parameter, make a variant of the type that is
5612 read-only. ??? However, if this is an unconstrained array, that type
5613 can be very complex, so skip it for now. Likewise for any other
5614 self-referential type. */
5616 && TREE_CODE (gnu_param_type
) != UNCONSTRAINED_ARRAY_TYPE
5617 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type
)))
5618 gnu_param_type
= build_qualified_type (gnu_param_type
,
5619 (TYPE_QUALS (gnu_param_type
)
5620 | TYPE_QUAL_CONST
));
5622 /* For foreign conventions, pass arrays as pointers to the element type.
5623 First check for unconstrained array and get the underlying array. */
5624 if (foreign
&& TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5626 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type
))));
5628 /* For GCC builtins, pass Address integer types as (void *) */
5629 if (Convention (gnat_subprog
) == Convention_Intrinsic
5630 && Present (Interface_Name (gnat_subprog
))
5631 && Is_Descendent_Of_Address (Etype (gnat_param
)))
5632 gnu_param_type
= ptr_void_type_node
;
5634 /* VMS descriptors are themselves passed by reference. */
5635 if (mech
== By_Short_Descriptor
||
5636 (mech
== By_Descriptor
&& TARGET_ABI_OPEN_VMS
&& !flag_vms_malloc64
))
5638 = build_pointer_type (build_vms_descriptor32 (gnu_param_type
,
5639 Mechanism (gnat_param
),
5641 else if (mech
== By_Descriptor
)
5643 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5644 chosen in fill_vms_descriptor. */
5646 = build_pointer_type (build_vms_descriptor32 (gnu_param_type
,
5647 Mechanism (gnat_param
),
5650 = build_pointer_type (build_vms_descriptor (gnu_param_type
,
5651 Mechanism (gnat_param
),
5655 /* Arrays are passed as pointers to element type for foreign conventions. */
5658 && TREE_CODE (gnu_param_type
) == ARRAY_TYPE
)
5660 /* Strip off any multi-dimensional entries, then strip
5661 off the last array to get the component type. */
5662 while (TREE_CODE (TREE_TYPE (gnu_param_type
)) == ARRAY_TYPE
5663 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type
)))
5664 gnu_param_type
= TREE_TYPE (gnu_param_type
);
5666 by_component_ptr
= true;
5667 gnu_param_type
= TREE_TYPE (gnu_param_type
);
5670 gnu_param_type
= build_qualified_type (gnu_param_type
,
5671 (TYPE_QUALS (gnu_param_type
)
5672 | TYPE_QUAL_CONST
));
5674 gnu_param_type
= build_pointer_type (gnu_param_type
);
5677 /* Fat pointers are passed as thin pointers for foreign conventions. */
5678 else if (foreign
&& TYPE_IS_FAT_POINTER_P (gnu_param_type
))
5680 = make_type_from_size (gnu_param_type
, size_int (POINTER_SIZE
), 0);
5682 /* If we must pass or were requested to pass by reference, do so.
5683 If we were requested to pass by copy, do so.
5684 Otherwise, for foreign conventions, pass In Out or Out parameters
5685 or aggregates by reference. For COBOL and Fortran, pass all
5686 integer and FP types that way too. For Convention Ada, use
5687 the standard Ada default. */
5688 else if (must_pass_by_ref (gnu_param_type
)
5689 || mech
== By_Reference
5692 && (!in_param
|| AGGREGATE_TYPE_P (gnu_param_type
)))
5694 && (Convention (gnat_subprog
) == Convention_Fortran
5695 || Convention (gnat_subprog
) == Convention_COBOL
)
5696 && (INTEGRAL_TYPE_P (gnu_param_type
)
5697 || FLOAT_TYPE_P (gnu_param_type
)))
5699 && default_pass_by_ref (gnu_param_type
)))))
5701 /* We take advantage of 6.2(12) by considering that references built for
5702 parameters whose type isn't by-ref and for which the mechanism hasn't
5703 been forced to by-ref are restrict-qualified in the C sense. */
5705 = !TYPE_IS_BY_REFERENCE_P (gnu_param_type
) && mech
!= By_Reference
;
5706 gnu_param_type
= build_reference_type (gnu_param_type
);
5709 = build_qualified_type (gnu_param_type
, TYPE_QUAL_RESTRICT
);
5712 /* In some ABIs, e.g. SPARC 32-bit, fat pointer types are themselves
5713 passed by reference. Pass them by explicit reference, this will
5714 generate more debuggable code at -O0. */
5715 if (TYPE_IS_FAT_POINTER_P (gnu_param_type
)
5716 && targetm
.calls
.pass_by_reference (pack_cumulative_args (NULL
),
5717 TYPE_MODE (gnu_param_type
),
5721 gnu_param_type
= build_reference_type (gnu_param_type
);
5722 by_double_ref
= true;
5726 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5730 if (mech
== By_Copy
&& (by_ref
|| by_component_ptr
))
5731 post_error ("?cannot pass & by copy", gnat_param
);
5733 /* If this is an Out parameter that isn't passed by reference and isn't
5734 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5735 it will be a VAR_DECL created when we process the procedure, so just
5736 return its type. For the special parameter of a valued procedure,
5739 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5740 Out parameters with discriminants or implicit initial values to be
5741 handled like In Out parameters. These type are normally built as
5742 aggregates, hence passed by reference, except for some packed arrays
5743 which end up encoded in special integer types.
5745 The exception we need to make is then for packed arrays of records
5746 with discriminants or implicit initial values. We have no light/easy
5747 way to check for the latter case, so we merely check for packed arrays
5748 of records. This may lead to useless copy-in operations, but in very
5749 rare cases only, as these would be exceptions in a set of already
5750 exceptional situations. */
5751 if (Ekind (gnat_param
) == E_Out_Parameter
5754 || (mech
!= By_Descriptor
5755 && mech
!= By_Short_Descriptor
5756 && !POINTER_TYPE_P (gnu_param_type
)
5757 && !AGGREGATE_TYPE_P (gnu_param_type
)))
5758 && !(Is_Array_Type (Etype (gnat_param
))
5759 && Is_Packed (Etype (gnat_param
))
5760 && Is_Composite_Type (Component_Type (Etype (gnat_param
)))))
5761 return gnu_param_type
;
5763 gnu_param
= create_param_decl (gnu_param_name
, gnu_param_type
,
5764 ro_param
|| by_ref
|| by_component_ptr
);
5765 DECL_BY_REF_P (gnu_param
) = by_ref
;
5766 DECL_BY_DOUBLE_REF_P (gnu_param
) = by_double_ref
;
5767 DECL_BY_COMPONENT_PTR_P (gnu_param
) = by_component_ptr
;
5768 DECL_BY_DESCRIPTOR_P (gnu_param
) = (mech
== By_Descriptor
||
5769 mech
== By_Short_Descriptor
);
5770 /* Note that, in case of a parameter passed by double reference, the
5771 DECL_POINTS_TO_READONLY_P flag is meant for the second reference.
5772 The first reference always points to read-only, as it points to
5773 the second reference, i.e. the reference to the actual parameter. */
5774 DECL_POINTS_TO_READONLY_P (gnu_param
)
5775 = (ro_param
&& (by_ref
|| by_component_ptr
));
5776 DECL_CAN_NEVER_BE_NULL_P (gnu_param
) = Can_Never_Be_Null (gnat_param
);
5778 /* Save the alternate descriptor type, if any. */
5779 if (gnu_param_type_alt
)
5780 SET_DECL_PARM_ALT_TYPE (gnu_param
, gnu_param_type_alt
);
5782 /* If no Mechanism was specified, indicate what we're using, then
5783 back-annotate it. */
5784 if (mech
== Default
)
5785 mech
= (by_ref
|| by_component_ptr
) ? By_Reference
: By_Copy
;
5787 Set_Mechanism (gnat_param
, mech
);
5791 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5794 same_discriminant_p (Entity_Id discr1
, Entity_Id discr2
)
5796 while (Present (Corresponding_Discriminant (discr1
)))
5797 discr1
= Corresponding_Discriminant (discr1
);
5799 while (Present (Corresponding_Discriminant (discr2
)))
5800 discr2
= Corresponding_Discriminant (discr2
);
5803 Original_Record_Component (discr1
) == Original_Record_Component (discr2
);
5806 /* Return true if the array type GNU_TYPE, which represents a dimension of
5807 GNAT_TYPE, has a non-aliased component in the back-end sense. */
5810 array_type_has_nonaliased_component (tree gnu_type
, Entity_Id gnat_type
)
5812 /* If the array type is not the innermost dimension of the GNAT type,
5813 then it has a non-aliased component. */
5814 if (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
5815 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
5818 /* If the array type has an aliased component in the front-end sense,
5819 then it also has an aliased component in the back-end sense. */
5820 if (Has_Aliased_Components (gnat_type
))
5823 /* If this is a derived type, then it has a non-aliased component if
5824 and only if its parent type also has one. */
5825 if (Is_Derived_Type (gnat_type
))
5827 tree gnu_parent_type
= gnat_to_gnu_type (Etype (gnat_type
));
5829 if (TREE_CODE (gnu_parent_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5831 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type
))));
5832 for (index
= Number_Dimensions (gnat_type
) - 1; index
> 0; index
--)
5833 gnu_parent_type
= TREE_TYPE (gnu_parent_type
);
5834 return TYPE_NONALIASED_COMPONENT (gnu_parent_type
);
5837 /* Otherwise, rely exclusively on properties of the element type. */
5838 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type
));
5841 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5844 compile_time_known_address_p (Node_Id gnat_address
)
5846 /* Catch System'To_Address. */
5847 if (Nkind (gnat_address
) == N_Unchecked_Type_Conversion
)
5848 gnat_address
= Expression (gnat_address
);
5850 return Compile_Time_Known_Value (gnat_address
);
5853 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
5854 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
5857 cannot_be_superflat_p (Node_Id gnat_range
)
5859 Node_Id gnat_lb
= Low_Bound (gnat_range
), gnat_hb
= High_Bound (gnat_range
);
5860 Node_Id scalar_range
;
5861 tree gnu_lb
, gnu_hb
, gnu_lb_minus_one
;
5863 /* If the low bound is not constant, try to find an upper bound. */
5864 while (Nkind (gnat_lb
) != N_Integer_Literal
5865 && (Ekind (Etype (gnat_lb
)) == E_Signed_Integer_Subtype
5866 || Ekind (Etype (gnat_lb
)) == E_Modular_Integer_Subtype
)
5867 && (scalar_range
= Scalar_Range (Etype (gnat_lb
)))
5868 && (Nkind (scalar_range
) == N_Signed_Integer_Type_Definition
5869 || Nkind (scalar_range
) == N_Range
))
5870 gnat_lb
= High_Bound (scalar_range
);
5872 /* If the high bound is not constant, try to find a lower bound. */
5873 while (Nkind (gnat_hb
) != N_Integer_Literal
5874 && (Ekind (Etype (gnat_hb
)) == E_Signed_Integer_Subtype
5875 || Ekind (Etype (gnat_hb
)) == E_Modular_Integer_Subtype
)
5876 && (scalar_range
= Scalar_Range (Etype (gnat_hb
)))
5877 && (Nkind (scalar_range
) == N_Signed_Integer_Type_Definition
5878 || Nkind (scalar_range
) == N_Range
))
5879 gnat_hb
= Low_Bound (scalar_range
);
5881 /* If we have failed to find constant bounds, punt. */
5882 if (Nkind (gnat_lb
) != N_Integer_Literal
5883 || Nkind (gnat_hb
) != N_Integer_Literal
)
5886 /* We need at least a signed 64-bit type to catch most cases. */
5887 gnu_lb
= UI_To_gnu (Intval (gnat_lb
), sbitsizetype
);
5888 gnu_hb
= UI_To_gnu (Intval (gnat_hb
), sbitsizetype
);
5889 if (TREE_OVERFLOW (gnu_lb
) || TREE_OVERFLOW (gnu_hb
))
5892 /* If the low bound is the smallest integer, nothing can be smaller. */
5893 gnu_lb_minus_one
= size_binop (MINUS_EXPR
, gnu_lb
, sbitsize_one_node
);
5894 if (TREE_OVERFLOW (gnu_lb_minus_one
))
5897 return !tree_int_cst_lt (gnu_hb
, gnu_lb_minus_one
);
5900 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
5903 constructor_address_p (tree gnu_expr
)
5905 while (TREE_CODE (gnu_expr
) == NOP_EXPR
5906 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
5907 || TREE_CODE (gnu_expr
) == NON_LVALUE_EXPR
)
5908 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
5910 return (TREE_CODE (gnu_expr
) == ADDR_EXPR
5911 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == CONSTRUCTOR
);
5914 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5915 be elaborated at the point of its definition, but do nothing else. */
5918 elaborate_entity (Entity_Id gnat_entity
)
5920 switch (Ekind (gnat_entity
))
5922 case E_Signed_Integer_Subtype
:
5923 case E_Modular_Integer_Subtype
:
5924 case E_Enumeration_Subtype
:
5925 case E_Ordinary_Fixed_Point_Subtype
:
5926 case E_Decimal_Fixed_Point_Subtype
:
5927 case E_Floating_Point_Subtype
:
5929 Node_Id gnat_lb
= Type_Low_Bound (gnat_entity
);
5930 Node_Id gnat_hb
= Type_High_Bound (gnat_entity
);
5932 /* ??? Tests to avoid Constraint_Error in static expressions
5933 are needed until after the front stops generating bogus
5934 conversions on bounds of real types. */
5935 if (!Raises_Constraint_Error (gnat_lb
))
5936 elaborate_expression (gnat_lb
, gnat_entity
, get_identifier ("L"),
5937 true, false, Needs_Debug_Info (gnat_entity
));
5938 if (!Raises_Constraint_Error (gnat_hb
))
5939 elaborate_expression (gnat_hb
, gnat_entity
, get_identifier ("U"),
5940 true, false, Needs_Debug_Info (gnat_entity
));
5946 Node_Id full_definition
= Declaration_Node (gnat_entity
);
5947 Node_Id record_definition
= Type_Definition (full_definition
);
5949 /* If this is a record extension, go a level further to find the
5950 record definition. */
5951 if (Nkind (record_definition
) == N_Derived_Type_Definition
)
5952 record_definition
= Record_Extension_Part (record_definition
);
5956 case E_Record_Subtype
:
5957 case E_Private_Subtype
:
5958 case E_Limited_Private_Subtype
:
5959 case E_Record_Subtype_With_Private
:
5960 if (Is_Constrained (gnat_entity
)
5961 && Has_Discriminants (gnat_entity
)
5962 && Present (Discriminant_Constraint (gnat_entity
)))
5964 Node_Id gnat_discriminant_expr
;
5965 Entity_Id gnat_field
;
5968 = First_Discriminant (Implementation_Base_Type (gnat_entity
)),
5969 gnat_discriminant_expr
5970 = First_Elmt (Discriminant_Constraint (gnat_entity
));
5971 Present (gnat_field
);
5972 gnat_field
= Next_Discriminant (gnat_field
),
5973 gnat_discriminant_expr
= Next_Elmt (gnat_discriminant_expr
))
5974 /* ??? For now, ignore access discriminants. */
5975 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr
))))
5976 elaborate_expression (Node (gnat_discriminant_expr
),
5977 gnat_entity
, get_entity_name (gnat_field
),
5978 true, false, false);
5985 /* Return true if the size in units represented by GNU_SIZE can be handled by
5986 an allocation. If STATIC_P is true, consider only what can be done with a
5987 static allocation. */
5990 allocatable_size_p (tree gnu_size
, bool static_p
)
5992 /* We can allocate a fixed size if it hasn't overflowed and can be handled
5993 (efficiently) on the host. */
5994 if (TREE_CODE (gnu_size
) == INTEGER_CST
)
5995 return !TREE_OVERFLOW (gnu_size
) && host_integerp (gnu_size
, 1);
5997 /* We can allocate a variable size if this isn't a static allocation. */
6002 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
6003 NAME, ARGS and ERROR_POINT. */
6006 prepend_one_attribute_to (struct attrib
** attr_list
,
6007 enum attr_type attr_type
,
6010 Node_Id attr_error_point
)
6012 struct attrib
* attr
= (struct attrib
*) xmalloc (sizeof (struct attrib
));
6014 attr
->type
= attr_type
;
6015 attr
->name
= attr_name
;
6016 attr
->args
= attr_args
;
6017 attr
->error_point
= attr_error_point
;
6019 attr
->next
= *attr_list
;
6023 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
6026 prepend_attributes (Entity_Id gnat_entity
, struct attrib
** attr_list
)
6030 /* Attributes are stored as Representation Item pragmas. */
6032 for (gnat_temp
= First_Rep_Item (gnat_entity
); Present (gnat_temp
);
6033 gnat_temp
= Next_Rep_Item (gnat_temp
))
6034 if (Nkind (gnat_temp
) == N_Pragma
)
6036 tree gnu_arg0
= NULL_TREE
, gnu_arg1
= NULL_TREE
;
6037 Node_Id gnat_assoc
= Pragma_Argument_Associations (gnat_temp
);
6038 enum attr_type etype
;
6040 /* Map the kind of pragma at hand. Skip if this is not one
6041 we know how to handle. */
6043 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp
))))
6045 case Pragma_Machine_Attribute
:
6046 etype
= ATTR_MACHINE_ATTRIBUTE
;
6049 case Pragma_Linker_Alias
:
6050 etype
= ATTR_LINK_ALIAS
;
6053 case Pragma_Linker_Section
:
6054 etype
= ATTR_LINK_SECTION
;
6057 case Pragma_Linker_Constructor
:
6058 etype
= ATTR_LINK_CONSTRUCTOR
;
6061 case Pragma_Linker_Destructor
:
6062 etype
= ATTR_LINK_DESTRUCTOR
;
6065 case Pragma_Weak_External
:
6066 etype
= ATTR_WEAK_EXTERNAL
;
6069 case Pragma_Thread_Local_Storage
:
6070 etype
= ATTR_THREAD_LOCAL_STORAGE
;
6077 /* See what arguments we have and turn them into GCC trees for
6078 attribute handlers. These expect identifier for strings. We
6079 handle at most two arguments, static expressions only. */
6081 if (Present (gnat_assoc
) && Present (First (gnat_assoc
)))
6083 Node_Id gnat_arg0
= Next (First (gnat_assoc
));
6084 Node_Id gnat_arg1
= Empty
;
6086 if (Present (gnat_arg0
)
6087 && Is_Static_Expression (Expression (gnat_arg0
)))
6089 gnu_arg0
= gnat_to_gnu (Expression (gnat_arg0
));
6091 if (TREE_CODE (gnu_arg0
) == STRING_CST
)
6092 gnu_arg0
= get_identifier (TREE_STRING_POINTER (gnu_arg0
));
6094 gnat_arg1
= Next (gnat_arg0
);
6097 if (Present (gnat_arg1
)
6098 && Is_Static_Expression (Expression (gnat_arg1
)))
6100 gnu_arg1
= gnat_to_gnu (Expression (gnat_arg1
));
6102 if (TREE_CODE (gnu_arg1
) == STRING_CST
)
6103 gnu_arg1
= get_identifier (TREE_STRING_POINTER (gnu_arg1
));
6107 /* Prepend to the list now. Make a list of the argument we might
6108 have, as GCC expects it. */
6109 prepend_one_attribute_to
6112 (gnu_arg1
!= NULL_TREE
)
6113 ? build_tree_list (NULL_TREE
, gnu_arg1
) : NULL_TREE
,
6114 Present (Next (First (gnat_assoc
)))
6115 ? Expression (Next (First (gnat_assoc
))) : gnat_temp
);
6119 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6120 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6121 return the GCC tree to use for that expression. GNU_NAME is the suffix
6122 to use if a variable needs to be created and DEFINITION is true if this
6123 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6124 otherwise, we are just elaborating the expression for side-effects. If
6125 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6126 isn't needed for code generation. */
6129 elaborate_expression (Node_Id gnat_expr
, Entity_Id gnat_entity
, tree gnu_name
,
6130 bool definition
, bool need_value
, bool need_debug
)
6134 /* If we already elaborated this expression (e.g. it was involved
6135 in the definition of a private type), use the old value. */
6136 if (present_gnu_tree (gnat_expr
))
6137 return get_gnu_tree (gnat_expr
);
6139 /* If we don't need a value and this is static or a discriminant,
6140 we don't need to do anything. */
6142 && (Is_OK_Static_Expression (gnat_expr
)
6143 || (Nkind (gnat_expr
) == N_Identifier
6144 && Ekind (Entity (gnat_expr
)) == E_Discriminant
)))
6147 /* If it's a static expression, we don't need a variable for debugging. */
6148 if (need_debug
&& Is_OK_Static_Expression (gnat_expr
))
6151 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6152 gnu_expr
= elaborate_expression_1 (gnat_to_gnu (gnat_expr
), gnat_entity
,
6153 gnu_name
, definition
, need_debug
);
6155 /* Save the expression in case we try to elaborate this entity again. Since
6156 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6157 if (!CONTAINS_PLACEHOLDER_P (gnu_expr
))
6158 save_gnu_tree (gnat_expr
, gnu_expr
, true);
6160 return need_value
? gnu_expr
: error_mark_node
;
6163 /* Similar, but take a GNU expression and always return a result. */
6166 elaborate_expression_1 (tree gnu_expr
, Entity_Id gnat_entity
, tree gnu_name
,
6167 bool definition
, bool need_debug
)
6169 const bool expr_public_p
= Is_Public (gnat_entity
);
6170 const bool expr_global_p
= expr_public_p
|| global_bindings_p ();
6171 bool expr_variable_p
, use_variable
;
6173 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
6174 reference will have been replaced with a COMPONENT_REF when the type
6175 is being elaborated. However, there are some cases involving child
6176 types where we will. So convert it to a COMPONENT_REF. We hope it
6177 will be at the highest level of the expression in these cases. */
6178 if (TREE_CODE (gnu_expr
) == FIELD_DECL
)
6179 gnu_expr
= build3 (COMPONENT_REF
, TREE_TYPE (gnu_expr
),
6180 build0 (PLACEHOLDER_EXPR
, DECL_CONTEXT (gnu_expr
)),
6181 gnu_expr
, NULL_TREE
);
6183 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6184 that an expression cannot contain both a discriminant and a variable. */
6185 if (CONTAINS_PLACEHOLDER_P (gnu_expr
))
6188 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6189 a variable that is initialized to contain the expression when the package
6190 containing the definition is elaborated. If this entity is defined at top
6191 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6192 if this is necessary. */
6193 if (CONSTANT_CLASS_P (gnu_expr
))
6194 expr_variable_p
= false;
6197 /* Skip any conversions and simple arithmetics to see if the expression
6198 is based on a read-only variable.
6199 ??? This really should remain read-only, but we have to think about
6200 the typing of the tree here. */
6202 = skip_simple_arithmetic (remove_conversions (gnu_expr
, true));
6204 if (handled_component_p (inner
))
6206 HOST_WIDE_INT bitsize
, bitpos
;
6208 enum machine_mode mode
;
6209 int unsignedp
, volatilep
;
6211 inner
= get_inner_reference (inner
, &bitsize
, &bitpos
, &offset
,
6212 &mode
, &unsignedp
, &volatilep
, false);
6213 /* If the offset is variable, err on the side of caution. */
6220 && TREE_CODE (inner
) == VAR_DECL
6221 && (TREE_READONLY (inner
) || DECL_READONLY_ONCE_ELAB (inner
)));
6224 /* We only need to use the variable if we are in a global context since GCC
6225 can do the right thing in the local case. However, when not optimizing,
6226 use it for bounds of loop iteration scheme to avoid code duplication. */
6227 use_variable
= expr_variable_p
6231 && Is_Itype (gnat_entity
)
6232 && Nkind (Associated_Node_For_Itype (gnat_entity
))
6233 == N_Loop_Parameter_Specification
));
6235 /* Now create it, possibly only for debugging purposes. */
6236 if (use_variable
|| need_debug
)
6240 (create_concat_name (gnat_entity
, IDENTIFIER_POINTER (gnu_name
)),
6241 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
, true, expr_public_p
,
6242 !definition
, expr_global_p
, !need_debug
, NULL
, gnat_entity
);
6248 return expr_variable_p
? gnat_save_expr (gnu_expr
) : gnu_expr
;
6251 /* Similar, but take an alignment factor and make it explicit in the tree. */
6254 elaborate_expression_2 (tree gnu_expr
, Entity_Id gnat_entity
, tree gnu_name
,
6255 bool definition
, bool need_debug
, unsigned int align
)
6257 tree unit_align
= size_int (align
/ BITS_PER_UNIT
);
6259 size_binop (MULT_EXPR
,
6260 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR
,
6263 gnat_entity
, gnu_name
, definition
,
6268 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6269 the value passed against the list of choices. */
6272 choices_to_gnu (tree operand
, Node_Id choices
)
6276 tree result
= boolean_false_node
;
6277 tree this_test
, low
= 0, high
= 0, single
= 0;
6279 for (choice
= First (choices
); Present (choice
); choice
= Next (choice
))
6281 switch (Nkind (choice
))
6284 low
= gnat_to_gnu (Low_Bound (choice
));
6285 high
= gnat_to_gnu (High_Bound (choice
));
6288 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6289 build_binary_op (GE_EXPR
, boolean_type_node
,
6291 build_binary_op (LE_EXPR
, boolean_type_node
,
6296 case N_Subtype_Indication
:
6297 gnat_temp
= Range_Expression (Constraint (choice
));
6298 low
= gnat_to_gnu (Low_Bound (gnat_temp
));
6299 high
= gnat_to_gnu (High_Bound (gnat_temp
));
6302 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6303 build_binary_op (GE_EXPR
, boolean_type_node
,
6305 build_binary_op (LE_EXPR
, boolean_type_node
,
6310 case N_Expanded_Name
:
6311 /* This represents either a subtype range, an enumeration
6312 literal, or a constant Ekind says which. If an enumeration
6313 literal or constant, fall through to the next case. */
6314 if (Ekind (Entity (choice
)) != E_Enumeration_Literal
6315 && Ekind (Entity (choice
)) != E_Constant
)
6317 tree type
= gnat_to_gnu_type (Entity (choice
));
6319 low
= TYPE_MIN_VALUE (type
);
6320 high
= TYPE_MAX_VALUE (type
);
6323 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6324 build_binary_op (GE_EXPR
, boolean_type_node
,
6326 build_binary_op (LE_EXPR
, boolean_type_node
,
6331 /* ... fall through ... */
6333 case N_Character_Literal
:
6334 case N_Integer_Literal
:
6335 single
= gnat_to_gnu (choice
);
6336 this_test
= build_binary_op (EQ_EXPR
, boolean_type_node
, operand
,
6340 case N_Others_Choice
:
6341 this_test
= boolean_true_node
;
6348 result
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, result
,
6355 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6356 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6359 adjust_packed (tree field_type
, tree record_type
, int packed
)
6361 /* If the field contains an item of variable size, we cannot pack it
6362 because we cannot create temporaries of non-fixed size in case
6363 we need to take the address of the field. See addressable_p and
6364 the notes on the addressability issues for further details. */
6365 if (type_has_variable_size (field_type
))
6368 /* If the alignment of the record is specified and the field type
6369 is over-aligned, request Storage_Unit alignment for the field. */
6372 if (TYPE_ALIGN (field_type
) > TYPE_ALIGN (record_type
))
6381 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6382 placed in GNU_RECORD_TYPE.
6384 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6385 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6386 record has a specified alignment.
6388 DEFINITION is true if this field is for a record being defined.
6390 DEBUG_INFO_P is true if we need to write debug information for types
6391 that we may create in the process. */
6394 gnat_to_gnu_field (Entity_Id gnat_field
, tree gnu_record_type
, int packed
,
6395 bool definition
, bool debug_info_p
)
6397 const Entity_Id gnat_field_type
= Etype (gnat_field
);
6398 tree gnu_field_type
= gnat_to_gnu_type (gnat_field_type
);
6399 tree gnu_field_id
= get_entity_name (gnat_field
);
6400 tree gnu_field
, gnu_size
, gnu_pos
;
6402 = (Treat_As_Volatile (gnat_field
) || Treat_As_Volatile (gnat_field_type
));
6403 bool needs_strict_alignment
6405 || Is_Aliased (gnat_field
)
6406 || Strict_Alignment (gnat_field_type
));
6408 /* If this field requires strict alignment, we cannot pack it because
6409 it would very likely be under-aligned in the record. */
6410 if (needs_strict_alignment
)
6413 packed
= adjust_packed (gnu_field_type
, gnu_record_type
, packed
);
6415 /* If a size is specified, use it. Otherwise, if the record type is packed,
6416 use the official RM size. See "Handling of Type'Size Values" in Einfo
6417 for further details. */
6418 if (Known_Esize (gnat_field
))
6419 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6420 gnat_field
, FIELD_DECL
, false, true);
6421 else if (packed
== 1)
6422 gnu_size
= validate_size (RM_Size (gnat_field_type
), gnu_field_type
,
6423 gnat_field
, FIELD_DECL
, false, true);
6425 gnu_size
= NULL_TREE
;
6427 /* If we have a specified size that is smaller than that of the field's type,
6428 or a position is specified, and the field's type is a record that doesn't
6429 require strict alignment, see if we can get either an integral mode form
6430 of the type or a smaller form. If we can, show a size was specified for
6431 the field if there wasn't one already, so we know to make this a bitfield
6432 and avoid making things wider.
6434 Changing to an integral mode form is useful when the record is packed as
6435 we can then place the field at a non-byte-aligned position and so achieve
6436 tighter packing. This is in addition required if the field shares a byte
6437 with another field and the front-end lets the back-end handle the access
6438 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6440 Changing to a smaller form is required if the specified size is smaller
6441 than that of the field's type and the type contains sub-fields that are
6442 padded, in order to avoid generating accesses to these sub-fields that
6443 are wider than the field.
6445 We avoid the transformation if it is not required or potentially useful,
6446 as it might entail an increase of the field's alignment and have ripple
6447 effects on the outer record type. A typical case is a field known to be
6448 byte-aligned and not to share a byte with another field. */
6449 if (!needs_strict_alignment
6450 && RECORD_OR_UNION_TYPE_P (gnu_field_type
)
6451 && !TYPE_FAT_POINTER_P (gnu_field_type
)
6452 && host_integerp (TYPE_SIZE (gnu_field_type
), 1)
6455 && (tree_int_cst_lt (gnu_size
, TYPE_SIZE (gnu_field_type
))
6456 || (Present (Component_Clause (gnat_field
))
6457 && !(UI_To_Int (Component_Bit_Offset (gnat_field
))
6458 % BITS_PER_UNIT
== 0
6459 && value_factor_p (gnu_size
, BITS_PER_UNIT
)))))))
6461 tree gnu_packable_type
= make_packable_type (gnu_field_type
, true);
6462 if (gnu_packable_type
!= gnu_field_type
)
6464 gnu_field_type
= gnu_packable_type
;
6466 gnu_size
= rm_size (gnu_field_type
);
6470 if (Is_Atomic (gnat_field
))
6471 check_ok_for_atomic (gnu_field_type
, gnat_field
, false);
6473 if (Present (Component_Clause (gnat_field
)))
6475 Entity_Id gnat_parent
6476 = Parent_Subtype (Underlying_Type (Scope (gnat_field
)));
6478 gnu_pos
= UI_To_gnu (Component_Bit_Offset (gnat_field
), bitsizetype
);
6479 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6480 gnat_field
, FIELD_DECL
, false, true);
6482 /* Ensure the position does not overlap with the parent subtype, if there
6483 is one. This test is omitted if the parent of the tagged type has a
6484 full rep clause since, in this case, component clauses are allowed to
6485 overlay the space allocated for the parent type and the front-end has
6486 checked that there are no overlapping components. */
6487 if (Present (gnat_parent
) && !Is_Fully_Repped_Tagged_Type (gnat_parent
))
6489 tree gnu_parent
= gnat_to_gnu_type (gnat_parent
);
6491 if (TREE_CODE (TYPE_SIZE (gnu_parent
)) == INTEGER_CST
6492 && tree_int_cst_lt (gnu_pos
, TYPE_SIZE (gnu_parent
)))
6495 ("offset of& must be beyond parent{, minimum allowed is ^}",
6496 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6497 TYPE_SIZE_UNIT (gnu_parent
));
6501 /* If this field needs strict alignment, check that the record is
6502 sufficiently aligned and that position and size are consistent
6503 with the alignment. But don't do it if we are just annotating
6504 types and the field's type is tagged, since tagged types aren't
6505 fully laid out in this mode. */
6506 if (needs_strict_alignment
6507 && !(type_annotate_only
&& Is_Tagged_Type (gnat_field_type
)))
6509 TYPE_ALIGN (gnu_record_type
)
6510 = MAX (TYPE_ALIGN (gnu_record_type
), TYPE_ALIGN (gnu_field_type
));
6513 && !operand_equal_p (gnu_size
, TYPE_SIZE (gnu_field_type
), 0))
6515 if (Is_Atomic (gnat_field
) || Is_Atomic (gnat_field_type
))
6517 ("atomic field& must be natural size of type{ (^)}",
6518 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6519 TYPE_SIZE (gnu_field_type
));
6521 else if (Is_Aliased (gnat_field
))
6523 ("size of aliased field& must be ^ bits",
6524 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6525 TYPE_SIZE (gnu_field_type
));
6527 else if (Strict_Alignment (gnat_field_type
))
6529 ("size of & with aliased or tagged components not ^ bits",
6530 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6531 TYPE_SIZE (gnu_field_type
));
6533 gnu_size
= NULL_TREE
;
6536 if (!integer_zerop (size_binop
6537 (TRUNC_MOD_EXPR
, gnu_pos
,
6538 bitsize_int (TYPE_ALIGN (gnu_field_type
)))))
6542 ("position of volatile field& must be multiple of ^ bits",
6543 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6544 TYPE_ALIGN (gnu_field_type
));
6546 else if (Is_Aliased (gnat_field
))
6548 ("position of aliased field& must be multiple of ^ bits",
6549 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6550 TYPE_ALIGN (gnu_field_type
));
6552 else if (Strict_Alignment (gnat_field_type
))
6554 ("position of & is not compatible with alignment required "
6555 "by its components",
6556 First_Bit (Component_Clause (gnat_field
)), gnat_field
);
6561 gnu_pos
= NULL_TREE
;
6566 /* If the record has rep clauses and this is the tag field, make a rep
6567 clause for it as well. */
6568 else if (Has_Specified_Layout (Scope (gnat_field
))
6569 && Chars (gnat_field
) == Name_uTag
)
6571 gnu_pos
= bitsize_zero_node
;
6572 gnu_size
= TYPE_SIZE (gnu_field_type
);
6577 gnu_pos
= NULL_TREE
;
6579 /* If we are packing the record and the field is BLKmode, round the
6580 size up to a byte boundary. */
6581 if (packed
&& TYPE_MODE (gnu_field_type
) == BLKmode
&& gnu_size
)
6582 gnu_size
= round_up (gnu_size
, BITS_PER_UNIT
);
6585 /* We need to make the size the maximum for the type if it is
6586 self-referential and an unconstrained type. In that case, we can't
6587 pack the field since we can't make a copy to align it. */
6588 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
6590 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type
))
6591 && !Is_Constrained (Underlying_Type (gnat_field_type
)))
6593 gnu_size
= max_size (TYPE_SIZE (gnu_field_type
), true);
6597 /* If a size is specified, adjust the field's type to it. */
6600 tree orig_field_type
;
6602 /* If the field's type is justified modular, we would need to remove
6603 the wrapper to (better) meet the layout requirements. However we
6604 can do so only if the field is not aliased to preserve the unique
6605 layout and if the prescribed size is not greater than that of the
6606 packed array to preserve the justification. */
6607 if (!needs_strict_alignment
6608 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
6609 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
6610 && tree_int_cst_compare (gnu_size
, TYPE_ADA_SIZE (gnu_field_type
))
6612 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
6615 = make_type_from_size (gnu_field_type
, gnu_size
,
6616 Has_Biased_Representation (gnat_field
));
6618 orig_field_type
= gnu_field_type
;
6619 gnu_field_type
= maybe_pad_type (gnu_field_type
, gnu_size
, 0, gnat_field
,
6620 false, false, definition
, true);
6622 /* If a padding record was made, declare it now since it will never be
6623 declared otherwise. This is necessary to ensure that its subtrees
6624 are properly marked. */
6625 if (gnu_field_type
!= orig_field_type
6626 && !DECL_P (TYPE_NAME (gnu_field_type
)))
6627 create_type_decl (TYPE_NAME (gnu_field_type
), gnu_field_type
, NULL
,
6628 true, debug_info_p
, gnat_field
);
6631 /* Otherwise (or if there was an error), don't specify a position. */
6633 gnu_pos
= NULL_TREE
;
6635 gcc_assert (TREE_CODE (gnu_field_type
) != RECORD_TYPE
6636 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type
));
6638 /* Now create the decl for the field. */
6640 = create_field_decl (gnu_field_id
, gnu_field_type
, gnu_record_type
,
6641 gnu_size
, gnu_pos
, packed
, Is_Aliased (gnat_field
));
6642 Sloc_to_locus (Sloc (gnat_field
), &DECL_SOURCE_LOCATION (gnu_field
));
6643 DECL_ALIASED_P (gnu_field
) = Is_Aliased (gnat_field
);
6644 TREE_THIS_VOLATILE (gnu_field
) = TREE_SIDE_EFFECTS (gnu_field
) = is_volatile
;
6646 if (Ekind (gnat_field
) == E_Discriminant
)
6647 DECL_DISCRIMINANT_NUMBER (gnu_field
)
6648 = UI_To_gnu (Discriminant_Number (gnat_field
), sizetype
);
6653 /* Return true if TYPE is a type with variable size or a padding type with a
6654 field of variable size or a record that has a field with such a type. */
6657 type_has_variable_size (tree type
)
6661 if (!TREE_CONSTANT (TYPE_SIZE (type
)))
6664 if (TYPE_IS_PADDING_P (type
)
6665 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type
))))
6668 if (!RECORD_OR_UNION_TYPE_P (type
))
6671 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
6672 if (type_has_variable_size (TREE_TYPE (field
)))
6678 /* Return true if FIELD is an artificial field. */
6681 field_is_artificial (tree field
)
6683 /* These fields are generated by the front-end proper. */
6684 if (IDENTIFIER_POINTER (DECL_NAME (field
)) [0] == '_')
6687 /* These fields are generated by gigi. */
6688 if (DECL_INTERNAL_P (field
))
6694 /* Return true if FIELD is a non-artificial aliased field. */
6697 field_is_aliased (tree field
)
6699 if (field_is_artificial (field
))
6702 return DECL_ALIASED_P (field
);
6705 /* Return true if FIELD is a non-artificial field with self-referential
6709 field_has_self_size (tree field
)
6711 if (field_is_artificial (field
))
6714 if (DECL_SIZE (field
) && TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
)
6717 return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field
)));
6720 /* Return true if FIELD is a non-artificial field with variable size. */
6723 field_has_variable_size (tree field
)
6725 if (field_is_artificial (field
))
6728 if (DECL_SIZE (field
) && TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
)
6731 return TREE_CODE (TYPE_SIZE (TREE_TYPE (field
))) != INTEGER_CST
;
6734 /* qsort comparer for the bit positions of two record components. */
6737 compare_field_bitpos (const PTR rt1
, const PTR rt2
)
6739 const_tree
const field1
= * (const_tree
const *) rt1
;
6740 const_tree
const field2
= * (const_tree
const *) rt2
;
6742 = tree_int_cst_compare (bit_position (field1
), bit_position (field2
));
6744 return ret
? ret
: (int) (DECL_UID (field1
) - DECL_UID (field2
));
6747 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
6748 the result as the field list of GNU_RECORD_TYPE and finish it up. When
6749 called from gnat_to_gnu_entity during the processing of a record type
6750 definition, the GCC node for the parent, if any, will be the single field
6751 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
6752 GNU_FIELD_LIST. The other calls to this function are recursive calls for
6753 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
6755 PACKED is 1 if this is for a packed record, -1 if this is for a record
6756 with Component_Alignment of Storage_Unit, -2 if this is for a record
6757 with a specified alignment.
6759 DEFINITION is true if we are defining this record type.
6761 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
6762 out the record. This means the alignment only serves to force fields to
6763 be bitfields, but not to require the record to be that aligned. This is
6766 ALL_REP is true if a rep clause is present for all the fields.
6768 UNCHECKED_UNION is true if we are building this type for a record with a
6769 Pragma Unchecked_Union.
6771 ARTIFICIAL is true if this is a type that was generated by the compiler.
6773 DEBUG_INFO is true if we need to write debug information about the type.
6775 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
6776 mean that its contents may be unused as well, only the container itself.
6778 REORDER is true if we are permitted to reorder components of this type.
6780 FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
6781 the outer record type down to this variant level. It is nonzero only if
6782 all the fields down to this level have a rep clause and ALL_REP is false.
6784 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6785 with a rep clause is to be added; in this case, that is all that should
6786 be done with such fields. */
6789 components_to_record (tree gnu_record_type
, Node_Id gnat_component_list
,
6790 tree gnu_field_list
, int packed
, bool definition
,
6791 bool cancel_alignment
, bool all_rep
,
6792 bool unchecked_union
, bool artificial
,
6793 bool debug_info
, bool maybe_unused
, bool reorder
,
6794 tree first_free_pos
, tree
*p_gnu_rep_list
)
6796 bool all_rep_and_size
= all_rep
&& TYPE_SIZE (gnu_record_type
);
6797 bool layout_with_rep
= false;
6798 bool has_self_field
= false;
6799 bool has_aliased_after_self_field
= false;
6800 Node_Id component_decl
, variant_part
;
6801 tree gnu_field
, gnu_next
, gnu_last
;
6802 tree gnu_rep_part
= NULL_TREE
;
6803 tree gnu_variant_part
= NULL_TREE
;
6804 tree gnu_rep_list
= NULL_TREE
;
6805 tree gnu_var_list
= NULL_TREE
;
6806 tree gnu_self_list
= NULL_TREE
;
6808 /* For each component referenced in a component declaration create a GCC
6809 field and add it to the list, skipping pragmas in the GNAT list. */
6810 gnu_last
= tree_last (gnu_field_list
);
6811 if (Present (Component_Items (gnat_component_list
)))
6813 = First_Non_Pragma (Component_Items (gnat_component_list
));
6814 Present (component_decl
);
6815 component_decl
= Next_Non_Pragma (component_decl
))
6817 Entity_Id gnat_field
= Defining_Entity (component_decl
);
6818 Name_Id gnat_name
= Chars (gnat_field
);
6820 /* If present, the _Parent field must have been created as the single
6821 field of the record type. Put it before any other fields. */
6822 if (gnat_name
== Name_uParent
)
6824 gnu_field
= TYPE_FIELDS (gnu_record_type
);
6825 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
6829 gnu_field
= gnat_to_gnu_field (gnat_field
, gnu_record_type
, packed
,
6830 definition
, debug_info
);
6832 /* If this is the _Tag field, put it before any other fields. */
6833 if (gnat_name
== Name_uTag
)
6834 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
6836 /* If this is the _Controller field, put it before the other
6837 fields except for the _Tag or _Parent field. */
6838 else if (gnat_name
== Name_uController
&& gnu_last
)
6840 DECL_CHAIN (gnu_field
) = DECL_CHAIN (gnu_last
);
6841 DECL_CHAIN (gnu_last
) = gnu_field
;
6844 /* If this is a regular field, put it after the other fields. */
6847 DECL_CHAIN (gnu_field
) = gnu_field_list
;
6848 gnu_field_list
= gnu_field
;
6850 gnu_last
= gnu_field
;
6852 /* And record information for the final layout. */
6853 if (field_has_self_size (gnu_field
))
6854 has_self_field
= true;
6855 else if (has_self_field
&& field_is_aliased (gnu_field
))
6856 has_aliased_after_self_field
= true;
6860 save_gnu_tree (gnat_field
, gnu_field
, false);
6863 /* At the end of the component list there may be a variant part. */
6864 variant_part
= Variant_Part (gnat_component_list
);
6866 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6867 mutually exclusive and should go in the same memory. To do this we need
6868 to treat each variant as a record whose elements are created from the
6869 component list for the variant. So here we create the records from the
6870 lists for the variants and put them all into the QUAL_UNION_TYPE.
6871 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6872 use GNU_RECORD_TYPE if there are no fields so far. */
6873 if (Present (variant_part
))
6875 Node_Id gnat_discr
= Name (variant_part
), variant
;
6876 tree gnu_discr
= gnat_to_gnu (gnat_discr
);
6877 tree gnu_name
= TYPE_NAME (gnu_record_type
);
6879 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr
))),
6881 tree gnu_union_type
, gnu_union_name
;
6882 tree this_first_free_pos
, gnu_variant_list
= NULL_TREE
;
6884 if (TREE_CODE (gnu_name
) == TYPE_DECL
)
6885 gnu_name
= DECL_NAME (gnu_name
);
6888 = concat_name (gnu_name
, IDENTIFIER_POINTER (gnu_var_name
));
6890 /* Reuse the enclosing union if this is an Unchecked_Union whose fields
6891 are all in the variant part, to match the layout of C unions. There
6892 is an associated check below. */
6893 if (TREE_CODE (gnu_record_type
) == UNION_TYPE
)
6894 gnu_union_type
= gnu_record_type
;
6898 = make_node (unchecked_union
? UNION_TYPE
: QUAL_UNION_TYPE
);
6900 TYPE_NAME (gnu_union_type
) = gnu_union_name
;
6901 TYPE_ALIGN (gnu_union_type
) = 0;
6902 TYPE_PACKED (gnu_union_type
) = TYPE_PACKED (gnu_record_type
);
6905 /* If all the fields down to this level have a rep clause, find out
6906 whether all the fields at this level also have one. If so, then
6907 compute the new first free position to be passed downward. */
6908 this_first_free_pos
= first_free_pos
;
6909 if (this_first_free_pos
)
6911 for (gnu_field
= gnu_field_list
;
6913 gnu_field
= DECL_CHAIN (gnu_field
))
6914 if (DECL_FIELD_OFFSET (gnu_field
))
6916 tree pos
= bit_position (gnu_field
);
6917 if (!tree_int_cst_lt (pos
, this_first_free_pos
))
6919 = size_binop (PLUS_EXPR
, pos
, DECL_SIZE (gnu_field
));
6923 this_first_free_pos
= NULL_TREE
;
6928 for (variant
= First_Non_Pragma (Variants (variant_part
));
6930 variant
= Next_Non_Pragma (variant
))
6932 tree gnu_variant_type
= make_node (RECORD_TYPE
);
6933 tree gnu_inner_name
;
6936 Get_Variant_Encoding (variant
);
6937 gnu_inner_name
= get_identifier_with_length (Name_Buffer
, Name_Len
);
6938 TYPE_NAME (gnu_variant_type
)
6939 = concat_name (gnu_union_name
,
6940 IDENTIFIER_POINTER (gnu_inner_name
));
6942 /* Set the alignment of the inner type in case we need to make
6943 inner objects into bitfields, but then clear it out so the
6944 record actually gets only the alignment required. */
6945 TYPE_ALIGN (gnu_variant_type
) = TYPE_ALIGN (gnu_record_type
);
6946 TYPE_PACKED (gnu_variant_type
) = TYPE_PACKED (gnu_record_type
);
6948 /* Similarly, if the outer record has a size specified and all
6949 the fields have a rep clause, we can propagate the size. */
6950 if (all_rep_and_size
)
6952 TYPE_SIZE (gnu_variant_type
) = TYPE_SIZE (gnu_record_type
);
6953 TYPE_SIZE_UNIT (gnu_variant_type
)
6954 = TYPE_SIZE_UNIT (gnu_record_type
);
6957 /* Add the fields into the record type for the variant. Note that
6958 we aren't sure to really use it at this point, see below. */
6959 components_to_record (gnu_variant_type
, Component_List (variant
),
6960 NULL_TREE
, packed
, definition
,
6961 !all_rep_and_size
, all_rep
, unchecked_union
,
6962 true, debug_info
, true, reorder
,
6963 this_first_free_pos
,
6964 all_rep
|| this_first_free_pos
6965 ? NULL
: &gnu_rep_list
);
6967 gnu_qual
= choices_to_gnu (gnu_discr
, Discrete_Choices (variant
));
6968 Set_Present_Expr (variant
, annotate_value (gnu_qual
));
6970 /* If this is an Unchecked_Union whose fields are all in the variant
6971 part and we have a single field with no representation clause or
6972 placed at offset zero, use the field directly to match the layout
6974 if (TREE_CODE (gnu_record_type
) == UNION_TYPE
6975 && (gnu_field
= TYPE_FIELDS (gnu_variant_type
)) != NULL_TREE
6976 && !DECL_CHAIN (gnu_field
)
6977 && (!DECL_FIELD_OFFSET (gnu_field
)
6978 || integer_zerop (bit_position (gnu_field
))))
6979 DECL_CONTEXT (gnu_field
) = gnu_union_type
;
6982 /* Deal with packedness like in gnat_to_gnu_field. */
6984 = adjust_packed (gnu_variant_type
, gnu_record_type
, packed
);
6986 /* Finalize the record type now. We used to throw away
6987 empty records but we no longer do that because we need
6988 them to generate complete debug info for the variant;
6989 otherwise, the union type definition will be lacking
6990 the fields associated with these empty variants. */
6991 rest_of_record_type_compilation (gnu_variant_type
);
6992 create_type_decl (TYPE_NAME (gnu_variant_type
), gnu_variant_type
,
6993 NULL
, true, debug_info
, gnat_component_list
);
6996 = create_field_decl (gnu_inner_name
, gnu_variant_type
,
6999 ? TYPE_SIZE (gnu_variant_type
) : 0,
7001 ? bitsize_zero_node
: 0,
7004 DECL_INTERNAL_P (gnu_field
) = 1;
7006 if (!unchecked_union
)
7007 DECL_QUALIFIER (gnu_field
) = gnu_qual
;
7010 DECL_CHAIN (gnu_field
) = gnu_variant_list
;
7011 gnu_variant_list
= gnu_field
;
7014 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7015 if (gnu_variant_list
)
7017 int union_field_packed
;
7019 if (all_rep_and_size
)
7021 TYPE_SIZE (gnu_union_type
) = TYPE_SIZE (gnu_record_type
);
7022 TYPE_SIZE_UNIT (gnu_union_type
)
7023 = TYPE_SIZE_UNIT (gnu_record_type
);
7026 finish_record_type (gnu_union_type
, nreverse (gnu_variant_list
),
7027 all_rep_and_size
? 1 : 0, debug_info
);
7029 /* If GNU_UNION_TYPE is our record type, it means we must have an
7030 Unchecked_Union with no fields. Verify that and, if so, just
7032 if (gnu_union_type
== gnu_record_type
)
7034 gcc_assert (unchecked_union
7040 create_type_decl (TYPE_NAME (gnu_union_type
), gnu_union_type
,
7041 NULL
, true, debug_info
, gnat_component_list
);
7043 /* Deal with packedness like in gnat_to_gnu_field. */
7045 = adjust_packed (gnu_union_type
, gnu_record_type
, packed
);
7048 = create_field_decl (gnu_var_name
, gnu_union_type
, gnu_record_type
,
7049 all_rep
? TYPE_SIZE (gnu_union_type
) : 0,
7050 all_rep
|| this_first_free_pos
7051 ? bitsize_zero_node
: 0,
7052 union_field_packed
, 0);
7054 DECL_INTERNAL_P (gnu_variant_part
) = 1;
7058 /* From now on, a zero FIRST_FREE_POS is totally useless. */
7059 if (first_free_pos
&& integer_zerop (first_free_pos
))
7060 first_free_pos
= NULL_TREE
;
7062 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
7063 permitted to reorder components, self-referential sizes or variable sizes.
7064 If they do, pull them out and put them onto the appropriate list. We have
7065 to do this in a separate pass since we want to handle the discriminants
7066 but can't play with them until we've used them in debugging data above.
7068 ??? If we reorder them, debugging information will be wrong but there is
7069 nothing that can be done about this at the moment. */
7070 gnu_last
= NULL_TREE
;
7072 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7075 DECL_CHAIN (gnu_last) = gnu_next; \
7077 gnu_field_list = gnu_next; \
7079 DECL_CHAIN (gnu_field) = (LIST); \
7080 (LIST) = gnu_field; \
7083 for (gnu_field
= gnu_field_list
; gnu_field
; gnu_field
= gnu_next
)
7085 gnu_next
= DECL_CHAIN (gnu_field
);
7087 if (DECL_FIELD_OFFSET (gnu_field
))
7089 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list
);
7093 if ((reorder
|| has_aliased_after_self_field
)
7094 && field_has_self_size (gnu_field
))
7096 MOVE_FROM_FIELD_LIST_TO (gnu_self_list
);
7100 if (reorder
&& field_has_variable_size (gnu_field
))
7102 MOVE_FROM_FIELD_LIST_TO (gnu_var_list
);
7106 gnu_last
= gnu_field
;
7109 #undef MOVE_FROM_FIELD_LIST_TO
7111 /* If permitted, we reorder the fields as follows:
7113 1) all fixed length fields,
7114 2) all fields whose length doesn't depend on discriminants,
7115 3) all fields whose length depends on discriminants,
7116 4) the variant part,
7118 within the record and within each variant recursively. */
7121 = chainon (nreverse (gnu_self_list
),
7122 chainon (nreverse (gnu_var_list
), gnu_field_list
));
7124 /* Otherwise, if there is an aliased field placed after a field whose length
7125 depends on discriminants, we put all the fields of the latter sort, last.
7126 We need to do this in case an object of this record type is mutable. */
7127 else if (has_aliased_after_self_field
)
7128 gnu_field_list
= chainon (nreverse (gnu_self_list
), gnu_field_list
);
7130 /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
7131 in our REP list to the previous level because this level needs them in
7132 order to do a correct layout, i.e. avoid having overlapping fields. */
7133 if (p_gnu_rep_list
&& gnu_rep_list
)
7134 *p_gnu_rep_list
= chainon (*p_gnu_rep_list
, gnu_rep_list
);
7136 /* Otherwise, sort the fields by bit position and put them into their own
7137 record, before the others, if we also have fields without rep clause. */
7138 else if (gnu_rep_list
)
7141 = (gnu_field_list
? make_node (RECORD_TYPE
) : gnu_record_type
);
7142 int i
, len
= list_length (gnu_rep_list
);
7143 tree
*gnu_arr
= XALLOCAVEC (tree
, len
);
7145 for (gnu_field
= gnu_rep_list
, i
= 0;
7147 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
7148 gnu_arr
[i
] = gnu_field
;
7150 qsort (gnu_arr
, len
, sizeof (tree
), compare_field_bitpos
);
7152 /* Put the fields in the list in order of increasing position, which
7153 means we start from the end. */
7154 gnu_rep_list
= NULL_TREE
;
7155 for (i
= len
- 1; i
>= 0; i
--)
7157 DECL_CHAIN (gnu_arr
[i
]) = gnu_rep_list
;
7158 gnu_rep_list
= gnu_arr
[i
];
7159 DECL_CONTEXT (gnu_arr
[i
]) = gnu_rep_type
;
7164 finish_record_type (gnu_rep_type
, gnu_rep_list
, 1, debug_info
);
7166 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
7167 without rep clause are laid out starting from this position.
7168 Therefore, we force it as a minimal size on the REP part. */
7170 = create_rep_part (gnu_rep_type
, gnu_record_type
, first_free_pos
);
7174 layout_with_rep
= true;
7175 gnu_field_list
= nreverse (gnu_rep_list
);
7179 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields without
7180 rep clause are laid out starting from this position. Therefore, if we
7181 have not already done so, we create a fake REP part with this size. */
7182 if (first_free_pos
&& !layout_with_rep
&& !gnu_rep_part
)
7184 tree gnu_rep_type
= make_node (RECORD_TYPE
);
7185 finish_record_type (gnu_rep_type
, NULL_TREE
, 0, debug_info
);
7187 = create_rep_part (gnu_rep_type
, gnu_record_type
, first_free_pos
);
7190 /* Now chain the REP part at the end of the reversed field list. */
7192 gnu_field_list
= chainon (gnu_field_list
, gnu_rep_part
);
7194 /* And the variant part at the beginning. */
7195 if (gnu_variant_part
)
7197 DECL_CHAIN (gnu_variant_part
) = gnu_field_list
;
7198 gnu_field_list
= gnu_variant_part
;
7201 if (cancel_alignment
)
7202 TYPE_ALIGN (gnu_record_type
) = 0;
7204 finish_record_type (gnu_record_type
, nreverse (gnu_field_list
),
7205 layout_with_rep
? 1 : 0, false);
7206 TYPE_ARTIFICIAL (gnu_record_type
) = artificial
;
7207 if (debug_info
&& !maybe_unused
)
7208 rest_of_record_type_compilation (gnu_record_type
);
7211 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7212 placed into an Esize, Component_Bit_Offset, or Component_Size value
7213 in the GNAT tree. */
7216 annotate_value (tree gnu_size
)
7219 Node_Ref_Or_Val ops
[3], ret
;
7220 struct tree_int_map in
;
7223 /* See if we've already saved the value for this node. */
7224 if (EXPR_P (gnu_size
))
7226 struct tree_int_map
*e
;
7228 if (!annotate_value_cache
)
7229 annotate_value_cache
= htab_create_ggc (512, tree_int_map_hash
,
7230 tree_int_map_eq
, 0);
7231 in
.base
.from
= gnu_size
;
7232 e
= (struct tree_int_map
*)
7233 htab_find (annotate_value_cache
, &in
);
7236 return (Node_Ref_Or_Val
) e
->to
;
7239 in
.base
.from
= NULL_TREE
;
7241 /* If we do not return inside this switch, TCODE will be set to the
7242 code to use for a Create_Node operand and LEN (set above) will be
7243 the number of recursive calls for us to make. */
7245 switch (TREE_CODE (gnu_size
))
7248 if (TREE_OVERFLOW (gnu_size
))
7251 /* This may come from a conversion from some smaller type, so ensure
7252 this is in bitsizetype. */
7253 gnu_size
= convert (bitsizetype
, gnu_size
);
7255 /* For a negative value, build NEGATE_EXPR of the opposite. Such values
7256 appear in expressions containing aligning patterns. Note that, since
7257 sizetype is sign-extended but nonetheless unsigned, we don't directly
7258 use tree_int_cst_sgn. */
7259 if (TREE_INT_CST_HIGH (gnu_size
) < 0)
7261 tree op_size
= fold_build1 (NEGATE_EXPR
, bitsizetype
, gnu_size
);
7262 return annotate_value (build1 (NEGATE_EXPR
, bitsizetype
, op_size
));
7265 return UI_From_gnu (gnu_size
);
7268 /* The only case we handle here is a simple discriminant reference. */
7269 if (TREE_CODE (TREE_OPERAND (gnu_size
, 0)) == PLACEHOLDER_EXPR
7270 && TREE_CODE (TREE_OPERAND (gnu_size
, 1)) == FIELD_DECL
7271 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size
, 1)))
7272 return Create_Node (Discrim_Val
,
7273 annotate_value (DECL_DISCRIMINANT_NUMBER
7274 (TREE_OPERAND (gnu_size
, 1))),
7279 CASE_CONVERT
: case NON_LVALUE_EXPR
:
7280 return annotate_value (TREE_OPERAND (gnu_size
, 0));
7282 /* Now just list the operations we handle. */
7283 case COND_EXPR
: tcode
= Cond_Expr
; break;
7284 case PLUS_EXPR
: tcode
= Plus_Expr
; break;
7285 case MINUS_EXPR
: tcode
= Minus_Expr
; break;
7286 case MULT_EXPR
: tcode
= Mult_Expr
; break;
7287 case TRUNC_DIV_EXPR
: tcode
= Trunc_Div_Expr
; break;
7288 case CEIL_DIV_EXPR
: tcode
= Ceil_Div_Expr
; break;
7289 case FLOOR_DIV_EXPR
: tcode
= Floor_Div_Expr
; break;
7290 case TRUNC_MOD_EXPR
: tcode
= Trunc_Mod_Expr
; break;
7291 case CEIL_MOD_EXPR
: tcode
= Ceil_Mod_Expr
; break;
7292 case FLOOR_MOD_EXPR
: tcode
= Floor_Mod_Expr
; break;
7293 case EXACT_DIV_EXPR
: tcode
= Exact_Div_Expr
; break;
7294 case NEGATE_EXPR
: tcode
= Negate_Expr
; break;
7295 case MIN_EXPR
: tcode
= Min_Expr
; break;
7296 case MAX_EXPR
: tcode
= Max_Expr
; break;
7297 case ABS_EXPR
: tcode
= Abs_Expr
; break;
7298 case TRUTH_ANDIF_EXPR
: tcode
= Truth_Andif_Expr
; break;
7299 case TRUTH_ORIF_EXPR
: tcode
= Truth_Orif_Expr
; break;
7300 case TRUTH_AND_EXPR
: tcode
= Truth_And_Expr
; break;
7301 case TRUTH_OR_EXPR
: tcode
= Truth_Or_Expr
; break;
7302 case TRUTH_XOR_EXPR
: tcode
= Truth_Xor_Expr
; break;
7303 case TRUTH_NOT_EXPR
: tcode
= Truth_Not_Expr
; break;
7304 case BIT_AND_EXPR
: tcode
= Bit_And_Expr
; break;
7305 case LT_EXPR
: tcode
= Lt_Expr
; break;
7306 case LE_EXPR
: tcode
= Le_Expr
; break;
7307 case GT_EXPR
: tcode
= Gt_Expr
; break;
7308 case GE_EXPR
: tcode
= Ge_Expr
; break;
7309 case EQ_EXPR
: tcode
= Eq_Expr
; break;
7310 case NE_EXPR
: tcode
= Ne_Expr
; break;
7314 tree t
= maybe_inline_call_in_expr (gnu_size
);
7316 return annotate_value (t
);
7319 /* Fall through... */
7325 /* Now get each of the operands that's relevant for this code. If any
7326 cannot be expressed as a repinfo node, say we can't. */
7327 for (i
= 0; i
< 3; i
++)
7330 for (i
= 0; i
< TREE_CODE_LENGTH (TREE_CODE (gnu_size
)); i
++)
7332 ops
[i
] = annotate_value (TREE_OPERAND (gnu_size
, i
));
7333 if (ops
[i
] == No_Uint
)
7337 ret
= Create_Node (tcode
, ops
[0], ops
[1], ops
[2]);
7339 /* Save the result in the cache. */
7342 struct tree_int_map
**h
;
7343 /* We can't assume the hash table data hasn't moved since the
7344 initial look up, so we have to search again. Allocating and
7345 inserting an entry at that point would be an alternative, but
7346 then we'd better discard the entry if we decided not to cache
7348 h
= (struct tree_int_map
**)
7349 htab_find_slot (annotate_value_cache
, &in
, INSERT
);
7351 *h
= ggc_alloc_tree_int_map ();
7352 (*h
)->base
.from
= gnu_size
;
7359 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7360 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7361 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7362 BY_REF is true if the object is used by reference and BY_DOUBLE_REF is
7363 true if the object is used by double reference. */
7366 annotate_object (Entity_Id gnat_entity
, tree gnu_type
, tree size
, bool by_ref
,
7372 gnu_type
= TREE_TYPE (gnu_type
);
7374 if (TYPE_IS_FAT_POINTER_P (gnu_type
))
7375 gnu_type
= TYPE_UNCONSTRAINED_ARRAY (gnu_type
);
7377 gnu_type
= TREE_TYPE (gnu_type
);
7380 if (Unknown_Esize (gnat_entity
))
7382 if (TREE_CODE (gnu_type
) == RECORD_TYPE
7383 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7384 size
= TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
))));
7386 size
= TYPE_SIZE (gnu_type
);
7389 Set_Esize (gnat_entity
, annotate_value (size
));
7392 if (Unknown_Alignment (gnat_entity
))
7393 Set_Alignment (gnat_entity
,
7394 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
7397 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7398 Return NULL_TREE if there is no such element in the list. */
7401 purpose_member_field (const_tree elem
, tree list
)
7405 tree field
= TREE_PURPOSE (list
);
7406 if (SAME_FIELD_P (field
, elem
))
7408 list
= TREE_CHAIN (list
);
7413 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7414 set Component_Bit_Offset and Esize of the components to the position and
7415 size used by Gigi. */
7418 annotate_rep (Entity_Id gnat_entity
, tree gnu_type
)
7420 Entity_Id gnat_field
;
7423 /* We operate by first making a list of all fields and their position (we
7424 can get the size easily) and then update all the sizes in the tree. */
7426 = build_position_list (gnu_type
, false, size_zero_node
, bitsize_zero_node
,
7427 BIGGEST_ALIGNMENT
, NULL_TREE
);
7429 for (gnat_field
= First_Entity (gnat_entity
);
7430 Present (gnat_field
);
7431 gnat_field
= Next_Entity (gnat_field
))
7432 if (Ekind (gnat_field
) == E_Component
7433 || (Ekind (gnat_field
) == E_Discriminant
7434 && !Is_Unchecked_Union (Scope (gnat_field
))))
7436 tree t
= purpose_member_field (gnat_to_gnu_field_decl (gnat_field
),
7442 /* If we are just annotating types and the type is tagged, the tag
7443 and the parent components are not generated by the front-end so
7444 we need to add the appropriate offset to each component without
7445 representation clause. */
7446 if (type_annotate_only
7447 && Is_Tagged_Type (gnat_entity
)
7448 && No (Component_Clause (gnat_field
)))
7450 /* For a component appearing in the current extension, the
7451 offset is the size of the parent. */
7452 if (Is_Derived_Type (gnat_entity
)
7453 && Original_Record_Component (gnat_field
) == gnat_field
)
7455 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity
))),
7458 parent_offset
= bitsize_int (POINTER_SIZE
);
7460 if (TYPE_FIELDS (gnu_type
))
7462 = round_up (parent_offset
,
7463 DECL_ALIGN (TYPE_FIELDS (gnu_type
)));
7466 parent_offset
= bitsize_zero_node
;
7468 Set_Component_Bit_Offset
7471 (size_binop (PLUS_EXPR
,
7472 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t
), 0),
7473 TREE_VEC_ELT (TREE_VALUE (t
), 2)),
7476 Set_Esize (gnat_field
,
7477 annotate_value (DECL_SIZE (TREE_PURPOSE (t
))));
7479 else if (Is_Tagged_Type (gnat_entity
) && Is_Derived_Type (gnat_entity
))
7481 /* If there is no entry, this is an inherited component whose
7482 position is the same as in the parent type. */
7483 Set_Component_Bit_Offset
7485 Component_Bit_Offset (Original_Record_Component (gnat_field
)));
7487 Set_Esize (gnat_field
,
7488 Esize (Original_Record_Component (gnat_field
)));
7493 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7494 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7495 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7496 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7497 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7498 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7499 pre-existing list to be chained to the newly created entries. */
7502 build_position_list (tree gnu_type
, bool do_not_flatten_variant
, tree gnu_pos
,
7503 tree gnu_bitpos
, unsigned int offset_align
, tree gnu_list
)
7507 for (gnu_field
= TYPE_FIELDS (gnu_type
);
7509 gnu_field
= DECL_CHAIN (gnu_field
))
7511 tree gnu_our_bitpos
= size_binop (PLUS_EXPR
, gnu_bitpos
,
7512 DECL_FIELD_BIT_OFFSET (gnu_field
));
7513 tree gnu_our_offset
= size_binop (PLUS_EXPR
, gnu_pos
,
7514 DECL_FIELD_OFFSET (gnu_field
));
7515 unsigned int our_offset_align
7516 = MIN (offset_align
, DECL_OFFSET_ALIGN (gnu_field
));
7517 tree v
= make_tree_vec (3);
7519 TREE_VEC_ELT (v
, 0) = gnu_our_offset
;
7520 TREE_VEC_ELT (v
, 1) = size_int (our_offset_align
);
7521 TREE_VEC_ELT (v
, 2) = gnu_our_bitpos
;
7522 gnu_list
= tree_cons (gnu_field
, v
, gnu_list
);
7524 /* Recurse on internal fields, flattening the nested fields except for
7525 those in the variant part, if requested. */
7526 if (DECL_INTERNAL_P (gnu_field
))
7528 tree gnu_field_type
= TREE_TYPE (gnu_field
);
7529 if (do_not_flatten_variant
7530 && TREE_CODE (gnu_field_type
) == QUAL_UNION_TYPE
)
7532 = build_position_list (gnu_field_type
, do_not_flatten_variant
,
7533 size_zero_node
, bitsize_zero_node
,
7534 BIGGEST_ALIGNMENT
, gnu_list
);
7537 = build_position_list (gnu_field_type
, do_not_flatten_variant
,
7538 gnu_our_offset
, gnu_our_bitpos
,
7539 our_offset_align
, gnu_list
);
7546 /* Return a list describing the substitutions needed to reflect the
7547 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7548 be in any order. The values in an element of the list are in the form
7549 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
7550 a definition of GNAT_SUBTYPE. */
7552 static vec
<subst_pair
>
7553 build_subst_list (Entity_Id gnat_subtype
, Entity_Id gnat_type
, bool definition
)
7555 vec
<subst_pair
> gnu_list
= vNULL
;
7556 Entity_Id gnat_discrim
;
7559 for (gnat_discrim
= First_Stored_Discriminant (gnat_type
),
7560 gnat_value
= First_Elmt (Stored_Constraint (gnat_subtype
));
7561 Present (gnat_discrim
);
7562 gnat_discrim
= Next_Stored_Discriminant (gnat_discrim
),
7563 gnat_value
= Next_Elmt (gnat_value
))
7564 /* Ignore access discriminants. */
7565 if (!Is_Access_Type (Etype (Node (gnat_value
))))
7567 tree gnu_field
= gnat_to_gnu_field_decl (gnat_discrim
);
7568 tree replacement
= convert (TREE_TYPE (gnu_field
),
7569 elaborate_expression
7570 (Node (gnat_value
), gnat_subtype
,
7571 get_entity_name (gnat_discrim
),
7572 definition
, true, false));
7573 subst_pair s
= {gnu_field
, replacement
};
7574 gnu_list
.safe_push (s
);
7580 /* Scan all fields in QUAL_UNION_TYPE and return a list describing the
7581 variants of QUAL_UNION_TYPE that are still relevant after applying
7582 the substitutions described in SUBST_LIST. GNU_LIST is a pre-existing
7583 list to be prepended to the newly created entries. */
7585 static vec
<variant_desc
>
7586 build_variant_list (tree qual_union_type
, vec
<subst_pair
> subst_list
,
7587 vec
<variant_desc
> gnu_list
)
7591 for (gnu_field
= TYPE_FIELDS (qual_union_type
);
7593 gnu_field
= DECL_CHAIN (gnu_field
))
7595 tree qual
= DECL_QUALIFIER (gnu_field
);
7599 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
7600 qual
= SUBSTITUTE_IN_EXPR (qual
, s
->discriminant
, s
->replacement
);
7602 /* If the new qualifier is not unconditionally false, its variant may
7603 still be accessed. */
7604 if (!integer_zerop (qual
))
7606 tree variant_type
= TREE_TYPE (gnu_field
), variant_subpart
;
7607 variant_desc v
= {variant_type
, gnu_field
, qual
, NULL_TREE
};
7609 gnu_list
.safe_push (v
);
7611 /* Recurse on the variant subpart of the variant, if any. */
7612 variant_subpart
= get_variant_part (variant_type
);
7613 if (variant_subpart
)
7614 gnu_list
= build_variant_list (TREE_TYPE (variant_subpart
),
7615 subst_list
, gnu_list
);
7617 /* If the new qualifier is unconditionally true, the subsequent
7618 variants cannot be accessed. */
7619 if (integer_onep (qual
))
7627 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7628 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
7629 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
7630 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
7631 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
7632 true if we are being called to process the Component_Size of GNAT_OBJECT;
7633 this is used only for error messages. ZERO_OK is true if a size of zero
7634 is permitted; if ZERO_OK is false, it means that a size of zero should be
7635 treated as an unspecified size. */
7638 validate_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_object
,
7639 enum tree_code kind
, bool component_p
, bool zero_ok
)
7641 Node_Id gnat_error_node
;
7642 tree type_size
, size
;
7644 /* Return 0 if no size was specified. */
7645 if (uint_size
== No_Uint
)
7648 /* Ignore a negative size since that corresponds to our back-annotation. */
7649 if (UI_Lt (uint_size
, Uint_0
))
7652 /* Find the node to use for error messages. */
7653 if ((Ekind (gnat_object
) == E_Component
7654 || Ekind (gnat_object
) == E_Discriminant
)
7655 && Present (Component_Clause (gnat_object
)))
7656 gnat_error_node
= Last_Bit (Component_Clause (gnat_object
));
7657 else if (Present (Size_Clause (gnat_object
)))
7658 gnat_error_node
= Expression (Size_Clause (gnat_object
));
7660 gnat_error_node
= gnat_object
;
7662 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7663 but cannot be represented in bitsizetype. */
7664 size
= UI_To_gnu (uint_size
, bitsizetype
);
7665 if (TREE_OVERFLOW (size
))
7668 post_error_ne ("component size for& is too large", gnat_error_node
,
7671 post_error_ne ("size for& is too large", gnat_error_node
,
7676 /* Ignore a zero size if it is not permitted. */
7677 if (!zero_ok
&& integer_zerop (size
))
7680 /* The size of objects is always a multiple of a byte. */
7681 if (kind
== VAR_DECL
7682 && !integer_zerop (size_binop (TRUNC_MOD_EXPR
, size
, bitsize_unit_node
)))
7685 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7686 gnat_error_node
, gnat_object
);
7688 post_error_ne ("size for& is not a multiple of Storage_Unit",
7689 gnat_error_node
, gnat_object
);
7693 /* If this is an integral type or a packed array type, the front-end has
7694 already verified the size, so we need not do it here (which would mean
7695 checking against the bounds). However, if this is an aliased object,
7696 it may not be smaller than the type of the object. */
7697 if ((INTEGRAL_TYPE_P (gnu_type
) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type
))
7698 && !(kind
== VAR_DECL
&& Is_Aliased (gnat_object
)))
7701 /* If the object is a record that contains a template, add the size of the
7702 template to the specified size. */
7703 if (TREE_CODE (gnu_type
) == RECORD_TYPE
7704 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7705 size
= size_binop (PLUS_EXPR
, DECL_SIZE (TYPE_FIELDS (gnu_type
)), size
);
7707 if (kind
== VAR_DECL
7708 /* If a type needs strict alignment, a component of this type in
7709 a packed record cannot be packed and thus uses the type size. */
7710 || (kind
== TYPE_DECL
&& Strict_Alignment (gnat_object
)))
7711 type_size
= TYPE_SIZE (gnu_type
);
7713 type_size
= rm_size (gnu_type
);
7715 /* Modify the size of a discriminated type to be the maximum size. */
7716 if (type_size
&& CONTAINS_PLACEHOLDER_P (type_size
))
7717 type_size
= max_size (type_size
, true);
7719 /* If this is an access type or a fat pointer, the minimum size is that given
7720 by the smallest integral mode that's valid for pointers. */
7721 if (TREE_CODE (gnu_type
) == POINTER_TYPE
|| TYPE_IS_FAT_POINTER_P (gnu_type
))
7723 enum machine_mode p_mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
7724 while (!targetm
.valid_pointer_mode (p_mode
))
7725 p_mode
= GET_MODE_WIDER_MODE (p_mode
);
7726 type_size
= bitsize_int (GET_MODE_BITSIZE (p_mode
));
7729 /* Issue an error either if the default size of the object isn't a constant
7730 or if the new size is smaller than it. */
7731 if (TREE_CODE (type_size
) != INTEGER_CST
7732 || TREE_OVERFLOW (type_size
)
7733 || tree_int_cst_lt (size
, type_size
))
7737 ("component size for& too small{, minimum allowed is ^}",
7738 gnat_error_node
, gnat_object
, type_size
);
7741 ("size for& too small{, minimum allowed is ^}",
7742 gnat_error_node
, gnat_object
, type_size
);
7749 /* Similarly, but both validate and process a value of RM size. This routine
7750 is only called for types. */
7753 set_rm_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_entity
)
7755 Node_Id gnat_attr_node
;
7756 tree old_size
, size
;
7758 /* Do nothing if no size was specified. */
7759 if (uint_size
== No_Uint
)
7762 /* Ignore a negative size since that corresponds to our back-annotation. */
7763 if (UI_Lt (uint_size
, Uint_0
))
7766 /* Only issue an error if a Value_Size clause was explicitly given.
7767 Otherwise, we'd be duplicating an error on the Size clause. */
7769 = Get_Attribute_Definition_Clause (gnat_entity
, Attr_Value_Size
);
7771 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7772 but cannot be represented in bitsizetype. */
7773 size
= UI_To_gnu (uint_size
, bitsizetype
);
7774 if (TREE_OVERFLOW (size
))
7776 if (Present (gnat_attr_node
))
7777 post_error_ne ("Value_Size for& is too large", gnat_attr_node
,
7782 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
7783 exists, or this is an integer type, in which case the front-end will
7784 have always set it. */
7785 if (No (gnat_attr_node
)
7786 && integer_zerop (size
)
7787 && !Has_Size_Clause (gnat_entity
)
7788 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
7791 old_size
= rm_size (gnu_type
);
7793 /* If the old size is self-referential, get the maximum size. */
7794 if (CONTAINS_PLACEHOLDER_P (old_size
))
7795 old_size
= max_size (old_size
, true);
7797 /* Issue an error either if the old size of the object isn't a constant or
7798 if the new size is smaller than it. The front-end has already verified
7799 this for scalar and packed array types. */
7800 if (TREE_CODE (old_size
) != INTEGER_CST
7801 || TREE_OVERFLOW (old_size
)
7802 || (AGGREGATE_TYPE_P (gnu_type
)
7803 && !(TREE_CODE (gnu_type
) == ARRAY_TYPE
7804 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type
))
7805 && !(TYPE_IS_PADDING_P (gnu_type
)
7806 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
))) == ARRAY_TYPE
7807 && TYPE_PACKED_ARRAY_TYPE_P
7808 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))
7809 && tree_int_cst_lt (size
, old_size
)))
7811 if (Present (gnat_attr_node
))
7813 ("Value_Size for& too small{, minimum allowed is ^}",
7814 gnat_attr_node
, gnat_entity
, old_size
);
7818 /* Otherwise, set the RM size proper for integral types... */
7819 if ((TREE_CODE (gnu_type
) == INTEGER_TYPE
7820 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
7821 || (TREE_CODE (gnu_type
) == ENUMERAL_TYPE
7822 || TREE_CODE (gnu_type
) == BOOLEAN_TYPE
))
7823 SET_TYPE_RM_SIZE (gnu_type
, size
);
7825 /* ...or the Ada size for record and union types. */
7826 else if (RECORD_OR_UNION_TYPE_P (gnu_type
)
7827 && !TYPE_FAT_POINTER_P (gnu_type
))
7828 SET_TYPE_ADA_SIZE (gnu_type
, size
);
7831 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7832 a type or object whose present alignment is ALIGN. If this alignment is
7833 valid, return it. Otherwise, give an error and return ALIGN. */
7836 validate_alignment (Uint alignment
, Entity_Id gnat_entity
, unsigned int align
)
7838 unsigned int max_allowed_alignment
= get_target_maximum_allowed_alignment ();
7839 unsigned int new_align
;
7840 Node_Id gnat_error_node
;
7842 /* Don't worry about checking alignment if alignment was not specified
7843 by the source program and we already posted an error for this entity. */
7844 if (Error_Posted (gnat_entity
) && !Has_Alignment_Clause (gnat_entity
))
7847 /* Post the error on the alignment clause if any. Note, for the implicit
7848 base type of an array type, the alignment clause is on the first
7850 if (Present (Alignment_Clause (gnat_entity
)))
7851 gnat_error_node
= Expression (Alignment_Clause (gnat_entity
));
7853 else if (Is_Itype (gnat_entity
)
7854 && Is_Array_Type (gnat_entity
)
7855 && Etype (gnat_entity
) == gnat_entity
7856 && Present (Alignment_Clause (First_Subtype (gnat_entity
))))
7858 Expression (Alignment_Clause (First_Subtype (gnat_entity
)));
7861 gnat_error_node
= gnat_entity
;
7863 /* Within GCC, an alignment is an integer, so we must make sure a value is
7864 specified that fits in that range. Also, there is an upper bound to
7865 alignments we can support/allow. */
7866 if (!UI_Is_In_Int_Range (alignment
)
7867 || ((new_align
= UI_To_Int (alignment
)) > max_allowed_alignment
))
7868 post_error_ne_num ("largest supported alignment for& is ^",
7869 gnat_error_node
, gnat_entity
, max_allowed_alignment
);
7870 else if (!(Present (Alignment_Clause (gnat_entity
))
7871 && From_At_Mod (Alignment_Clause (gnat_entity
)))
7872 && new_align
* BITS_PER_UNIT
< align
)
7874 unsigned int double_align
;
7875 bool is_capped_double
, align_clause
;
7877 /* If the default alignment of "double" or larger scalar types is
7878 specifically capped and the new alignment is above the cap, do
7879 not post an error and change the alignment only if there is an
7880 alignment clause; this makes it possible to have the associated
7881 GCC type overaligned by default for performance reasons. */
7882 if ((double_align
= double_float_alignment
) > 0)
7885 = Is_Type (gnat_entity
) ? gnat_entity
: Etype (gnat_entity
);
7887 = is_double_float_or_array (gnat_type
, &align_clause
);
7889 else if ((double_align
= double_scalar_alignment
) > 0)
7892 = Is_Type (gnat_entity
) ? gnat_entity
: Etype (gnat_entity
);
7894 = is_double_scalar_or_array (gnat_type
, &align_clause
);
7897 is_capped_double
= align_clause
= false;
7899 if (is_capped_double
&& new_align
>= double_align
)
7902 align
= new_align
* BITS_PER_UNIT
;
7906 if (is_capped_double
)
7907 align
= double_align
* BITS_PER_UNIT
;
7909 post_error_ne_num ("alignment for& must be at least ^",
7910 gnat_error_node
, gnat_entity
,
7911 align
/ BITS_PER_UNIT
);
7916 new_align
= (new_align
> 0 ? new_align
* BITS_PER_UNIT
: 1);
7917 if (new_align
> align
)
7924 /* Verify that OBJECT, a type or decl, is something we can implement
7925 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7926 if we require atomic components. */
7929 check_ok_for_atomic (tree object
, Entity_Id gnat_entity
, bool comp_p
)
7931 Node_Id gnat_error_point
= gnat_entity
;
7933 enum machine_mode mode
;
7937 /* There are three case of what OBJECT can be. It can be a type, in which
7938 case we take the size, alignment and mode from the type. It can be a
7939 declaration that was indirect, in which case the relevant values are
7940 that of the type being pointed to, or it can be a normal declaration,
7941 in which case the values are of the decl. The code below assumes that
7942 OBJECT is either a type or a decl. */
7943 if (TYPE_P (object
))
7945 /* If this is an anonymous base type, nothing to check. Error will be
7946 reported on the source type. */
7947 if (!Comes_From_Source (gnat_entity
))
7950 mode
= TYPE_MODE (object
);
7951 align
= TYPE_ALIGN (object
);
7952 size
= TYPE_SIZE (object
);
7954 else if (DECL_BY_REF_P (object
))
7956 mode
= TYPE_MODE (TREE_TYPE (TREE_TYPE (object
)));
7957 align
= TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object
)));
7958 size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (object
)));
7962 mode
= DECL_MODE (object
);
7963 align
= DECL_ALIGN (object
);
7964 size
= DECL_SIZE (object
);
7967 /* Consider all floating-point types atomic and any types that that are
7968 represented by integers no wider than a machine word. */
7969 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
7970 || ((GET_MODE_CLASS (mode
) == MODE_INT
7971 || GET_MODE_CLASS (mode
) == MODE_PARTIAL_INT
)
7972 && GET_MODE_BITSIZE (mode
) <= BITS_PER_WORD
))
7975 /* For the moment, also allow anything that has an alignment equal
7976 to its size and which is smaller than a word. */
7977 if (size
&& TREE_CODE (size
) == INTEGER_CST
7978 && compare_tree_int (size
, align
) == 0
7979 && align
<= BITS_PER_WORD
)
7982 for (gnat_node
= First_Rep_Item (gnat_entity
); Present (gnat_node
);
7983 gnat_node
= Next_Rep_Item (gnat_node
))
7985 if (!comp_p
&& Nkind (gnat_node
) == N_Pragma
7986 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
7988 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
7989 else if (comp_p
&& Nkind (gnat_node
) == N_Pragma
7990 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
7991 == Pragma_Atomic_Components
))
7992 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
7996 post_error_ne ("atomic access to component of & cannot be guaranteed",
7997 gnat_error_point
, gnat_entity
);
7999 post_error_ne ("atomic access to & cannot be guaranteed",
8000 gnat_error_point
, gnat_entity
);
8004 /* Helper for the intrin compatibility checks family. Evaluate whether
8005 two types are definitely incompatible. */
8008 intrin_types_incompatible_p (tree t1
, tree t2
)
8010 enum tree_code code
;
8012 if (TYPE_MAIN_VARIANT (t1
) == TYPE_MAIN_VARIANT (t2
))
8015 if (TYPE_MODE (t1
) != TYPE_MODE (t2
))
8018 if (TREE_CODE (t1
) != TREE_CODE (t2
))
8021 code
= TREE_CODE (t1
);
8027 return TYPE_PRECISION (t1
) != TYPE_PRECISION (t2
);
8030 case REFERENCE_TYPE
:
8031 /* Assume designated types are ok. We'd need to account for char * and
8032 void * variants to do better, which could rapidly get messy and isn't
8033 clearly worth the effort. */
8043 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8044 on the Ada/builtin argument lists for the INB binding. */
8047 intrin_arglists_compatible_p (intrin_binding_t
* inb
)
8049 function_args_iterator ada_iter
, btin_iter
;
8051 function_args_iter_init (&ada_iter
, inb
->ada_fntype
);
8052 function_args_iter_init (&btin_iter
, inb
->btin_fntype
);
8054 /* Sequence position of the last argument we checked. */
8059 tree ada_type
= function_args_iter_cond (&ada_iter
);
8060 tree btin_type
= function_args_iter_cond (&btin_iter
);
8062 /* If we've exhausted both lists simultaneously, we're done. */
8063 if (ada_type
== NULL_TREE
&& btin_type
== NULL_TREE
)
8066 /* If one list is shorter than the other, they fail to match. */
8067 if (ada_type
== NULL_TREE
|| btin_type
== NULL_TREE
)
8070 /* If we're done with the Ada args and not with the internal builtin
8071 args, or the other way around, complain. */
8072 if (ada_type
== void_type_node
8073 && btin_type
!= void_type_node
)
8075 post_error ("?Ada arguments list too short!", inb
->gnat_entity
);
8079 if (btin_type
== void_type_node
8080 && ada_type
!= void_type_node
)
8082 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8083 inb
->gnat_entity
, inb
->gnat_entity
, argpos
);
8087 /* Otherwise, check that types match for the current argument. */
8089 if (intrin_types_incompatible_p (ada_type
, btin_type
))
8091 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8092 inb
->gnat_entity
, inb
->gnat_entity
, argpos
);
8097 function_args_iter_next (&ada_iter
);
8098 function_args_iter_next (&btin_iter
);
8104 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8105 on the Ada/builtin return values for the INB binding. */
8108 intrin_return_compatible_p (intrin_binding_t
* inb
)
8110 tree ada_return_type
= TREE_TYPE (inb
->ada_fntype
);
8111 tree btin_return_type
= TREE_TYPE (inb
->btin_fntype
);
8113 /* Accept function imported as procedure, common and convenient. */
8114 if (VOID_TYPE_P (ada_return_type
)
8115 && !VOID_TYPE_P (btin_return_type
))
8118 /* If return type is Address (integer type), map it to void *. */
8119 if (Is_Descendent_Of_Address (Etype (inb
->gnat_entity
)))
8120 ada_return_type
= ptr_void_type_node
;
8122 /* Check return types compatibility otherwise. Note that this
8123 handles void/void as well. */
8124 if (intrin_types_incompatible_p (btin_return_type
, ada_return_type
))
8126 post_error ("?intrinsic binding type mismatch on return value!",
8134 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8135 compatible. Issue relevant warnings when they are not.
8137 This is intended as a light check to diagnose the most obvious cases, not
8138 as a full fledged type compatibility predicate. It is the programmer's
8139 responsibility to ensure correctness of the Ada declarations in Imports,
8140 especially when binding straight to a compiler internal. */
8143 intrin_profiles_compatible_p (intrin_binding_t
* inb
)
8145 /* Check compatibility on return values and argument lists, each responsible
8146 for posting warnings as appropriate. Ensure use of the proper sloc for
8149 bool arglists_compatible_p
, return_compatible_p
;
8150 location_t saved_location
= input_location
;
8152 Sloc_to_locus (Sloc (inb
->gnat_entity
), &input_location
);
8154 return_compatible_p
= intrin_return_compatible_p (inb
);
8155 arglists_compatible_p
= intrin_arglists_compatible_p (inb
);
8157 input_location
= saved_location
;
8159 return return_compatible_p
&& arglists_compatible_p
;
8162 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
8163 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
8164 specified size for this field. POS_LIST is a position list describing
8165 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
8169 create_field_decl_from (tree old_field
, tree field_type
, tree record_type
,
8170 tree size
, tree pos_list
,
8171 vec
<subst_pair
> subst_list
)
8173 tree t
= TREE_VALUE (purpose_member (old_field
, pos_list
));
8174 tree pos
= TREE_VEC_ELT (t
, 0), bitpos
= TREE_VEC_ELT (t
, 2);
8175 unsigned int offset_align
= tree_low_cst (TREE_VEC_ELT (t
, 1), 1);
8176 tree new_pos
, new_field
;
8180 if (CONTAINS_PLACEHOLDER_P (pos
))
8181 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
8182 pos
= SUBSTITUTE_IN_EXPR (pos
, s
->discriminant
, s
->replacement
);
8184 /* If the position is now a constant, we can set it as the position of the
8185 field when we make it. Otherwise, we need to deal with it specially. */
8186 if (TREE_CONSTANT (pos
))
8187 new_pos
= bit_from_pos (pos
, bitpos
);
8189 new_pos
= NULL_TREE
;
8192 = create_field_decl (DECL_NAME (old_field
), field_type
, record_type
,
8193 size
, new_pos
, DECL_PACKED (old_field
),
8194 !DECL_NONADDRESSABLE_P (old_field
));
8198 normalize_offset (&pos
, &bitpos
, offset_align
);
8199 DECL_FIELD_OFFSET (new_field
) = pos
;
8200 DECL_FIELD_BIT_OFFSET (new_field
) = bitpos
;
8201 SET_DECL_OFFSET_ALIGN (new_field
, offset_align
);
8202 DECL_SIZE (new_field
) = size
;
8203 DECL_SIZE_UNIT (new_field
)
8204 = convert (sizetype
,
8205 size_binop (CEIL_DIV_EXPR
, size
, bitsize_unit_node
));
8206 layout_decl (new_field
, DECL_OFFSET_ALIGN (new_field
));
8209 DECL_INTERNAL_P (new_field
) = DECL_INTERNAL_P (old_field
);
8210 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field
, old_field
);
8211 DECL_DISCRIMINANT_NUMBER (new_field
) = DECL_DISCRIMINANT_NUMBER (old_field
);
8212 TREE_THIS_VOLATILE (new_field
) = TREE_THIS_VOLATILE (old_field
);
8217 /* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
8218 it is the minimal size the REP_PART must have. */
8221 create_rep_part (tree rep_type
, tree record_type
, tree min_size
)
8225 if (min_size
&& !tree_int_cst_lt (TYPE_SIZE (rep_type
), min_size
))
8226 min_size
= NULL_TREE
;
8228 field
= create_field_decl (get_identifier ("REP"), rep_type
, record_type
,
8229 min_size
, bitsize_zero_node
, 0, 1);
8230 DECL_INTERNAL_P (field
) = 1;
8235 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8238 get_rep_part (tree record_type
)
8240 tree field
= TYPE_FIELDS (record_type
);
8242 /* The REP part is the first field, internal, another record, and its name
8243 starts with an 'R'. */
8245 && DECL_INTERNAL_P (field
)
8246 && TREE_CODE (TREE_TYPE (field
)) == RECORD_TYPE
8247 && IDENTIFIER_POINTER (DECL_NAME (field
)) [0] == 'R')
8253 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8256 get_variant_part (tree record_type
)
8260 /* The variant part is the only internal field that is a qualified union. */
8261 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
8262 if (DECL_INTERNAL_P (field
)
8263 && TREE_CODE (TREE_TYPE (field
)) == QUAL_UNION_TYPE
)
8269 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8270 the list of variants to be used and RECORD_TYPE is the type of the parent.
8271 POS_LIST is a position list describing the layout of fields present in
8272 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8276 create_variant_part_from (tree old_variant_part
,
8277 vec
<variant_desc
> variant_list
,
8278 tree record_type
, tree pos_list
,
8279 vec
<subst_pair
> subst_list
)
8281 tree offset
= DECL_FIELD_OFFSET (old_variant_part
);
8282 tree old_union_type
= TREE_TYPE (old_variant_part
);
8283 tree new_union_type
, new_variant_part
;
8284 tree union_field_list
= NULL_TREE
;
8288 /* First create the type of the variant part from that of the old one. */
8289 new_union_type
= make_node (QUAL_UNION_TYPE
);
8290 TYPE_NAME (new_union_type
)
8291 = concat_name (TYPE_NAME (record_type
),
8292 IDENTIFIER_POINTER (DECL_NAME (old_variant_part
)));
8294 /* If the position of the variant part is constant, subtract it from the
8295 size of the type of the parent to get the new size. This manual CSE
8296 reduces the code size when not optimizing. */
8297 if (TREE_CODE (offset
) == INTEGER_CST
)
8299 tree bitpos
= DECL_FIELD_BIT_OFFSET (old_variant_part
);
8300 tree first_bit
= bit_from_pos (offset
, bitpos
);
8301 TYPE_SIZE (new_union_type
)
8302 = size_binop (MINUS_EXPR
, TYPE_SIZE (record_type
), first_bit
);
8303 TYPE_SIZE_UNIT (new_union_type
)
8304 = size_binop (MINUS_EXPR
, TYPE_SIZE_UNIT (record_type
),
8305 byte_from_pos (offset
, bitpos
));
8306 SET_TYPE_ADA_SIZE (new_union_type
,
8307 size_binop (MINUS_EXPR
, TYPE_ADA_SIZE (record_type
),
8309 TYPE_ALIGN (new_union_type
) = TYPE_ALIGN (old_union_type
);
8310 relate_alias_sets (new_union_type
, old_union_type
, ALIAS_SET_COPY
);
8313 copy_and_substitute_in_size (new_union_type
, old_union_type
, subst_list
);
8315 /* Now finish up the new variants and populate the union type. */
8316 FOR_EACH_VEC_ELT_REVERSE (variant_list
, i
, v
)
8318 tree old_field
= v
->field
, new_field
;
8319 tree old_variant
, old_variant_subpart
, new_variant
, field_list
;
8321 /* Skip variants that don't belong to this nesting level. */
8322 if (DECL_CONTEXT (old_field
) != old_union_type
)
8325 /* Retrieve the list of fields already added to the new variant. */
8326 new_variant
= v
->new_type
;
8327 field_list
= TYPE_FIELDS (new_variant
);
8329 /* If the old variant had a variant subpart, we need to create a new
8330 variant subpart and add it to the field list. */
8331 old_variant
= v
->type
;
8332 old_variant_subpart
= get_variant_part (old_variant
);
8333 if (old_variant_subpart
)
8335 tree new_variant_subpart
8336 = create_variant_part_from (old_variant_subpart
, variant_list
,
8337 new_variant
, pos_list
, subst_list
);
8338 DECL_CHAIN (new_variant_subpart
) = field_list
;
8339 field_list
= new_variant_subpart
;
8342 /* Finish up the new variant and create the field. No need for debug
8343 info thanks to the XVS type. */
8344 finish_record_type (new_variant
, nreverse (field_list
), 2, false);
8345 compute_record_mode (new_variant
);
8346 create_type_decl (TYPE_NAME (new_variant
), new_variant
, NULL
,
8347 true, false, Empty
);
8350 = create_field_decl_from (old_field
, new_variant
, new_union_type
,
8351 TYPE_SIZE (new_variant
),
8352 pos_list
, subst_list
);
8353 DECL_QUALIFIER (new_field
) = v
->qual
;
8354 DECL_INTERNAL_P (new_field
) = 1;
8355 DECL_CHAIN (new_field
) = union_field_list
;
8356 union_field_list
= new_field
;
8359 /* Finish up the union type and create the variant part. No need for debug
8360 info thanks to the XVS type. Note that we don't reverse the field list
8361 because VARIANT_LIST has been traversed in reverse order. */
8362 finish_record_type (new_union_type
, union_field_list
, 2, false);
8363 compute_record_mode (new_union_type
);
8364 create_type_decl (TYPE_NAME (new_union_type
), new_union_type
, NULL
,
8365 true, false, Empty
);
8368 = create_field_decl_from (old_variant_part
, new_union_type
, record_type
,
8369 TYPE_SIZE (new_union_type
),
8370 pos_list
, subst_list
);
8371 DECL_INTERNAL_P (new_variant_part
) = 1;
8373 /* With multiple discriminants it is possible for an inner variant to be
8374 statically selected while outer ones are not; in this case, the list
8375 of fields of the inner variant is not flattened and we end up with a
8376 qualified union with a single member. Drop the useless container. */
8377 if (!DECL_CHAIN (union_field_list
))
8379 DECL_CONTEXT (union_field_list
) = record_type
;
8380 DECL_FIELD_OFFSET (union_field_list
)
8381 = DECL_FIELD_OFFSET (new_variant_part
);
8382 DECL_FIELD_BIT_OFFSET (union_field_list
)
8383 = DECL_FIELD_BIT_OFFSET (new_variant_part
);
8384 SET_DECL_OFFSET_ALIGN (union_field_list
,
8385 DECL_OFFSET_ALIGN (new_variant_part
));
8386 new_variant_part
= union_field_list
;
8389 return new_variant_part
;
8392 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8393 which are both RECORD_TYPE, after applying the substitutions described
8397 copy_and_substitute_in_size (tree new_type
, tree old_type
,
8398 vec
<subst_pair
> subst_list
)
8403 TYPE_SIZE (new_type
) = TYPE_SIZE (old_type
);
8404 TYPE_SIZE_UNIT (new_type
) = TYPE_SIZE_UNIT (old_type
);
8405 SET_TYPE_ADA_SIZE (new_type
, TYPE_ADA_SIZE (old_type
));
8406 TYPE_ALIGN (new_type
) = TYPE_ALIGN (old_type
);
8407 relate_alias_sets (new_type
, old_type
, ALIAS_SET_COPY
);
8409 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type
)))
8410 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
8411 TYPE_SIZE (new_type
)
8412 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type
),
8413 s
->discriminant
, s
->replacement
);
8415 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type
)))
8416 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
8417 TYPE_SIZE_UNIT (new_type
)
8418 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type
),
8419 s
->discriminant
, s
->replacement
);
8421 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type
)))
8422 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
8424 (new_type
, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type
),
8425 s
->discriminant
, s
->replacement
));
8427 /* Finalize the size. */
8428 TYPE_SIZE (new_type
) = variable_size (TYPE_SIZE (new_type
));
8429 TYPE_SIZE_UNIT (new_type
) = variable_size (TYPE_SIZE_UNIT (new_type
));
8432 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8433 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8434 updated by replacing F with R.
8436 The function doesn't update the layout of the type, i.e. it assumes
8437 that the substitution is purely formal. That's why the replacement
8438 value R must itself contain a PLACEHOLDER_EXPR. */
8441 substitute_in_type (tree t
, tree f
, tree r
)
8445 gcc_assert (CONTAINS_PLACEHOLDER_P (r
));
8447 switch (TREE_CODE (t
))
8454 /* First the domain types of arrays. */
8455 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t
))
8456 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t
)))
8458 tree low
= SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t
), f
, r
);
8459 tree high
= SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t
), f
, r
);
8461 if (low
== TYPE_GCC_MIN_VALUE (t
) && high
== TYPE_GCC_MAX_VALUE (t
))
8465 TYPE_GCC_MIN_VALUE (nt
) = low
;
8466 TYPE_GCC_MAX_VALUE (nt
) = high
;
8468 if (TREE_CODE (t
) == INTEGER_TYPE
&& TYPE_INDEX_TYPE (t
))
8470 (nt
, substitute_in_type (TYPE_INDEX_TYPE (t
), f
, r
));
8475 /* Then the subtypes. */
8476 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t
))
8477 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t
)))
8479 tree low
= SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t
), f
, r
);
8480 tree high
= SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t
), f
, r
);
8482 if (low
== TYPE_RM_MIN_VALUE (t
) && high
== TYPE_RM_MAX_VALUE (t
))
8486 SET_TYPE_RM_MIN_VALUE (nt
, low
);
8487 SET_TYPE_RM_MAX_VALUE (nt
, high
);
8495 nt
= substitute_in_type (TREE_TYPE (t
), f
, r
);
8496 if (nt
== TREE_TYPE (t
))
8499 return build_complex_type (nt
);
8502 /* These should never show up here. */
8507 tree component
= substitute_in_type (TREE_TYPE (t
), f
, r
);
8508 tree domain
= substitute_in_type (TYPE_DOMAIN (t
), f
, r
);
8510 if (component
== TREE_TYPE (t
) && domain
== TYPE_DOMAIN (t
))
8513 nt
= build_nonshared_array_type (component
, domain
);
8514 TYPE_ALIGN (nt
) = TYPE_ALIGN (t
);
8515 TYPE_USER_ALIGN (nt
) = TYPE_USER_ALIGN (t
);
8516 SET_TYPE_MODE (nt
, TYPE_MODE (t
));
8517 TYPE_SIZE (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t
), f
, r
);
8518 TYPE_SIZE_UNIT (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t
), f
, r
);
8519 TYPE_NONALIASED_COMPONENT (nt
) = TYPE_NONALIASED_COMPONENT (t
);
8520 TYPE_MULTI_ARRAY_P (nt
) = TYPE_MULTI_ARRAY_P (t
);
8521 TYPE_CONVENTION_FORTRAN_P (nt
) = TYPE_CONVENTION_FORTRAN_P (t
);
8527 case QUAL_UNION_TYPE
:
8529 bool changed_field
= false;
8532 /* Start out with no fields, make new fields, and chain them
8533 in. If we haven't actually changed the type of any field,
8534 discard everything we've done and return the old type. */
8536 TYPE_FIELDS (nt
) = NULL_TREE
;
8538 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
8540 tree new_field
= copy_node (field
), new_n
;
8542 new_n
= substitute_in_type (TREE_TYPE (field
), f
, r
);
8543 if (new_n
!= TREE_TYPE (field
))
8545 TREE_TYPE (new_field
) = new_n
;
8546 changed_field
= true;
8549 new_n
= SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field
), f
, r
);
8550 if (new_n
!= DECL_FIELD_OFFSET (field
))
8552 DECL_FIELD_OFFSET (new_field
) = new_n
;
8553 changed_field
= true;
8556 /* Do the substitution inside the qualifier, if any. */
8557 if (TREE_CODE (t
) == QUAL_UNION_TYPE
)
8559 new_n
= SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field
), f
, r
);
8560 if (new_n
!= DECL_QUALIFIER (field
))
8562 DECL_QUALIFIER (new_field
) = new_n
;
8563 changed_field
= true;
8567 DECL_CONTEXT (new_field
) = nt
;
8568 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field
, field
);
8570 DECL_CHAIN (new_field
) = TYPE_FIELDS (nt
);
8571 TYPE_FIELDS (nt
) = new_field
;
8577 TYPE_FIELDS (nt
) = nreverse (TYPE_FIELDS (nt
));
8578 TYPE_SIZE (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t
), f
, r
);
8579 TYPE_SIZE_UNIT (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t
), f
, r
);
8580 SET_TYPE_ADA_SIZE (nt
, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t
), f
, r
));
8589 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8590 needed to represent the object. */
8593 rm_size (tree gnu_type
)
8595 /* For integral types, we store the RM size explicitly. */
8596 if (INTEGRAL_TYPE_P (gnu_type
) && TYPE_RM_SIZE (gnu_type
))
8597 return TYPE_RM_SIZE (gnu_type
);
8599 /* Return the RM size of the actual data plus the size of the template. */
8600 if (TREE_CODE (gnu_type
) == RECORD_TYPE
8601 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
8603 size_binop (PLUS_EXPR
,
8604 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)))),
8605 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
8607 /* For record or union types, we store the size explicitly. */
8608 if (RECORD_OR_UNION_TYPE_P (gnu_type
)
8609 && !TYPE_FAT_POINTER_P (gnu_type
)
8610 && TYPE_ADA_SIZE (gnu_type
))
8611 return TYPE_ADA_SIZE (gnu_type
);
8613 /* For other types, this is just the size. */
8614 return TYPE_SIZE (gnu_type
);
8617 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8618 fully-qualified name, possibly with type information encoding.
8619 Otherwise, return the name. */
8622 get_entity_name (Entity_Id gnat_entity
)
8624 Get_Encoded_Name (gnat_entity
);
8625 return get_identifier_with_length (Name_Buffer
, Name_Len
);
8628 /* Return an identifier representing the external name to be used for
8629 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8630 and the specified suffix. */
8633 create_concat_name (Entity_Id gnat_entity
, const char *suffix
)
8635 Entity_Kind kind
= Ekind (gnat_entity
);
8639 String_Template temp
= {1, (int) strlen (suffix
)};
8640 Fat_Pointer fp
= {suffix
, &temp
};
8641 Get_External_Name_With_Suffix (gnat_entity
, fp
);
8644 Get_External_Name (gnat_entity
, 0);
8646 /* A variable using the Stdcall convention lives in a DLL. We adjust
8647 its name to use the jump table, the _imp__NAME contains the address
8648 for the NAME variable. */
8649 if ((kind
== E_Variable
|| kind
== E_Constant
)
8650 && Has_Stdcall_Convention (gnat_entity
))
8652 const int len
= 6 + Name_Len
;
8653 char *new_name
= (char *) alloca (len
+ 1);
8654 strcpy (new_name
, "_imp__");
8655 strcat (new_name
, Name_Buffer
);
8656 return get_identifier_with_length (new_name
, len
);
8659 return get_identifier_with_length (Name_Buffer
, Name_Len
);
8662 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8663 string, return a new IDENTIFIER_NODE that is the concatenation of
8664 the name followed by "___" and the specified suffix. */
8667 concat_name (tree gnu_name
, const char *suffix
)
8669 const int len
= IDENTIFIER_LENGTH (gnu_name
) + 3 + strlen (suffix
);
8670 char *new_name
= (char *) alloca (len
+ 1);
8671 strcpy (new_name
, IDENTIFIER_POINTER (gnu_name
));
8672 strcat (new_name
, "___");
8673 strcat (new_name
, suffix
);
8674 return get_identifier_with_length (new_name
, len
);
8677 #include "gt-ada-decl.h"