1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2013, 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"
36 #include "diagnostic-core.h"
54 /* "stdcall" and "thiscall" conventions should be processed in a specific way
55 on 32-bit x86/Windows only. The macros below are helpers to avoid having
56 to check for a Windows specific attribute throughout this unit. */
58 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
60 #define Has_Stdcall_Convention(E) \
61 (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
62 #define Has_Thiscall_Convention(E) \
63 (!TARGET_64BIT && is_cplusplus_method (E))
65 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
66 #define Has_Thiscall_Convention(E) (is_cplusplus_method (E))
69 #define Has_Stdcall_Convention(E) 0
70 #define Has_Thiscall_Convention(E) 0
73 /* Stack realignment is necessary for functions with foreign conventions when
74 the ABI doesn't mandate as much as what the compiler assumes - that is, up
75 to PREFERRED_STACK_BOUNDARY.
77 Such realignment can be requested with a dedicated function type attribute
78 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
79 characterize the situations where the attribute should be set. We rely on
80 compiler configuration settings for 'main' to decide. */
82 #ifdef MAIN_STACK_BOUNDARY
83 #define FOREIGN_FORCE_REALIGN_STACK \
84 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
86 #define FOREIGN_FORCE_REALIGN_STACK 0
91 struct incomplete
*next
;
96 /* These variables are used to defer recursively expanding incomplete types
97 while we are processing an array, a record or a subprogram type. */
98 static int defer_incomplete_level
= 0;
99 static struct incomplete
*defer_incomplete_list
;
101 /* This variable is used to delay expanding From_Limited_With types until the
103 static struct incomplete
*defer_limited_with
;
105 typedef struct subst_pair_d
{
111 typedef struct variant_desc_d
{
112 /* The type of the variant. */
115 /* The associated field. */
118 /* The value of the qualifier. */
121 /* The type of the variant after transformation. */
126 /* A hash table used to cache the result of annotate_value. */
127 static GTY ((if_marked ("tree_int_map_marked_p"),
128 param_is (struct tree_int_map
))) htab_t annotate_value_cache
;
130 static bool allocatable_size_p (tree
, bool);
131 static void prepend_one_attribute_to (struct attrib
**,
132 enum attr_type
, tree
, tree
, Node_Id
);
133 static void prepend_attributes (Entity_Id
, struct attrib
**);
134 static tree
elaborate_expression (Node_Id
, Entity_Id
, tree
, bool, bool, bool);
135 static bool type_has_variable_size (tree
);
136 static tree
elaborate_expression_1 (tree
, Entity_Id
, tree
, bool, bool);
137 static tree
elaborate_expression_2 (tree
, Entity_Id
, tree
, bool, bool,
139 static tree
gnat_to_gnu_component_type (Entity_Id
, bool, bool);
140 static tree
gnat_to_gnu_param (Entity_Id
, Mechanism_Type
, Entity_Id
, bool,
142 static tree
gnat_to_gnu_field (Entity_Id
, tree
, int, bool, bool);
143 static bool same_discriminant_p (Entity_Id
, Entity_Id
);
144 static bool array_type_has_nonaliased_component (tree
, Entity_Id
);
145 static bool compile_time_known_address_p (Node_Id
);
146 static bool cannot_be_superflat_p (Node_Id
);
147 static bool constructor_address_p (tree
);
148 static bool components_to_record (tree
, Node_Id
, tree
, int, bool, bool, bool,
149 bool, bool, bool, bool, bool, tree
, tree
*);
150 static Uint
annotate_value (tree
);
151 static void annotate_rep (Entity_Id
, tree
);
152 static tree
build_position_list (tree
, bool, tree
, tree
, unsigned int, tree
);
153 static vec
<subst_pair
> build_subst_list (Entity_Id
, Entity_Id
, bool);
154 static vec
<variant_desc
> build_variant_list (tree
,
157 static tree
validate_size (Uint
, tree
, Entity_Id
, enum tree_code
, bool, bool);
158 static void set_rm_size (Uint
, tree
, Entity_Id
);
159 static unsigned int validate_alignment (Uint
, Entity_Id
, unsigned int);
160 static void check_ok_for_atomic (tree
, Entity_Id
, bool);
161 static tree
create_field_decl_from (tree
, tree
, tree
, tree
, tree
,
163 static tree
create_rep_part (tree
, tree
, tree
);
164 static tree
get_rep_part (tree
);
165 static tree
create_variant_part_from (tree
, vec
<variant_desc
> , tree
,
166 tree
, vec
<subst_pair
> );
167 static void copy_and_substitute_in_size (tree
, tree
, vec
<subst_pair
> );
169 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
170 to pass around calls performing profile compatibility checks. */
173 Entity_Id gnat_entity
; /* The Ada subprogram entity. */
174 tree ada_fntype
; /* The corresponding GCC type node. */
175 tree btin_fntype
; /* The GCC builtin function type node. */
178 static bool intrin_profiles_compatible_p (intrin_binding_t
*);
180 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
181 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
182 and associate the ..._DECL node with the input GNAT defining identifier.
184 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
185 initial value (in GCC tree form). This is optional for a variable. For
186 a renamed entity, GNU_EXPR gives the object being renamed.
188 DEFINITION is nonzero if this call is intended for a definition. This is
189 used for separate compilation where it is necessary to know whether an
190 external declaration or a definition must be created if the GCC equivalent
191 was not created previously. The value of 1 is normally used for a nonzero
192 DEFINITION, but a value of 2 is used in special circumstances, defined in
196 gnat_to_gnu_entity (Entity_Id gnat_entity
, tree gnu_expr
, int definition
)
198 /* Contains the kind of the input GNAT node. */
199 const Entity_Kind kind
= Ekind (gnat_entity
);
200 /* True if this is a type. */
201 const bool is_type
= IN (kind
, Type_Kind
);
202 /* True if debug info is requested for this entity. */
203 const bool debug_info_p
= Needs_Debug_Info (gnat_entity
);
204 /* True if this entity is to be considered as imported. */
205 const bool imported_p
206 = (Is_Imported (gnat_entity
) && No (Address_Clause (gnat_entity
)));
207 /* For a type, contains the equivalent GNAT node to be used in gigi. */
208 Entity_Id gnat_equiv_type
= Empty
;
209 /* Temporary used to walk the GNAT tree. */
211 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
212 This node will be associated with the GNAT node by calling at the end
213 of the `switch' statement. */
214 tree gnu_decl
= NULL_TREE
;
215 /* Contains the GCC type to be used for the GCC node. */
216 tree gnu_type
= NULL_TREE
;
217 /* Contains the GCC size tree to be used for the GCC node. */
218 tree gnu_size
= NULL_TREE
;
219 /* Contains the GCC name to be used for the GCC node. */
220 tree gnu_entity_name
;
221 /* True if we have already saved gnu_decl as a GNAT association. */
223 /* True if we incremented defer_incomplete_level. */
224 bool this_deferred
= false;
225 /* True if we incremented force_global. */
226 bool this_global
= false;
227 /* True if we should check to see if elaborated during processing. */
228 bool maybe_present
= false;
229 /* True if we made GNU_DECL and its type here. */
230 bool this_made_decl
= false;
231 /* Size and alignment of the GCC node, if meaningful. */
232 unsigned int esize
= 0, align
= 0;
233 /* Contains the list of attributes directly attached to the entity. */
234 struct attrib
*attr_list
= NULL
;
236 /* Since a use of an Itype is a definition, process it as such if it
237 is not in a with'ed unit. */
240 && Is_Itype (gnat_entity
)
241 && !present_gnu_tree (gnat_entity
)
242 && In_Extended_Main_Code_Unit (gnat_entity
))
244 /* Ensure that we are in a subprogram mentioned in the Scope chain of
245 this entity, our current scope is global, or we encountered a task
246 or entry (where we can't currently accurately check scoping). */
247 if (!current_function_decl
248 || DECL_ELABORATION_PROC_P (current_function_decl
))
250 process_type (gnat_entity
);
251 return get_gnu_tree (gnat_entity
);
254 for (gnat_temp
= Scope (gnat_entity
);
256 gnat_temp
= Scope (gnat_temp
))
258 if (Is_Type (gnat_temp
))
259 gnat_temp
= Underlying_Type (gnat_temp
);
261 if (Ekind (gnat_temp
) == E_Subprogram_Body
)
263 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp
)));
265 if (IN (Ekind (gnat_temp
), Subprogram_Kind
)
266 && Present (Protected_Body_Subprogram (gnat_temp
)))
267 gnat_temp
= Protected_Body_Subprogram (gnat_temp
);
269 if (Ekind (gnat_temp
) == E_Entry
270 || Ekind (gnat_temp
) == E_Entry_Family
271 || Ekind (gnat_temp
) == E_Task_Type
272 || (IN (Ekind (gnat_temp
), Subprogram_Kind
)
273 && present_gnu_tree (gnat_temp
)
274 && (current_function_decl
275 == gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0))))
277 process_type (gnat_entity
);
278 return get_gnu_tree (gnat_entity
);
282 /* This abort means the Itype has an incorrect scope, i.e. that its
283 scope does not correspond to the subprogram it is declared in. */
287 /* If we've already processed this entity, return what we got last time.
288 If we are defining the node, we should not have already processed it.
289 In that case, we will abort below when we try to save a new GCC tree
290 for this object. We also need to handle the case of getting a dummy
291 type when a Full_View exists but be careful so as not to trigger its
292 premature elaboration. */
293 if ((!definition
|| (is_type
&& imported_p
))
294 && present_gnu_tree (gnat_entity
))
296 gnu_decl
= get_gnu_tree (gnat_entity
);
298 if (TREE_CODE (gnu_decl
) == TYPE_DECL
299 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
))
300 && IN (kind
, Incomplete_Or_Private_Kind
)
301 && Present (Full_View (gnat_entity
))
302 && (present_gnu_tree (Full_View (gnat_entity
))
303 || No (Freeze_Node (Full_View (gnat_entity
)))))
306 = gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 0);
307 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
308 save_gnu_tree (gnat_entity
, gnu_decl
, false);
314 /* If this is a numeric or enumeral type, or an access type, a nonzero Esize
315 must be specified unless it was specified by the programmer. Exceptions
316 are for access-to-protected-subprogram types and all access subtypes, as
317 another GNAT type is used to lay out the GCC type for them. */
318 gcc_assert (!Unknown_Esize (gnat_entity
)
319 || Has_Size_Clause (gnat_entity
)
320 || (!IN (kind
, Numeric_Kind
)
321 && !IN (kind
, Enumeration_Kind
)
322 && (!IN (kind
, Access_Kind
)
323 || kind
== E_Access_Protected_Subprogram_Type
324 || kind
== E_Anonymous_Access_Protected_Subprogram_Type
325 || kind
== E_Access_Subtype
326 || type_annotate_only
)));
328 /* The RM size must be specified for all discrete and fixed-point types. */
329 gcc_assert (!(IN (kind
, Discrete_Or_Fixed_Point_Kind
)
330 && Unknown_RM_Size (gnat_entity
)));
332 /* If we get here, it means we have not yet done anything with this entity.
333 If we are not defining it, it must be a type or an entity that is defined
334 elsewhere or externally, otherwise we should have defined it already. */
335 gcc_assert (definition
336 || type_annotate_only
338 || kind
== E_Discriminant
339 || kind
== E_Component
341 || (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
342 || Is_Public (gnat_entity
));
344 /* Get the name of the entity and set up the line number and filename of
345 the original definition for use in any decl we make. */
346 gnu_entity_name
= get_entity_name (gnat_entity
);
347 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
349 /* For cases when we are not defining (i.e., we are referencing from
350 another compilation unit) public entities, show we are at global level
351 for the purpose of computing scopes. Don't do this for components or
352 discriminants since the relevant test is whether or not the record is
355 && kind
!= E_Component
356 && kind
!= E_Discriminant
357 && Is_Public (gnat_entity
)
358 && !Is_Statically_Allocated (gnat_entity
))
359 force_global
++, this_global
= true;
361 /* Handle any attributes directly attached to the entity. */
362 if (Has_Gigi_Rep_Item (gnat_entity
))
363 prepend_attributes (gnat_entity
, &attr_list
);
365 /* Do some common processing for types. */
368 /* Compute the equivalent type to be used in gigi. */
369 gnat_equiv_type
= Gigi_Equivalent_Type (gnat_entity
);
371 /* Machine_Attributes on types are expected to be propagated to
372 subtypes. The corresponding Gigi_Rep_Items are only attached
373 to the first subtype though, so we handle the propagation here. */
374 if (Base_Type (gnat_entity
) != gnat_entity
375 && !Is_First_Subtype (gnat_entity
)
376 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity
))))
377 prepend_attributes (First_Subtype (Base_Type (gnat_entity
)),
380 /* Compute a default value for the size of an elementary type. */
381 if (Known_Esize (gnat_entity
) && Is_Elementary_Type (gnat_entity
))
383 unsigned int max_esize
;
385 gcc_assert (UI_Is_In_Int_Range (Esize (gnat_entity
)));
386 esize
= UI_To_Int (Esize (gnat_entity
));
388 if (IN (kind
, Float_Kind
))
389 max_esize
= fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE
);
390 else if (IN (kind
, Access_Kind
))
391 max_esize
= POINTER_SIZE
* 2;
393 max_esize
= LONG_LONG_TYPE_SIZE
;
395 if (esize
> max_esize
)
403 /* If this is a use of a deferred constant without address clause,
404 get its full definition. */
406 && No (Address_Clause (gnat_entity
))
407 && Present (Full_View (gnat_entity
)))
410 = gnat_to_gnu_entity (Full_View (gnat_entity
), gnu_expr
, 0);
415 /* If we have an external constant that we are not defining, get the
416 expression that is was defined to represent. We may throw it away
417 later if it is not a constant. But do not retrieve the expression
418 if it is an allocator because the designated type might be dummy
421 && !No_Initialization (Declaration_Node (gnat_entity
))
422 && Present (Expression (Declaration_Node (gnat_entity
)))
423 && Nkind (Expression (Declaration_Node (gnat_entity
)))
426 bool went_into_elab_proc
= false;
427 int save_force_global
= force_global
;
429 /* The expression may contain N_Expression_With_Actions nodes and
430 thus object declarations from other units. In this case, even
431 though the expression will eventually be discarded since not a
432 constant, the declarations would be stuck either in the global
433 varpool or in the current scope. Therefore we force the local
434 context and create a fake scope that we'll zap at the end. */
435 if (!current_function_decl
)
437 current_function_decl
= get_elaboration_procedure ();
438 went_into_elab_proc
= true;
443 gnu_expr
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
446 force_global
= save_force_global
;
447 if (went_into_elab_proc
)
448 current_function_decl
= NULL_TREE
;
451 /* Ignore deferred constant definitions without address clause since
452 they are processed fully in the front-end. If No_Initialization
453 is set, this is not a deferred constant but a constant whose value
454 is built manually. And constants that are renamings are handled
458 && No (Address_Clause (gnat_entity
))
459 && !No_Initialization (Declaration_Node (gnat_entity
))
460 && No (Renamed_Object (gnat_entity
)))
462 gnu_decl
= error_mark_node
;
467 /* Ignore constant definitions already marked with the error node. See
468 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
471 && present_gnu_tree (gnat_entity
)
472 && get_gnu_tree (gnat_entity
) == error_mark_node
)
474 maybe_present
= true;
481 /* We used to special case VMS exceptions here to directly map them to
482 their associated condition code. Since this code had to be masked
483 dynamically to strip off the severity bits, this caused trouble in
484 the GCC/ZCX case because the "type" pointers we store in the tables
485 have to be static. We now don't special case here anymore, and let
486 the regular processing take place, which leaves us with a regular
487 exception data object for VMS exceptions too. The condition code
488 mapping is taken care of by the front end and the bitmasking by the
495 /* The GNAT record where the component was defined. */
496 Entity_Id gnat_record
= Underlying_Type (Scope (gnat_entity
));
498 /* If the variable is an inherited record component (in the case of
499 extended record types), just return the inherited entity, which
500 must be a FIELD_DECL. Likewise for discriminants.
501 For discriminants of untagged records which have explicit
502 stored discriminants, return the entity for the corresponding
503 stored discriminant. Also use Original_Record_Component
504 if the record has a private extension. */
505 if (Present (Original_Record_Component (gnat_entity
))
506 && Original_Record_Component (gnat_entity
) != gnat_entity
)
509 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity
),
510 gnu_expr
, definition
);
515 /* If the enclosing record has explicit stored discriminants,
516 then it is an untagged record. If the Corresponding_Discriminant
517 is not empty then this must be a renamed discriminant and its
518 Original_Record_Component must point to the corresponding explicit
519 stored discriminant (i.e. we should have taken the previous
521 else if (Present (Corresponding_Discriminant (gnat_entity
))
522 && Is_Tagged_Type (gnat_record
))
524 /* A tagged record has no explicit stored discriminants. */
525 gcc_assert (First_Discriminant (gnat_record
)
526 == First_Stored_Discriminant (gnat_record
));
528 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity
),
529 gnu_expr
, definition
);
534 else if (Present (CR_Discriminant (gnat_entity
))
535 && type_annotate_only
)
537 gnu_decl
= gnat_to_gnu_entity (CR_Discriminant (gnat_entity
),
538 gnu_expr
, definition
);
543 /* If the enclosing record has explicit stored discriminants, then
544 it is an untagged record. If the Corresponding_Discriminant
545 is not empty then this must be a renamed discriminant and its
546 Original_Record_Component must point to the corresponding explicit
547 stored discriminant (i.e. we should have taken the first
549 else if (Present (Corresponding_Discriminant (gnat_entity
))
550 && (First_Discriminant (gnat_record
)
551 != First_Stored_Discriminant (gnat_record
)))
554 /* Otherwise, if we are not defining this and we have no GCC type
555 for the containing record, make one for it. Then we should
556 have made our own equivalent. */
557 else if (!definition
&& !present_gnu_tree (gnat_record
))
559 /* ??? If this is in a record whose scope is a protected
560 type and we have an Original_Record_Component, use it.
561 This is a workaround for major problems in protected type
563 Entity_Id Scop
= Scope (Scope (gnat_entity
));
564 if ((Is_Protected_Type (Scop
)
565 || (Is_Private_Type (Scop
)
566 && Present (Full_View (Scop
))
567 && Is_Protected_Type (Full_View (Scop
))))
568 && Present (Original_Record_Component (gnat_entity
)))
571 = gnat_to_gnu_entity (Original_Record_Component
578 gnat_to_gnu_entity (Scope (gnat_entity
), NULL_TREE
, 0);
579 gnu_decl
= get_gnu_tree (gnat_entity
);
585 /* Here we have no GCC type and this is a reference rather than a
586 definition. This should never happen. Most likely the cause is
587 reference before declaration in the gnat tree for gnat_entity. */
591 case E_Loop_Parameter
:
592 case E_Out_Parameter
:
595 /* Simple variables, loop variables, Out parameters and exceptions. */
599 = ((kind
== E_Constant
|| kind
== E_Variable
)
600 && Is_True_Constant (gnat_entity
)
601 && !Treat_As_Volatile (gnat_entity
)
602 && (((Nkind (Declaration_Node (gnat_entity
))
603 == N_Object_Declaration
)
604 && Present (Expression (Declaration_Node (gnat_entity
))))
605 || Present (Renamed_Object (gnat_entity
))
607 bool inner_const_flag
= const_flag
;
608 bool static_p
= Is_Statically_Allocated (gnat_entity
);
609 bool mutable_p
= false;
610 bool used_by_ref
= false;
611 tree gnu_ext_name
= NULL_TREE
;
612 tree renamed_obj
= NULL_TREE
;
613 tree gnu_object_size
;
615 if (Present (Renamed_Object (gnat_entity
)) && !definition
)
617 if (kind
== E_Exception
)
618 gnu_expr
= gnat_to_gnu_entity (Renamed_Entity (gnat_entity
),
621 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_entity
));
624 /* Get the type after elaborating the renamed object. */
625 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
627 /* If this is a standard exception definition, then use the standard
628 exception type. This is necessary to make sure that imported and
629 exported views of exceptions are properly merged in LTO mode. */
630 if (TREE_CODE (TYPE_NAME (gnu_type
)) == TYPE_DECL
631 && DECL_NAME (TYPE_NAME (gnu_type
)) == exception_data_name_id
)
632 gnu_type
= except_type_node
;
634 /* For a debug renaming declaration, build a debug-only entity. */
635 if (Present (Debug_Renaming_Link (gnat_entity
)))
637 /* Force a non-null value to make sure the symbol is retained. */
638 tree value
= build1 (INDIRECT_REF
, gnu_type
,
640 build_pointer_type (gnu_type
),
641 integer_minus_one_node
));
642 gnu_decl
= build_decl (input_location
,
643 VAR_DECL
, gnu_entity_name
, gnu_type
);
644 SET_DECL_VALUE_EXPR (gnu_decl
, value
);
645 DECL_HAS_VALUE_EXPR_P (gnu_decl
) = 1;
646 gnat_pushdecl (gnu_decl
, gnat_entity
);
650 /* If this is a loop variable, its type should be the base type.
651 This is because the code for processing a loop determines whether
652 a normal loop end test can be done by comparing the bounds of the
653 loop against those of the base type, which is presumed to be the
654 size used for computation. But this is not correct when the size
655 of the subtype is smaller than the type. */
656 if (kind
== E_Loop_Parameter
)
657 gnu_type
= get_base_type (gnu_type
);
659 /* Reject non-renamed objects whose type is an unconstrained array or
660 any object whose type is a dummy type or void. */
661 if ((TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
662 && No (Renamed_Object (gnat_entity
)))
663 || TYPE_IS_DUMMY_P (gnu_type
)
664 || TREE_CODE (gnu_type
) == VOID_TYPE
)
666 gcc_assert (type_annotate_only
);
669 return error_mark_node
;
672 /* If an alignment is specified, use it if valid. Note that exceptions
673 are objects but don't have an alignment. We must do this before we
674 validate the size, since the alignment can affect the size. */
675 if (kind
!= E_Exception
&& Known_Alignment (gnat_entity
))
677 gcc_assert (Present (Alignment (gnat_entity
)));
679 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
680 TYPE_ALIGN (gnu_type
));
682 /* No point in changing the type if there is an address clause
683 as the final type of the object will be a reference type. */
684 if (Present (Address_Clause (gnat_entity
)))
688 tree orig_type
= gnu_type
;
691 = maybe_pad_type (gnu_type
, NULL_TREE
, align
, gnat_entity
,
692 false, false, definition
, true);
694 /* If a padding record was made, declare it now since it will
695 never be declared otherwise. This is necessary to ensure
696 that its subtrees are properly marked. */
697 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
698 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, true,
699 debug_info_p
, gnat_entity
);
703 /* If we are defining the object, see if it has a Size and validate it
704 if so. If we are not defining the object and a Size clause applies,
705 simply retrieve the value. We don't want to ignore the clause and
706 it is expected to have been validated already. Then get the new
709 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
,
710 gnat_entity
, VAR_DECL
, false,
711 Has_Size_Clause (gnat_entity
));
712 else if (Has_Size_Clause (gnat_entity
))
713 gnu_size
= UI_To_gnu (Esize (gnat_entity
), bitsizetype
);
718 = make_type_from_size (gnu_type
, gnu_size
,
719 Has_Biased_Representation (gnat_entity
));
721 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0))
722 gnu_size
= NULL_TREE
;
725 /* If this object has self-referential size, it must be a record with
726 a default discriminant. We are supposed to allocate an object of
727 the maximum size in this case, unless it is a constant with an
728 initializing expression, in which case we can get the size from
729 that. Note that the resulting size may still be a variable, so
730 this may end up with an indirect allocation. */
731 if (No (Renamed_Object (gnat_entity
))
732 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
734 if (gnu_expr
&& kind
== E_Constant
)
736 tree size
= TYPE_SIZE (TREE_TYPE (gnu_expr
));
737 if (CONTAINS_PLACEHOLDER_P (size
))
739 /* If the initializing expression is itself a constant,
740 despite having a nominal type with self-referential
741 size, we can get the size directly from it. */
742 if (TREE_CODE (gnu_expr
) == COMPONENT_REF
744 (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
745 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == VAR_DECL
746 && (TREE_READONLY (TREE_OPERAND (gnu_expr
, 0))
747 || DECL_READONLY_ONCE_ELAB
748 (TREE_OPERAND (gnu_expr
, 0))))
749 gnu_size
= DECL_SIZE (TREE_OPERAND (gnu_expr
, 0));
752 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_expr
);
757 /* We may have no GNU_EXPR because No_Initialization is
758 set even though there's an Expression. */
759 else if (kind
== E_Constant
760 && (Nkind (Declaration_Node (gnat_entity
))
761 == N_Object_Declaration
)
762 && Present (Expression (Declaration_Node (gnat_entity
))))
764 = TYPE_SIZE (gnat_to_gnu_type
766 (Expression (Declaration_Node (gnat_entity
)))));
769 gnu_size
= max_size (TYPE_SIZE (gnu_type
), true);
773 /* If we are at global level and the size isn't constant, call
774 elaborate_expression_1 to make a variable for it rather than
775 calculating it each time. */
776 if (global_bindings_p () && !TREE_CONSTANT (gnu_size
))
777 gnu_size
= elaborate_expression_1 (gnu_size
, gnat_entity
,
778 get_identifier ("SIZE"),
782 /* If the size is zero byte, make it one byte since some linkers have
783 troubles with zero-sized objects. If the object will have a
784 template, that will make it nonzero so don't bother. Also avoid
785 doing that for an object renaming or an object with an address
786 clause, as we would lose useful information on the view size
787 (e.g. for null array slices) and we are not allocating the object
790 && integer_zerop (gnu_size
)
791 && !TREE_OVERFLOW (gnu_size
))
792 || (TYPE_SIZE (gnu_type
)
793 && integer_zerop (TYPE_SIZE (gnu_type
))
794 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type
))))
795 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
796 || !Is_Array_Type (Etype (gnat_entity
)))
797 && No (Renamed_Object (gnat_entity
))
798 && No (Address_Clause (gnat_entity
)))
799 gnu_size
= bitsize_unit_node
;
801 /* If this is an object with no specified size and alignment, and
802 if either it is atomic or we are not optimizing alignment for
803 space and it is composite and not an exception, an Out parameter
804 or a reference to another object, and the size of its type is a
805 constant, set the alignment to the smallest one which is not
806 smaller than the size, with an appropriate cap. */
807 if (!gnu_size
&& align
== 0
808 && (Is_Atomic (gnat_entity
)
809 || (!Optimize_Alignment_Space (gnat_entity
)
810 && kind
!= E_Exception
811 && kind
!= E_Out_Parameter
812 && Is_Composite_Type (Etype (gnat_entity
))
813 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
814 && !Is_Exported (gnat_entity
)
816 && No (Renamed_Object (gnat_entity
))
817 && No (Address_Clause (gnat_entity
))))
818 && TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
)
820 unsigned int size_cap
, align_cap
;
822 /* No point in promoting the alignment if this doesn't prevent
823 BLKmode access to the object, in particular block copy, as
824 this will for example disable the NRV optimization for it.
825 No point in jumping through all the hoops needed in order
826 to support BIGGEST_ALIGNMENT if we don't really have to.
827 So we cap to the smallest alignment that corresponds to
828 a known efficient memory access pattern of the target. */
829 if (Is_Atomic (gnat_entity
))
832 align_cap
= BIGGEST_ALIGNMENT
;
836 size_cap
= MAX_FIXED_MODE_SIZE
;
837 align_cap
= get_mode_alignment (ptr_mode
);
840 if (!tree_fits_uhwi_p (TYPE_SIZE (gnu_type
))
841 || compare_tree_int (TYPE_SIZE (gnu_type
), size_cap
) > 0)
843 else if (compare_tree_int (TYPE_SIZE (gnu_type
), align_cap
) > 0)
846 align
= ceil_pow2 (tree_to_uhwi (TYPE_SIZE (gnu_type
)));
848 /* But make sure not to under-align the object. */
849 if (align
<= TYPE_ALIGN (gnu_type
))
852 /* And honor the minimum valid atomic alignment, if any. */
853 #ifdef MINIMUM_ATOMIC_ALIGNMENT
854 else if (align
< MINIMUM_ATOMIC_ALIGNMENT
)
855 align
= MINIMUM_ATOMIC_ALIGNMENT
;
859 /* If the object is set to have atomic components, find the component
860 type and validate it.
862 ??? Note that we ignore Has_Volatile_Components on objects; it's
863 not at all clear what to do in that case. */
864 if (Has_Atomic_Components (gnat_entity
))
866 tree gnu_inner
= (TREE_CODE (gnu_type
) == ARRAY_TYPE
867 ? TREE_TYPE (gnu_type
) : gnu_type
);
869 while (TREE_CODE (gnu_inner
) == ARRAY_TYPE
870 && TYPE_MULTI_ARRAY_P (gnu_inner
))
871 gnu_inner
= TREE_TYPE (gnu_inner
);
873 check_ok_for_atomic (gnu_inner
, gnat_entity
, true);
876 /* Now check if the type of the object allows atomic access. Note
877 that we must test the type, even if this object has size and
878 alignment to allow such access, because we will be going inside
879 the padded record to assign to the object. We could fix this by
880 always copying via an intermediate value, but it's not clear it's
882 if (Is_Atomic (gnat_entity
))
883 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
885 /* If this is an aliased object with an unconstrained nominal subtype,
886 make a type that includes the template. */
887 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
888 && Is_Array_Type (Etype (gnat_entity
))
889 && !type_annotate_only
)
892 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity
)));
894 = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array
),
896 concat_name (gnu_entity_name
,
901 /* ??? If this is an object of CW type initialized to a value, try to
902 ensure that the object is sufficient aligned for this value, but
903 without pessimizing the allocation. This is a kludge necessary
904 because we don't support dynamic alignment. */
906 && Ekind (Etype (gnat_entity
)) == E_Class_Wide_Subtype
907 && No (Renamed_Object (gnat_entity
))
908 && No (Address_Clause (gnat_entity
)))
909 align
= get_target_system_allocator_alignment () * BITS_PER_UNIT
;
911 #ifdef MINIMUM_ATOMIC_ALIGNMENT
912 /* If the size is a constant and no alignment is specified, force
913 the alignment to be the minimum valid atomic alignment. The
914 restriction on constant size avoids problems with variable-size
915 temporaries; if the size is variable, there's no issue with
916 atomic access. Also don't do this for a constant, since it isn't
917 necessary and can interfere with constant replacement. Finally,
918 do not do it for Out parameters since that creates an
919 size inconsistency with In parameters. */
921 && MINIMUM_ATOMIC_ALIGNMENT
> TYPE_ALIGN (gnu_type
)
922 && !FLOAT_TYPE_P (gnu_type
)
923 && !const_flag
&& No (Renamed_Object (gnat_entity
))
924 && !imported_p
&& No (Address_Clause (gnat_entity
))
925 && kind
!= E_Out_Parameter
926 && (gnu_size
? TREE_CODE (gnu_size
) == INTEGER_CST
927 : TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
))
928 align
= MINIMUM_ATOMIC_ALIGNMENT
;
931 /* Make a new type with the desired size and alignment, if needed.
932 But do not take into account alignment promotions to compute the
933 size of the object. */
934 gnu_object_size
= gnu_size
? gnu_size
: TYPE_SIZE (gnu_type
);
935 if (gnu_size
|| align
> 0)
937 tree orig_type
= gnu_type
;
939 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
940 false, false, definition
, true);
942 /* If a padding record was made, declare it now since it will
943 never be declared otherwise. This is necessary to ensure
944 that its subtrees are properly marked. */
945 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
946 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, true,
947 debug_info_p
, gnat_entity
);
950 /* If this is a renaming, avoid as much as possible to create a new
951 object. However, in several cases, creating it is required.
952 This processing needs to be applied to the raw expression so
953 as to make it more likely to rename the underlying object. */
954 if (Present (Renamed_Object (gnat_entity
)))
956 bool create_normal_object
= false;
958 /* If the renamed object had padding, strip off the reference
959 to the inner object and reset our type. */
960 if ((TREE_CODE (gnu_expr
) == COMPONENT_REF
961 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
962 /* Strip useless conversions around the object. */
963 || gnat_useless_type_conversion (gnu_expr
))
965 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
966 gnu_type
= TREE_TYPE (gnu_expr
);
969 /* Or else, if the renamed object has an unconstrained type with
970 default discriminant, use the padded type. */
971 else if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_expr
))
972 && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_expr
)))
974 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
975 gnu_type
= TREE_TYPE (gnu_expr
);
977 /* Case 1: If this is a constant renaming stemming from a function
978 call, treat it as a normal object whose initial value is what
979 is being renamed. RM 3.3 says that the result of evaluating a
980 function call is a constant object. As a consequence, it can
981 be the inner object of a constant renaming. In this case, the
982 renaming must be fully instantiated, i.e. it cannot be a mere
983 reference to (part of) an existing object. */
986 tree inner_object
= gnu_expr
;
987 while (handled_component_p (inner_object
))
988 inner_object
= TREE_OPERAND (inner_object
, 0);
989 if (TREE_CODE (inner_object
) == CALL_EXPR
)
990 create_normal_object
= true;
993 /* Otherwise, see if we can proceed with a stabilized version of
994 the renamed entity or if we need to make a new object. */
995 if (!create_normal_object
)
997 tree maybe_stable_expr
= NULL_TREE
;
1000 /* Case 2: If the renaming entity need not be materialized and
1001 the renamed expression is something we can stabilize, use
1002 that for the renaming. At the global level, we can only do
1003 this if we know no SAVE_EXPRs need be made, because the
1004 expression we return might be used in arbitrary conditional
1005 branches so we must force the evaluation of the SAVE_EXPRs
1006 immediately and this requires a proper function context.
1007 Note that an external constant is at the global level. */
1008 if (!Materialize_Entity (gnat_entity
)
1009 && (!((!definition
&& kind
== E_Constant
)
1010 || global_bindings_p ())
1011 || (staticp (gnu_expr
)
1012 && !TREE_SIDE_EFFECTS (gnu_expr
))))
1015 = gnat_stabilize_reference (gnu_expr
, true, &stable
);
1019 /* ??? No DECL_EXPR is created so we need to mark
1020 the expression manually lest it is shared. */
1021 if ((!definition
&& kind
== E_Constant
)
1022 || global_bindings_p ())
1023 MARK_VISITED (maybe_stable_expr
);
1024 gnu_decl
= maybe_stable_expr
;
1025 save_gnu_tree (gnat_entity
, gnu_decl
, true);
1027 annotate_object (gnat_entity
, gnu_type
, NULL_TREE
,
1029 /* This assertion will fail if the renamed object
1030 isn't aligned enough as to make it possible to
1031 honor the alignment set on the renaming. */
1034 unsigned int renamed_align
1036 ? DECL_ALIGN (gnu_decl
)
1037 : TYPE_ALIGN (TREE_TYPE (gnu_decl
));
1038 gcc_assert (renamed_align
>= align
);
1043 /* The stabilization failed. Keep maybe_stable_expr
1044 untouched here to let the pointer case below know
1045 about that failure. */
1048 /* Case 3: If this is a constant renaming and creating a
1049 new object is allowed and cheap, treat it as a normal
1050 object whose initial value is what is being renamed. */
1052 && !Is_Composite_Type
1053 (Underlying_Type (Etype (gnat_entity
))))
1056 /* Case 4: Make this into a constant pointer to the object we
1057 are to rename and attach the object to the pointer if it is
1058 something we can stabilize.
1060 From the proper scope, attached objects will be referenced
1061 directly instead of indirectly via the pointer to avoid
1062 subtle aliasing problems with non-addressable entities.
1063 They have to be stable because we must not evaluate the
1064 variables in the expression every time the renaming is used.
1065 The pointer is called a "renaming" pointer in this case.
1067 In the rare cases where we cannot stabilize the renamed
1068 object, we just make a "bare" pointer, and the renamed
1069 entity is always accessed indirectly through it. */
1072 /* We need to preserve the volatileness of the renamed
1073 object through the indirection. */
1074 if (TREE_THIS_VOLATILE (gnu_expr
)
1075 && !TYPE_VOLATILE (gnu_type
))
1077 = build_qualified_type (gnu_type
,
1078 (TYPE_QUALS (gnu_type
)
1079 | TYPE_QUAL_VOLATILE
));
1080 gnu_type
= build_reference_type (gnu_type
);
1081 inner_const_flag
= TREE_READONLY (gnu_expr
);
1084 /* If the previous attempt at stabilizing failed, there
1085 is no point in trying again and we reuse the result
1086 without attaching it to the pointer. In this case it
1087 will only be used as the initializing expression of
1088 the pointer and thus needs no special treatment with
1089 regard to multiple evaluations. */
1090 if (maybe_stable_expr
)
1093 /* Otherwise, try to stabilize and attach the expression
1094 to the pointer if the stabilization succeeds.
1096 Note that this might introduce SAVE_EXPRs and we don't
1097 check whether we're at the global level or not. This
1098 is fine since we are building a pointer initializer and
1099 neither the pointer nor the initializing expression can
1100 be accessed before the pointer elaboration has taken
1101 place in a correct program.
1103 These SAVE_EXPRs will be evaluated at the right place
1104 by either the evaluation of the initializer for the
1105 non-global case or the elaboration code for the global
1106 case, and will be attached to the elaboration procedure
1107 in the latter case. */
1111 = gnat_stabilize_reference (gnu_expr
, true, &stable
);
1114 renamed_obj
= maybe_stable_expr
;
1116 /* Attaching is actually performed downstream, as soon
1117 as we have a VAR_DECL for the pointer we make. */
1120 if (type_annotate_only
1121 && TREE_CODE (maybe_stable_expr
) == ERROR_MARK
)
1122 gnu_expr
= NULL_TREE
;
1124 gnu_expr
= build_unary_op (ADDR_EXPR
, gnu_type
,
1127 gnu_size
= NULL_TREE
;
1133 /* Make a volatile version of this object's type if we are to make
1134 the object volatile. We also interpret 13.3(19) conservatively
1135 and disallow any optimizations for such a non-constant object. */
1136 if ((Treat_As_Volatile (gnat_entity
)
1138 && gnu_type
!= except_type_node
1139 && (Is_Exported (gnat_entity
)
1141 || Present (Address_Clause (gnat_entity
)))))
1142 && !TYPE_VOLATILE (gnu_type
))
1143 gnu_type
= build_qualified_type (gnu_type
,
1144 (TYPE_QUALS (gnu_type
)
1145 | TYPE_QUAL_VOLATILE
));
1147 /* If we are defining an aliased object whose nominal subtype is
1148 unconstrained, the object is a record that contains both the
1149 template and the object. If there is an initializer, it will
1150 have already been converted to the right type, but we need to
1151 create the template if there is no initializer. */
1154 && TREE_CODE (gnu_type
) == RECORD_TYPE
1155 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
1156 /* Beware that padding might have been introduced above. */
1157 || (TYPE_PADDING_P (gnu_type
)
1158 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
1160 && TYPE_CONTAINS_TEMPLATE_P
1161 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))))
1164 = TYPE_PADDING_P (gnu_type
)
1165 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
1166 : TYPE_FIELDS (gnu_type
);
1167 vec
<constructor_elt
, va_gc
> *v
;
1169 tree t
= build_template (TREE_TYPE (template_field
),
1170 TREE_TYPE (DECL_CHAIN (template_field
)),
1172 CONSTRUCTOR_APPEND_ELT (v
, template_field
, t
);
1173 gnu_expr
= gnat_build_constructor (gnu_type
, v
);
1176 /* Convert the expression to the type of the object except in the
1177 case where the object's type is unconstrained or the object's type
1178 is a padded record whose field is of self-referential size. In
1179 the former case, converting will generate unnecessary evaluations
1180 of the CONSTRUCTOR to compute the size and in the latter case, we
1181 want to only copy the actual data. Also don't convert to a record
1182 type with a variant part from a record type without one, to keep
1183 the object simpler. */
1185 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1186 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1187 && !(TYPE_IS_PADDING_P (gnu_type
)
1188 && CONTAINS_PLACEHOLDER_P
1189 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))
1190 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1191 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
1192 && get_variant_part (gnu_type
) != NULL_TREE
1193 && get_variant_part (TREE_TYPE (gnu_expr
)) == NULL_TREE
))
1194 gnu_expr
= convert (gnu_type
, gnu_expr
);
1196 /* If this is a pointer that doesn't have an initializing expression,
1197 initialize it to NULL, unless the object is imported. */
1199 && (POINTER_TYPE_P (gnu_type
) || TYPE_IS_FAT_POINTER_P (gnu_type
))
1201 && !Is_Imported (gnat_entity
))
1202 gnu_expr
= integer_zero_node
;
1204 /* If we are defining the object and it has an Address clause, we must
1205 either get the address expression from the saved GCC tree for the
1206 object if it has a Freeze node, or elaborate the address expression
1207 here since the front-end has guaranteed that the elaboration has no
1208 effects in this case. */
1209 if (definition
&& Present (Address_Clause (gnat_entity
)))
1211 Node_Id gnat_expr
= Expression (Address_Clause (gnat_entity
));
1213 = present_gnu_tree (gnat_entity
)
1214 ? get_gnu_tree (gnat_entity
) : gnat_to_gnu (gnat_expr
);
1216 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
1218 /* Ignore the size. It's either meaningless or was handled
1220 gnu_size
= NULL_TREE
;
1221 /* Convert the type of the object to a reference type that can
1222 alias everything as per 13.3(19). */
1224 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1225 gnu_address
= convert (gnu_type
, gnu_address
);
1228 = !Is_Public (gnat_entity
)
1229 || compile_time_known_address_p (gnat_expr
);
1231 /* If this is a deferred constant, the initializer is attached to
1233 if (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
1236 (Expression (Declaration_Node (Full_View (gnat_entity
))));
1238 /* If we don't have an initializing expression for the underlying
1239 variable, the initializing expression for the pointer is the
1240 specified address. Otherwise, we have to make a COMPOUND_EXPR
1241 to assign both the address and the initial value. */
1243 gnu_expr
= gnu_address
;
1246 = build2 (COMPOUND_EXPR
, gnu_type
,
1248 (MODIFY_EXPR
, NULL_TREE
,
1249 build_unary_op (INDIRECT_REF
, NULL_TREE
,
1255 /* If it has an address clause and we are not defining it, mark it
1256 as an indirect object. Likewise for Stdcall objects that are
1258 if ((!definition
&& Present (Address_Clause (gnat_entity
)))
1259 || (Is_Imported (gnat_entity
)
1260 && Has_Stdcall_Convention (gnat_entity
)))
1262 /* Convert the type of the object to a reference type that can
1263 alias everything as per 13.3(19). */
1265 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1266 gnu_size
= NULL_TREE
;
1268 /* No point in taking the address of an initializing expression
1269 that isn't going to be used. */
1270 gnu_expr
= NULL_TREE
;
1272 /* If it has an address clause whose value is known at compile
1273 time, make the object a CONST_DECL. This will avoid a
1274 useless dereference. */
1275 if (Present (Address_Clause (gnat_entity
)))
1277 Node_Id gnat_address
1278 = Expression (Address_Clause (gnat_entity
));
1280 if (compile_time_known_address_p (gnat_address
))
1282 gnu_expr
= gnat_to_gnu (gnat_address
);
1290 /* If we are at top level and this object is of variable size,
1291 make the actual type a hidden pointer to the real type and
1292 make the initializer be a memory allocation and initialization.
1293 Likewise for objects we aren't defining (presumed to be
1294 external references from other packages), but there we do
1295 not set up an initialization.
1297 If the object's size overflows, make an allocator too, so that
1298 Storage_Error gets raised. Note that we will never free
1299 such memory, so we presume it never will get allocated. */
1300 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type
),
1301 global_bindings_p ()
1305 && !allocatable_size_p (convert (sizetype
,
1307 (CEIL_DIV_EXPR
, gnu_size
,
1308 bitsize_unit_node
)),
1309 global_bindings_p ()
1313 gnu_type
= build_reference_type (gnu_type
);
1314 gnu_size
= NULL_TREE
;
1317 /* In case this was a aliased object whose nominal subtype is
1318 unconstrained, the pointer above will be a thin pointer and
1319 build_allocator will automatically make the template.
1321 If we have a template initializer only (that we made above),
1322 pretend there is none and rely on what build_allocator creates
1323 again anyway. Otherwise (if we have a full initializer), get
1324 the data part and feed that to build_allocator.
1326 If we are elaborating a mutable object, tell build_allocator to
1327 ignore a possibly simpler size from the initializer, if any, as
1328 we must allocate the maximum possible size in this case. */
1329 if (definition
&& !imported_p
)
1331 tree gnu_alloc_type
= TREE_TYPE (gnu_type
);
1333 if (TREE_CODE (gnu_alloc_type
) == RECORD_TYPE
1334 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type
))
1337 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type
)));
1339 if (TREE_CODE (gnu_expr
) == CONSTRUCTOR
1340 && 1 == vec_safe_length (CONSTRUCTOR_ELTS (gnu_expr
)))
1344 = build_component_ref
1345 (gnu_expr
, NULL_TREE
,
1346 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr
))),
1350 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type
)) == INTEGER_CST
1351 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_alloc_type
)))
1352 post_error ("?`Storage_Error` will be raised at run time!",
1356 = build_allocator (gnu_alloc_type
, gnu_expr
, gnu_type
,
1357 Empty
, Empty
, gnat_entity
, mutable_p
);
1362 gnu_expr
= NULL_TREE
;
1367 /* If this object would go into the stack and has an alignment larger
1368 than the largest stack alignment the back-end can honor, resort to
1369 a variable of "aligning type". */
1370 if (!global_bindings_p () && !static_p
&& definition
1371 && !imported_p
&& TYPE_ALIGN (gnu_type
) > BIGGEST_ALIGNMENT
)
1373 /* Create the new variable. No need for extra room before the
1374 aligned field as this is in automatic storage. */
1376 = make_aligning_type (gnu_type
, TYPE_ALIGN (gnu_type
),
1377 TYPE_SIZE_UNIT (gnu_type
),
1378 BIGGEST_ALIGNMENT
, 0, gnat_entity
);
1380 = create_var_decl (create_concat_name (gnat_entity
, "ALIGN"),
1381 NULL_TREE
, gnu_new_type
, NULL_TREE
, false,
1382 false, false, false, NULL
, gnat_entity
);
1384 /* Initialize the aligned field if we have an initializer. */
1387 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
1389 (gnu_new_var
, NULL_TREE
,
1390 TYPE_FIELDS (gnu_new_type
), false),
1394 /* And setup this entity as a reference to the aligned field. */
1395 gnu_type
= build_reference_type (gnu_type
);
1398 (ADDR_EXPR
, gnu_type
,
1399 build_component_ref (gnu_new_var
, NULL_TREE
,
1400 TYPE_FIELDS (gnu_new_type
), false));
1402 gnu_size
= NULL_TREE
;
1407 /* If this is an aliased object with an unconstrained nominal subtype,
1408 we make its type a thin reference, i.e. the reference counterpart
1409 of a thin pointer, so that it points to the array part. This is
1410 aimed at making it easier for the debugger to decode the object.
1411 Note that we have to do that this late because of the couple of
1412 allocation adjustments that might be made just above. */
1413 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
1414 && Is_Array_Type (Etype (gnat_entity
))
1415 && !type_annotate_only
)
1418 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity
)));
1420 /* In case the object with the template has already been allocated
1421 just above, we have nothing to do here. */
1422 if (!TYPE_IS_THIN_POINTER_P (gnu_type
))
1425 = create_var_decl (concat_name (gnu_entity_name
, "UNC"),
1426 NULL_TREE
, gnu_type
, gnu_expr
,
1427 const_flag
, Is_Public (gnat_entity
),
1428 imported_p
|| !definition
, static_p
,
1431 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_unc_var
);
1432 TREE_CONSTANT (gnu_expr
) = 1;
1434 gnu_size
= NULL_TREE
;
1440 = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array
));
1444 gnu_type
= build_qualified_type (gnu_type
, (TYPE_QUALS (gnu_type
)
1445 | TYPE_QUAL_CONST
));
1447 /* Convert the expression to the type of the object except in the
1448 case where the object's type is unconstrained or the object's type
1449 is a padded record whose field is of self-referential size. In
1450 the former case, converting will generate unnecessary evaluations
1451 of the CONSTRUCTOR to compute the size and in the latter case, we
1452 want to only copy the actual data. Also don't convert to a record
1453 type with a variant part from a record type without one, to keep
1454 the object simpler. */
1456 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1457 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1458 && !(TYPE_IS_PADDING_P (gnu_type
)
1459 && CONTAINS_PLACEHOLDER_P
1460 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))
1461 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1462 && TREE_CODE (TREE_TYPE (gnu_expr
)) == RECORD_TYPE
1463 && get_variant_part (gnu_type
) != NULL_TREE
1464 && get_variant_part (TREE_TYPE (gnu_expr
)) == NULL_TREE
))
1465 gnu_expr
= convert (gnu_type
, gnu_expr
);
1467 /* If this name is external or there was a name specified, use it,
1468 unless this is a VMS exception object since this would conflict
1469 with the symbol we need to export in addition. Don't use the
1470 Interface_Name if there is an address clause (see CD30005). */
1471 if (!Is_VMS_Exception (gnat_entity
)
1472 && ((Present (Interface_Name (gnat_entity
))
1473 && No (Address_Clause (gnat_entity
)))
1474 || (Is_Public (gnat_entity
)
1475 && (!Is_Imported (gnat_entity
)
1476 || Is_Exported (gnat_entity
)))))
1477 gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
1479 /* If this is an aggregate constant initialized to a constant, force it
1480 to be statically allocated. This saves an initialization copy. */
1483 && gnu_expr
&& TREE_CONSTANT (gnu_expr
)
1484 && AGGREGATE_TYPE_P (gnu_type
)
1485 && tree_fits_uhwi_p (TYPE_SIZE_UNIT (gnu_type
))
1486 && !(TYPE_IS_PADDING_P (gnu_type
)
1487 && !tree_fits_uhwi_p (TYPE_SIZE_UNIT
1488 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))))
1491 /* Now create the variable or the constant and set various flags. */
1493 = create_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
1494 gnu_expr
, const_flag
, Is_Public (gnat_entity
),
1495 imported_p
|| !definition
, static_p
, attr_list
,
1497 DECL_BY_REF_P (gnu_decl
) = used_by_ref
;
1498 DECL_POINTS_TO_READONLY_P (gnu_decl
) = used_by_ref
&& inner_const_flag
;
1499 DECL_CAN_NEVER_BE_NULL_P (gnu_decl
) = Can_Never_Be_Null (gnat_entity
);
1501 /* If we are defining an Out parameter and optimization isn't enabled,
1502 create a fake PARM_DECL for debugging purposes and make it point to
1503 the VAR_DECL. Suppress debug info for the latter but make sure it
1504 will live in memory so that it can be accessed from within the
1505 debugger through the PARM_DECL. */
1506 if (kind
== E_Out_Parameter
1510 && !flag_generate_lto
)
1512 tree param
= create_param_decl (gnu_entity_name
, gnu_type
, false);
1513 gnat_pushdecl (param
, gnat_entity
);
1514 SET_DECL_VALUE_EXPR (param
, gnu_decl
);
1515 DECL_HAS_VALUE_EXPR_P (param
) = 1;
1516 DECL_IGNORED_P (gnu_decl
) = 1;
1517 TREE_ADDRESSABLE (gnu_decl
) = 1;
1520 /* If this is a loop parameter, set the corresponding flag. */
1521 else if (kind
== E_Loop_Parameter
)
1522 DECL_LOOP_PARM_P (gnu_decl
) = 1;
1524 /* If this is a renaming pointer, attach the renamed object to it and
1525 register it if we are at the global level. Note that an external
1526 constant is at the global level. */
1527 if (TREE_CODE (gnu_decl
) == VAR_DECL
&& renamed_obj
)
1529 SET_DECL_RENAMED_OBJECT (gnu_decl
, renamed_obj
);
1530 if ((!definition
&& kind
== E_Constant
) || global_bindings_p ())
1532 DECL_RENAMING_GLOBAL_P (gnu_decl
) = 1;
1533 record_global_renaming_pointer (gnu_decl
);
1537 /* If this is a constant and we are defining it or it generates a real
1538 symbol at the object level and we are referencing it, we may want
1539 or need to have a true variable to represent it:
1540 - if optimization isn't enabled, for debugging purposes,
1541 - if the constant is public and not overlaid on something else,
1542 - if its address is taken,
1543 - if either itself or its type is aliased. */
1544 if (TREE_CODE (gnu_decl
) == CONST_DECL
1545 && (definition
|| Sloc (gnat_entity
) > Standard_Location
)
1546 && ((!optimize
&& debug_info_p
)
1547 || (Is_Public (gnat_entity
)
1548 && No (Address_Clause (gnat_entity
)))
1549 || Address_Taken (gnat_entity
)
1550 || Is_Aliased (gnat_entity
)
1551 || Is_Aliased (Etype (gnat_entity
))))
1554 = create_true_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
1555 gnu_expr
, true, Is_Public (gnat_entity
),
1556 !definition
, static_p
, attr_list
,
1559 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl
, gnu_corr_var
);
1561 /* As debugging information will be generated for the variable,
1562 do not generate debugging information for the constant. */
1564 DECL_IGNORED_P (gnu_decl
) = 1;
1566 DECL_IGNORED_P (gnu_corr_var
) = 1;
1569 /* If this is a constant, even if we don't need a true variable, we
1570 may need to avoid returning the initializer in every case. That
1571 can happen for the address of a (constant) constructor because,
1572 upon dereferencing it, the constructor will be reinjected in the
1573 tree, which may not be valid in every case; see lvalue_required_p
1574 for more details. */
1575 if (TREE_CODE (gnu_decl
) == CONST_DECL
)
1576 DECL_CONST_ADDRESS_P (gnu_decl
) = constructor_address_p (gnu_expr
);
1578 /* If this object is declared in a block that contains a block with an
1579 exception handler, and we aren't using the GCC exception mechanism,
1580 we must force this variable in memory in order to avoid an invalid
1582 if (Exception_Mechanism
!= Back_End_Exceptions
1583 && Has_Nested_Block_With_Handler (Scope (gnat_entity
)))
1584 TREE_ADDRESSABLE (gnu_decl
) = 1;
1586 /* If this is a local variable with non-BLKmode and aggregate type,
1587 and optimization isn't enabled, then force it in memory so that
1588 a register won't be allocated to it with possible subparts left
1589 uninitialized and reaching the register allocator. */
1590 else if (TREE_CODE (gnu_decl
) == VAR_DECL
1591 && !DECL_EXTERNAL (gnu_decl
)
1592 && !TREE_STATIC (gnu_decl
)
1593 && DECL_MODE (gnu_decl
) != BLKmode
1594 && AGGREGATE_TYPE_P (TREE_TYPE (gnu_decl
))
1595 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_decl
))
1597 TREE_ADDRESSABLE (gnu_decl
) = 1;
1599 /* If we are defining an object with variable size or an object with
1600 fixed size that will be dynamically allocated, and we are using the
1601 setjmp/longjmp exception mechanism, update the setjmp buffer. */
1603 && Exception_Mechanism
== Setjmp_Longjmp
1604 && get_block_jmpbuf_decl ()
1605 && DECL_SIZE_UNIT (gnu_decl
)
1606 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl
)) != INTEGER_CST
1607 || (flag_stack_check
== GENERIC_STACK_CHECK
1608 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl
),
1609 STACK_CHECK_MAX_VAR_SIZE
) > 0)))
1610 add_stmt_with_node (build_call_n_expr
1611 (update_setjmp_buf_decl
, 1,
1612 build_unary_op (ADDR_EXPR
, NULL_TREE
,
1613 get_block_jmpbuf_decl ())),
1616 /* Back-annotate Esize and Alignment of the object if not already
1617 known. Note that we pick the values of the type, not those of
1618 the object, to shield ourselves from low-level platform-dependent
1619 adjustments like alignment promotion. This is both consistent with
1620 all the treatment above, where alignment and size are set on the
1621 type of the object and not on the object directly, and makes it
1622 possible to support all confirming representation clauses. */
1623 annotate_object (gnat_entity
, TREE_TYPE (gnu_decl
), gnu_object_size
,
1629 /* Return a TYPE_DECL for "void" that we previously made. */
1630 gnu_decl
= TYPE_NAME (void_type_node
);
1633 case E_Enumeration_Type
:
1634 /* A special case: for the types Character and Wide_Character in
1635 Standard, we do not list all the literals. So if the literals
1636 are not specified, make this an unsigned integer type. */
1637 if (No (First_Literal (gnat_entity
)))
1639 gnu_type
= make_unsigned_type (esize
);
1640 TYPE_NAME (gnu_type
) = gnu_entity_name
;
1642 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1643 This is needed by the DWARF-2 back-end to distinguish between
1644 unsigned integer types and character types. */
1645 TYPE_STRING_FLAG (gnu_type
) = 1;
1649 /* We have a list of enumeral constants in First_Literal. We make a
1650 CONST_DECL for each one and build into GNU_LITERAL_LIST the list
1651 to be placed into TYPE_FIELDS. Each node is itself a TREE_LIST
1652 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1653 value of the literal. But when we have a regular boolean type, we
1654 simplify this a little by using a BOOLEAN_TYPE. */
1655 const bool is_boolean
= Is_Boolean_Type (gnat_entity
)
1656 && !Has_Non_Standard_Rep (gnat_entity
);
1657 const bool is_unsigned
= Is_Unsigned_Type (gnat_entity
);
1658 tree gnu_list
= NULL_TREE
;
1659 Entity_Id gnat_literal
;
1661 gnu_type
= make_node (is_boolean
? BOOLEAN_TYPE
: ENUMERAL_TYPE
);
1662 TYPE_PRECISION (gnu_type
) = esize
;
1663 TYPE_UNSIGNED (gnu_type
) = is_unsigned
;
1664 set_min_and_max_values_for_integral_type (gnu_type
, esize
,
1665 TYPE_SIGN (gnu_type
));
1666 process_attributes (&gnu_type
, &attr_list
, true, gnat_entity
);
1667 layout_type (gnu_type
);
1669 for (gnat_literal
= First_Literal (gnat_entity
);
1670 Present (gnat_literal
);
1671 gnat_literal
= Next_Literal (gnat_literal
))
1674 = UI_To_gnu (Enumeration_Rep (gnat_literal
), gnu_type
);
1676 = create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
1677 gnu_type
, gnu_value
, true, false, false,
1678 false, NULL
, gnat_literal
);
1679 /* Do not generate debug info for individual enumerators. */
1680 DECL_IGNORED_P (gnu_literal
) = 1;
1681 save_gnu_tree (gnat_literal
, gnu_literal
, false);
1683 = tree_cons (DECL_NAME (gnu_literal
), gnu_value
, gnu_list
);
1687 TYPE_VALUES (gnu_type
) = nreverse (gnu_list
);
1689 /* Note that the bounds are updated at the end of this function
1690 to avoid an infinite recursion since they refer to the type. */
1695 case E_Signed_Integer_Type
:
1696 case E_Ordinary_Fixed_Point_Type
:
1697 case E_Decimal_Fixed_Point_Type
:
1698 /* For integer types, just make a signed type the appropriate number
1700 gnu_type
= make_signed_type (esize
);
1703 case E_Modular_Integer_Type
:
1705 /* For modular types, make the unsigned type of the proper number
1706 of bits and then set up the modulus, if required. */
1707 tree gnu_modulus
, gnu_high
= NULL_TREE
;
1709 /* Packed array types are supposed to be subtypes only. */
1710 gcc_assert (!Is_Packed_Array_Type (gnat_entity
));
1712 gnu_type
= make_unsigned_type (esize
);
1714 /* Get the modulus in this type. If it overflows, assume it is because
1715 it is equal to 2**Esize. Note that there is no overflow checking
1716 done on unsigned type, so we detect the overflow by looking for
1717 a modulus of zero, which is otherwise invalid. */
1718 gnu_modulus
= UI_To_gnu (Modulus (gnat_entity
), gnu_type
);
1720 if (!integer_zerop (gnu_modulus
))
1722 TYPE_MODULAR_P (gnu_type
) = 1;
1723 SET_TYPE_MODULUS (gnu_type
, gnu_modulus
);
1724 gnu_high
= fold_build2 (MINUS_EXPR
, gnu_type
, gnu_modulus
,
1725 convert (gnu_type
, integer_one_node
));
1728 /* If the upper bound is not maximal, make an extra subtype. */
1730 && !tree_int_cst_equal (gnu_high
, TYPE_MAX_VALUE (gnu_type
)))
1732 tree gnu_subtype
= make_unsigned_type (esize
);
1733 SET_TYPE_RM_MAX_VALUE (gnu_subtype
, gnu_high
);
1734 TREE_TYPE (gnu_subtype
) = gnu_type
;
1735 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
1736 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "UMT");
1737 gnu_type
= gnu_subtype
;
1742 case E_Signed_Integer_Subtype
:
1743 case E_Enumeration_Subtype
:
1744 case E_Modular_Integer_Subtype
:
1745 case E_Ordinary_Fixed_Point_Subtype
:
1746 case E_Decimal_Fixed_Point_Subtype
:
1748 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1749 not want to call create_range_type since we would like each subtype
1750 node to be distinct. ??? Historically this was in preparation for
1751 when memory aliasing is implemented, but that's obsolete now given
1752 the call to relate_alias_sets below.
1754 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1755 this fact is used by the arithmetic conversion functions.
1757 We elaborate the Ancestor_Subtype if it is not in the current unit
1758 and one of our bounds is non-static. We do this to ensure consistent
1759 naming in the case where several subtypes share the same bounds, by
1760 elaborating the first such subtype first, thus using its name. */
1763 && Present (Ancestor_Subtype (gnat_entity
))
1764 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1765 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1766 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1767 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
), gnu_expr
, 0);
1769 /* Set the precision to the Esize except for bit-packed arrays. */
1770 if (Is_Packed_Array_Type (gnat_entity
)
1771 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1772 esize
= UI_To_Int (RM_Size (gnat_entity
));
1774 /* This should be an unsigned type if the base type is unsigned or
1775 if the lower bound is constant and non-negative or if the type
1777 if (Is_Unsigned_Type (Etype (gnat_entity
))
1778 || Is_Unsigned_Type (gnat_entity
)
1779 || Has_Biased_Representation (gnat_entity
))
1780 gnu_type
= make_unsigned_type (esize
);
1782 gnu_type
= make_signed_type (esize
);
1783 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1785 SET_TYPE_RM_MIN_VALUE
1787 convert (TREE_TYPE (gnu_type
),
1788 elaborate_expression (Type_Low_Bound (gnat_entity
),
1789 gnat_entity
, get_identifier ("L"),
1791 Needs_Debug_Info (gnat_entity
))));
1793 SET_TYPE_RM_MAX_VALUE
1795 convert (TREE_TYPE (gnu_type
),
1796 elaborate_expression (Type_High_Bound (gnat_entity
),
1797 gnat_entity
, get_identifier ("U"),
1799 Needs_Debug_Info (gnat_entity
))));
1801 TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1802 = Has_Biased_Representation (gnat_entity
);
1804 /* Inherit our alias set from what we're a subtype of. Subtypes
1805 are not different types and a pointer can designate any instance
1806 within a subtype hierarchy. */
1807 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
1809 /* One of the above calls might have caused us to be elaborated,
1810 so don't blow up if so. */
1811 if (present_gnu_tree (gnat_entity
))
1813 maybe_present
= true;
1817 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1818 TYPE_STUB_DECL (gnu_type
)
1819 = create_type_stub_decl (gnu_entity_name
, gnu_type
);
1821 /* For a packed array, make the original array type a parallel type. */
1823 && Is_Packed_Array_Type (gnat_entity
)
1824 && present_gnu_tree (Original_Array_Type (gnat_entity
)))
1825 add_parallel_type (gnu_type
,
1827 (Original_Array_Type (gnat_entity
)));
1831 /* We have to handle clauses that under-align the type specially. */
1832 if ((Present (Alignment_Clause (gnat_entity
))
1833 || (Is_Packed_Array_Type (gnat_entity
)
1835 (Alignment_Clause (Original_Array_Type (gnat_entity
)))))
1836 && UI_Is_In_Int_Range (Alignment (gnat_entity
)))
1838 align
= UI_To_Int (Alignment (gnat_entity
)) * BITS_PER_UNIT
;
1839 if (align
>= TYPE_ALIGN (gnu_type
))
1843 /* If the type we are dealing with represents a bit-packed array,
1844 we need to have the bits left justified on big-endian targets
1845 and right justified on little-endian targets. We also need to
1846 ensure that when the value is read (e.g. for comparison of two
1847 such values), we only get the good bits, since the unused bits
1848 are uninitialized. Both goals are accomplished by wrapping up
1849 the modular type in an enclosing record type. */
1850 if (Is_Packed_Array_Type (gnat_entity
)
1851 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1853 tree gnu_field_type
, gnu_field
;
1855 /* Set the RM size before wrapping up the original type. */
1856 SET_TYPE_RM_SIZE (gnu_type
,
1857 UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
));
1858 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
) = 1;
1860 /* Create a stripped-down declaration, mainly for debugging. */
1861 create_type_decl (gnu_entity_name
, gnu_type
, true, debug_info_p
,
1864 /* Now save it and build the enclosing record type. */
1865 gnu_field_type
= gnu_type
;
1867 gnu_type
= make_node (RECORD_TYPE
);
1868 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "JM");
1869 TYPE_PACKED (gnu_type
) = 1;
1870 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_field_type
);
1871 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_field_type
);
1872 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_RM_SIZE (gnu_field_type
));
1874 /* Propagate the alignment of the modular type to the record type,
1875 unless there is an alignment clause that under-aligns the type.
1876 This means that bit-packed arrays are given "ceil" alignment for
1877 their size by default, which may seem counter-intuitive but makes
1878 it possible to overlay them on modular types easily. */
1879 TYPE_ALIGN (gnu_type
)
1880 = align
> 0 ? align
: TYPE_ALIGN (gnu_field_type
);
1882 relate_alias_sets (gnu_type
, gnu_field_type
, ALIAS_SET_COPY
);
1884 /* Don't declare the field as addressable since we won't be taking
1885 its address and this would prevent create_field_decl from making
1888 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type
,
1889 gnu_type
, NULL_TREE
, bitsize_zero_node
, 1, 0);
1891 /* Do not emit debug info until after the parallel type is added. */
1892 finish_record_type (gnu_type
, gnu_field
, 2, false);
1893 compute_record_mode (gnu_type
);
1894 TYPE_JUSTIFIED_MODULAR_P (gnu_type
) = 1;
1898 /* Make the original array type a parallel type. */
1899 if (present_gnu_tree (Original_Array_Type (gnat_entity
)))
1900 add_parallel_type (gnu_type
,
1902 (Original_Array_Type (gnat_entity
)));
1904 rest_of_record_type_compilation (gnu_type
);
1908 /* If the type we are dealing with has got a smaller alignment than the
1909 natural one, we need to wrap it up in a record type and misalign the
1910 latter; we reuse the padding machinery for this purpose. Note that,
1911 even if the record type is marked as packed because of misalignment,
1912 we don't pack the field so as to give it the size of the type. */
1915 tree gnu_field_type
, gnu_field
;
1917 /* Set the RM size before wrapping up the type. */
1918 SET_TYPE_RM_SIZE (gnu_type
,
1919 UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
));
1921 /* Create a stripped-down declaration, mainly for debugging. */
1922 create_type_decl (gnu_entity_name
, gnu_type
, true, debug_info_p
,
1925 /* Now save it and build the enclosing record type. */
1926 gnu_field_type
= gnu_type
;
1928 gnu_type
= make_node (RECORD_TYPE
);
1929 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "PAD");
1930 TYPE_PACKED (gnu_type
) = 1;
1931 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_field_type
);
1932 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_field_type
);
1933 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_RM_SIZE (gnu_field_type
));
1934 TYPE_ALIGN (gnu_type
) = align
;
1935 relate_alias_sets (gnu_type
, gnu_field_type
, ALIAS_SET_COPY
);
1937 /* Don't declare the field as addressable since we won't be taking
1938 its address and this would prevent create_field_decl from making
1941 = create_field_decl (get_identifier ("F"), gnu_field_type
,
1942 gnu_type
, TYPE_SIZE (gnu_field_type
),
1943 bitsize_zero_node
, 0, 0);
1945 finish_record_type (gnu_type
, gnu_field
, 2, debug_info_p
);
1946 compute_record_mode (gnu_type
);
1947 TYPE_PADDING_P (gnu_type
) = 1;
1952 case E_Floating_Point_Type
:
1953 /* If this is a VAX floating-point type, use an integer of the proper
1954 size. All the operations will be handled with ASM statements. */
1955 if (Vax_Float (gnat_entity
))
1957 gnu_type
= make_signed_type (esize
);
1958 TYPE_VAX_FLOATING_POINT_P (gnu_type
) = 1;
1959 SET_TYPE_DIGITS_VALUE (gnu_type
,
1960 UI_To_gnu (Digits_Value (gnat_entity
),
1965 /* The type of the Low and High bounds can be our type if this is
1966 a type from Standard, so set them at the end of the function. */
1967 gnu_type
= make_node (REAL_TYPE
);
1968 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1969 layout_type (gnu_type
);
1972 case E_Floating_Point_Subtype
:
1973 if (Vax_Float (gnat_entity
))
1975 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1979 /* See the E_Signed_Integer_Subtype case for the rationale. */
1981 && Present (Ancestor_Subtype (gnat_entity
))
1982 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1983 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1984 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1985 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
), gnu_expr
, 0);
1987 gnu_type
= make_node (REAL_TYPE
);
1988 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1989 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1990 TYPE_GCC_MIN_VALUE (gnu_type
)
1991 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type
));
1992 TYPE_GCC_MAX_VALUE (gnu_type
)
1993 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type
));
1994 layout_type (gnu_type
);
1996 SET_TYPE_RM_MIN_VALUE
1998 convert (TREE_TYPE (gnu_type
),
1999 elaborate_expression (Type_Low_Bound (gnat_entity
),
2000 gnat_entity
, get_identifier ("L"),
2002 Needs_Debug_Info (gnat_entity
))));
2004 SET_TYPE_RM_MAX_VALUE
2006 convert (TREE_TYPE (gnu_type
),
2007 elaborate_expression (Type_High_Bound (gnat_entity
),
2008 gnat_entity
, get_identifier ("U"),
2010 Needs_Debug_Info (gnat_entity
))));
2012 /* Inherit our alias set from what we're a subtype of, as for
2013 integer subtypes. */
2014 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
2016 /* One of the above calls might have caused us to be elaborated,
2017 so don't blow up if so. */
2018 maybe_present
= true;
2021 /* Array and String Types and Subtypes
2023 Unconstrained array types are represented by E_Array_Type and
2024 constrained array types are represented by E_Array_Subtype. There
2025 are no actual objects of an unconstrained array type; all we have
2026 are pointers to that type.
2028 The following fields are defined on array types and subtypes:
2030 Component_Type Component type of the array.
2031 Number_Dimensions Number of dimensions (an int).
2032 First_Index Type of first index. */
2037 const bool convention_fortran_p
2038 = (Convention (gnat_entity
) == Convention_Fortran
);
2039 const int ndim
= Number_Dimensions (gnat_entity
);
2040 tree gnu_template_type
;
2041 tree gnu_ptr_template
;
2042 tree gnu_template_reference
, gnu_template_fields
, gnu_fat_type
;
2043 tree
*gnu_index_types
= XALLOCAVEC (tree
, ndim
);
2044 tree
*gnu_temp_fields
= XALLOCAVEC (tree
, ndim
);
2045 tree gnu_max_size
= size_one_node
, gnu_max_size_unit
, tem
, t
;
2046 Entity_Id gnat_index
, gnat_name
;
2050 /* Create the type for the component now, as it simplifies breaking
2051 type reference loops. */
2053 = gnat_to_gnu_component_type (gnat_entity
, definition
, debug_info_p
);
2054 if (present_gnu_tree (gnat_entity
))
2056 /* As a side effect, the type may have been translated. */
2057 maybe_present
= true;
2061 /* We complete an existing dummy fat pointer type in place. This both
2062 avoids further complex adjustments in update_pointer_to and yields
2063 better debugging information in DWARF by leveraging the support for
2064 incomplete declarations of "tagged" types in the DWARF back-end. */
2065 gnu_type
= get_dummy_type (gnat_entity
);
2066 if (gnu_type
&& TYPE_POINTER_TO (gnu_type
))
2068 gnu_fat_type
= TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type
));
2069 TYPE_NAME (gnu_fat_type
) = NULL_TREE
;
2070 /* Save the contents of the dummy type for update_pointer_to. */
2071 TYPE_POINTER_TO (gnu_type
) = copy_type (gnu_fat_type
);
2073 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type
)));
2074 gnu_template_type
= TREE_TYPE (gnu_ptr_template
);
2078 gnu_fat_type
= make_node (RECORD_TYPE
);
2079 gnu_template_type
= make_node (RECORD_TYPE
);
2080 gnu_ptr_template
= build_pointer_type (gnu_template_type
);
2083 /* Make a node for the array. If we are not defining the array
2084 suppress expanding incomplete types. */
2085 gnu_type
= make_node (UNCONSTRAINED_ARRAY_TYPE
);
2089 defer_incomplete_level
++;
2090 this_deferred
= true;
2093 /* Build the fat pointer type. Use a "void *" object instead of
2094 a pointer to the array type since we don't have the array type
2095 yet (it will reference the fat pointer via the bounds). */
2097 = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node
,
2098 gnu_fat_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2100 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template
,
2101 gnu_fat_type
, NULL_TREE
, NULL_TREE
, 0, 0);
2103 if (COMPLETE_TYPE_P (gnu_fat_type
))
2105 /* We are going to lay it out again so reset the alias set. */
2106 alias_set_type alias_set
= TYPE_ALIAS_SET (gnu_fat_type
);
2107 TYPE_ALIAS_SET (gnu_fat_type
) = -1;
2108 finish_fat_pointer_type (gnu_fat_type
, tem
);
2109 TYPE_ALIAS_SET (gnu_fat_type
) = alias_set
;
2110 for (t
= gnu_fat_type
; t
; t
= TYPE_NEXT_VARIANT (t
))
2112 TYPE_FIELDS (t
) = tem
;
2113 SET_TYPE_UNCONSTRAINED_ARRAY (t
, gnu_type
);
2118 finish_fat_pointer_type (gnu_fat_type
, tem
);
2119 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type
, gnu_type
);
2122 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2123 is the fat pointer. This will be used to access the individual
2124 fields once we build them. */
2125 tem
= build3 (COMPONENT_REF
, gnu_ptr_template
,
2126 build0 (PLACEHOLDER_EXPR
, gnu_fat_type
),
2127 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type
)), NULL_TREE
);
2128 gnu_template_reference
2129 = build_unary_op (INDIRECT_REF
, gnu_template_type
, tem
);
2130 TREE_READONLY (gnu_template_reference
) = 1;
2131 TREE_THIS_NOTRAP (gnu_template_reference
) = 1;
2133 /* Now create the GCC type for each index and add the fields for that
2134 index to the template. */
2135 for (index
= (convention_fortran_p
? ndim
- 1 : 0),
2136 gnat_index
= First_Index (gnat_entity
);
2137 0 <= index
&& index
< ndim
;
2138 index
+= (convention_fortran_p
? - 1 : 1),
2139 gnat_index
= Next_Index (gnat_index
))
2141 char field_name
[16];
2142 tree gnu_index_base_type
2143 = get_unpadded_type (Base_Type (Etype (gnat_index
)));
2144 tree gnu_lb_field
, gnu_hb_field
, gnu_orig_min
, gnu_orig_max
;
2145 tree gnu_min
, gnu_max
, gnu_high
;
2147 /* Make the FIELD_DECLs for the low and high bounds of this
2148 type and then make extractions of these fields from the
2150 sprintf (field_name
, "LB%d", index
);
2151 gnu_lb_field
= create_field_decl (get_identifier (field_name
),
2152 gnu_index_base_type
,
2153 gnu_template_type
, NULL_TREE
,
2155 Sloc_to_locus (Sloc (gnat_entity
),
2156 &DECL_SOURCE_LOCATION (gnu_lb_field
));
2158 field_name
[0] = 'U';
2159 gnu_hb_field
= create_field_decl (get_identifier (field_name
),
2160 gnu_index_base_type
,
2161 gnu_template_type
, NULL_TREE
,
2163 Sloc_to_locus (Sloc (gnat_entity
),
2164 &DECL_SOURCE_LOCATION (gnu_hb_field
));
2166 gnu_temp_fields
[index
] = chainon (gnu_lb_field
, gnu_hb_field
);
2168 /* We can't use build_component_ref here since the template type
2169 isn't complete yet. */
2170 gnu_orig_min
= build3 (COMPONENT_REF
, gnu_index_base_type
,
2171 gnu_template_reference
, gnu_lb_field
,
2173 gnu_orig_max
= build3 (COMPONENT_REF
, gnu_index_base_type
,
2174 gnu_template_reference
, gnu_hb_field
,
2176 TREE_READONLY (gnu_orig_min
) = TREE_READONLY (gnu_orig_max
) = 1;
2178 gnu_min
= convert (sizetype
, gnu_orig_min
);
2179 gnu_max
= convert (sizetype
, gnu_orig_max
);
2181 /* Compute the size of this dimension. See the E_Array_Subtype
2182 case below for the rationale. */
2184 = build3 (COND_EXPR
, sizetype
,
2185 build2 (GE_EXPR
, boolean_type_node
,
2186 gnu_orig_max
, gnu_orig_min
),
2188 size_binop (MINUS_EXPR
, gnu_min
, size_one_node
));
2190 /* Make a range type with the new range in the Ada base type.
2191 Then make an index type with the size range in sizetype. */
2192 gnu_index_types
[index
]
2193 = create_index_type (gnu_min
, gnu_high
,
2194 create_range_type (gnu_index_base_type
,
2199 /* Update the maximum size of the array in elements. */
2202 tree gnu_index_type
= get_unpadded_type (Etype (gnat_index
));
2204 = convert (sizetype
, TYPE_MIN_VALUE (gnu_index_type
));
2206 = convert (sizetype
, TYPE_MAX_VALUE (gnu_index_type
));
2208 = size_binop (MAX_EXPR
,
2209 size_binop (PLUS_EXPR
, size_one_node
,
2210 size_binop (MINUS_EXPR
,
2214 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2215 && TREE_OVERFLOW (gnu_this_max
))
2216 gnu_max_size
= NULL_TREE
;
2219 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2222 TYPE_NAME (gnu_index_types
[index
])
2223 = create_concat_name (gnat_entity
, field_name
);
2226 /* Install all the fields into the template. */
2227 TYPE_NAME (gnu_template_type
)
2228 = create_concat_name (gnat_entity
, "XUB");
2229 gnu_template_fields
= NULL_TREE
;
2230 for (index
= 0; index
< ndim
; index
++)
2232 = chainon (gnu_template_fields
, gnu_temp_fields
[index
]);
2233 finish_record_type (gnu_template_type
, gnu_template_fields
, 0,
2235 TYPE_READONLY (gnu_template_type
) = 1;
2237 /* If Component_Size is not already specified, annotate it with the
2238 size of the component. */
2239 if (Unknown_Component_Size (gnat_entity
))
2240 Set_Component_Size (gnat_entity
,
2241 annotate_value (TYPE_SIZE (comp_type
)));
2243 /* Compute the maximum size of the array in units and bits. */
2246 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2247 TYPE_SIZE_UNIT (comp_type
));
2248 gnu_max_size
= size_binop (MULT_EXPR
,
2249 convert (bitsizetype
, gnu_max_size
),
2250 TYPE_SIZE (comp_type
));
2253 gnu_max_size_unit
= NULL_TREE
;
2255 /* Now build the array type. */
2257 for (index
= ndim
- 1; index
>= 0; index
--)
2259 tem
= build_nonshared_array_type (tem
, gnu_index_types
[index
]);
2260 if (Reverse_Storage_Order (gnat_entity
))
2261 sorry ("non-default Scalar_Storage_Order");
2262 TYPE_MULTI_ARRAY_P (tem
) = (index
> 0);
2263 if (array_type_has_nonaliased_component (tem
, gnat_entity
))
2264 TYPE_NONALIASED_COMPONENT (tem
) = 1;
2266 /* If it is passed by reference, force BLKmode to ensure that
2267 objects of this type will always be put in memory. */
2268 if (TYPE_MODE (tem
) != BLKmode
2269 && Is_By_Reference_Type (gnat_entity
))
2270 SET_TYPE_MODE (tem
, BLKmode
);
2273 /* If an alignment is specified, use it if valid. But ignore it
2274 for the original type of packed array types. If the alignment
2275 was requested with an explicit alignment clause, state so. */
2276 if (No (Packed_Array_Type (gnat_entity
))
2277 && Known_Alignment (gnat_entity
))
2280 = validate_alignment (Alignment (gnat_entity
), gnat_entity
,
2282 if (Present (Alignment_Clause (gnat_entity
)))
2283 TYPE_USER_ALIGN (tem
) = 1;
2286 TYPE_CONVENTION_FORTRAN_P (tem
) = convention_fortran_p
;
2288 /* Adjust the type of the pointer-to-array field of the fat pointer
2289 and record the aliasing relationships if necessary. */
2290 TREE_TYPE (TYPE_FIELDS (gnu_fat_type
)) = build_pointer_type (tem
);
2291 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type
))
2292 record_component_aliases (gnu_fat_type
);
2294 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2295 corresponding fat pointer. */
2296 TREE_TYPE (gnu_type
) = gnu_fat_type
;
2297 TYPE_POINTER_TO (gnu_type
) = gnu_fat_type
;
2298 TYPE_REFERENCE_TO (gnu_type
) = gnu_fat_type
;
2299 SET_TYPE_MODE (gnu_type
, BLKmode
);
2300 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (tem
);
2302 /* If the maximum size doesn't overflow, use it. */
2304 && TREE_CODE (gnu_max_size
) == INTEGER_CST
2305 && !TREE_OVERFLOW (gnu_max_size
)
2306 && TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2307 && !TREE_OVERFLOW (gnu_max_size_unit
))
2309 TYPE_SIZE (tem
) = size_binop (MIN_EXPR
, gnu_max_size
,
2311 TYPE_SIZE_UNIT (tem
) = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2312 TYPE_SIZE_UNIT (tem
));
2315 create_type_decl (create_concat_name (gnat_entity
, "XUA"), tem
,
2316 !Comes_From_Source (gnat_entity
), debug_info_p
,
2319 /* Give the fat pointer type a name. If this is a packed type, tell
2320 the debugger how to interpret the underlying bits. */
2321 if (Present (Packed_Array_Type (gnat_entity
)))
2322 gnat_name
= Packed_Array_Type (gnat_entity
);
2324 gnat_name
= gnat_entity
;
2325 create_type_decl (create_concat_name (gnat_name
, "XUP"), gnu_fat_type
,
2326 !Comes_From_Source (gnat_entity
), debug_info_p
,
2329 /* Create the type to be designated by thin pointers: a record type for
2330 the array and its template. We used to shift the fields to have the
2331 template at a negative offset, but this was somewhat of a kludge; we
2332 now shift thin pointer values explicitly but only those which have a
2333 TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE. */
2334 tem
= build_unc_object_type (gnu_template_type
, tem
,
2335 create_concat_name (gnat_name
, "XUT"),
2338 SET_TYPE_UNCONSTRAINED_ARRAY (tem
, gnu_type
);
2339 TYPE_OBJECT_RECORD_TYPE (gnu_type
) = tem
;
2343 case E_String_Subtype
:
2344 case E_Array_Subtype
:
2346 /* This is the actual data type for array variables. Multidimensional
2347 arrays are implemented as arrays of arrays. Note that arrays which
2348 have sparse enumeration subtypes as index components create sparse
2349 arrays, which is obviously space inefficient but so much easier to
2352 Also note that the subtype never refers to the unconstrained array
2353 type, which is somewhat at variance with Ada semantics.
2355 First check to see if this is simply a renaming of the array type.
2356 If so, the result is the array type. */
2358 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
2359 if (!Is_Constrained (gnat_entity
))
2363 Entity_Id gnat_index
, gnat_base_index
;
2364 const bool convention_fortran_p
2365 = (Convention (gnat_entity
) == Convention_Fortran
);
2366 const int ndim
= Number_Dimensions (gnat_entity
);
2367 tree gnu_base_type
= gnu_type
;
2368 tree
*gnu_index_types
= XALLOCAVEC (tree
, ndim
);
2369 tree gnu_max_size
= size_one_node
, gnu_max_size_unit
;
2370 bool need_index_type_struct
= false;
2373 /* First create the GCC type for each index and find out whether
2374 special types are needed for debugging information. */
2375 for (index
= (convention_fortran_p
? ndim
- 1 : 0),
2376 gnat_index
= First_Index (gnat_entity
),
2378 = First_Index (Implementation_Base_Type (gnat_entity
));
2379 0 <= index
&& index
< ndim
;
2380 index
+= (convention_fortran_p
? - 1 : 1),
2381 gnat_index
= Next_Index (gnat_index
),
2382 gnat_base_index
= Next_Index (gnat_base_index
))
2384 tree gnu_index_type
= get_unpadded_type (Etype (gnat_index
));
2385 tree gnu_orig_min
= TYPE_MIN_VALUE (gnu_index_type
);
2386 tree gnu_orig_max
= TYPE_MAX_VALUE (gnu_index_type
);
2387 tree gnu_min
= convert (sizetype
, gnu_orig_min
);
2388 tree gnu_max
= convert (sizetype
, gnu_orig_max
);
2389 tree gnu_base_index_type
2390 = get_unpadded_type (Etype (gnat_base_index
));
2391 tree gnu_base_orig_min
= TYPE_MIN_VALUE (gnu_base_index_type
);
2392 tree gnu_base_orig_max
= TYPE_MAX_VALUE (gnu_base_index_type
);
2395 /* See if the base array type is already flat. If it is, we
2396 are probably compiling an ACATS test but it will cause the
2397 code below to malfunction if we don't handle it specially. */
2398 if (TREE_CODE (gnu_base_orig_min
) == INTEGER_CST
2399 && TREE_CODE (gnu_base_orig_max
) == INTEGER_CST
2400 && tree_int_cst_lt (gnu_base_orig_max
, gnu_base_orig_min
))
2402 gnu_min
= size_one_node
;
2403 gnu_max
= size_zero_node
;
2407 /* Similarly, if one of the values overflows in sizetype and the
2408 range is null, use 1..0 for the sizetype bounds. */
2409 else if (TREE_CODE (gnu_min
) == INTEGER_CST
2410 && TREE_CODE (gnu_max
) == INTEGER_CST
2411 && (TREE_OVERFLOW (gnu_min
) || TREE_OVERFLOW (gnu_max
))
2412 && tree_int_cst_lt (gnu_orig_max
, gnu_orig_min
))
2414 gnu_min
= size_one_node
;
2415 gnu_max
= size_zero_node
;
2419 /* If the minimum and maximum values both overflow in sizetype,
2420 but the difference in the original type does not overflow in
2421 sizetype, ignore the overflow indication. */
2422 else if (TREE_CODE (gnu_min
) == INTEGER_CST
2423 && TREE_CODE (gnu_max
) == INTEGER_CST
2424 && TREE_OVERFLOW (gnu_min
) && TREE_OVERFLOW (gnu_max
)
2427 fold_build2 (MINUS_EXPR
, gnu_index_type
,
2431 TREE_OVERFLOW (gnu_min
) = 0;
2432 TREE_OVERFLOW (gnu_max
) = 0;
2436 /* Compute the size of this dimension in the general case. We
2437 need to provide GCC with an upper bound to use but have to
2438 deal with the "superflat" case. There are three ways to do
2439 this. If we can prove that the array can never be superflat,
2440 we can just use the high bound of the index type. */
2441 else if ((Nkind (gnat_index
) == N_Range
2442 && cannot_be_superflat_p (gnat_index
))
2443 /* Packed Array Types are never superflat. */
2444 || Is_Packed_Array_Type (gnat_entity
))
2447 /* Otherwise, if the high bound is constant but the low bound is
2448 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2449 lower bound. Note that the comparison must be done in the
2450 original type to avoid any overflow during the conversion. */
2451 else if (TREE_CODE (gnu_max
) == INTEGER_CST
2452 && TREE_CODE (gnu_min
) != INTEGER_CST
)
2456 = build_cond_expr (sizetype
,
2457 build_binary_op (GE_EXPR
,
2462 int_const_binop (PLUS_EXPR
, gnu_max
,
2466 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2467 in all the other cases. Note that, here as well as above,
2468 the condition used in the comparison must be equivalent to
2469 the condition (length != 0). This is relied upon in order
2470 to optimize array comparisons in compare_arrays. Moreover
2471 we use int_const_binop for the shift by 1 if the bound is
2472 constant to avoid any unwanted overflow. */
2475 = build_cond_expr (sizetype
,
2476 build_binary_op (GE_EXPR
,
2481 TREE_CODE (gnu_min
) == INTEGER_CST
2482 ? int_const_binop (MINUS_EXPR
, gnu_min
,
2484 : size_binop (MINUS_EXPR
, gnu_min
,
2487 /* Reuse the index type for the range type. Then make an index
2488 type with the size range in sizetype. */
2489 gnu_index_types
[index
]
2490 = create_index_type (gnu_min
, gnu_high
, gnu_index_type
,
2493 /* Update the maximum size of the array in elements. Here we
2494 see if any constraint on the index type of the base type
2495 can be used in the case of self-referential bound on the
2496 index type of the subtype. We look for a non-"infinite"
2497 and non-self-referential bound from any type involved and
2498 handle each bound separately. */
2501 tree gnu_base_min
= convert (sizetype
, gnu_base_orig_min
);
2502 tree gnu_base_max
= convert (sizetype
, gnu_base_orig_max
);
2503 tree gnu_base_index_base_type
2504 = get_base_type (gnu_base_index_type
);
2505 tree gnu_base_base_min
2506 = convert (sizetype
,
2507 TYPE_MIN_VALUE (gnu_base_index_base_type
));
2508 tree gnu_base_base_max
2509 = convert (sizetype
,
2510 TYPE_MAX_VALUE (gnu_base_index_base_type
));
2512 if (!CONTAINS_PLACEHOLDER_P (gnu_min
)
2513 || !(TREE_CODE (gnu_base_min
) == INTEGER_CST
2514 && !TREE_OVERFLOW (gnu_base_min
)))
2515 gnu_base_min
= gnu_min
;
2517 if (!CONTAINS_PLACEHOLDER_P (gnu_max
)
2518 || !(TREE_CODE (gnu_base_max
) == INTEGER_CST
2519 && !TREE_OVERFLOW (gnu_base_max
)))
2520 gnu_base_max
= gnu_max
;
2522 if ((TREE_CODE (gnu_base_min
) == INTEGER_CST
2523 && TREE_OVERFLOW (gnu_base_min
))
2524 || operand_equal_p (gnu_base_min
, gnu_base_base_min
, 0)
2525 || (TREE_CODE (gnu_base_max
) == INTEGER_CST
2526 && TREE_OVERFLOW (gnu_base_max
))
2527 || operand_equal_p (gnu_base_max
, gnu_base_base_max
, 0))
2528 gnu_max_size
= NULL_TREE
;
2532 = size_binop (MAX_EXPR
,
2533 size_binop (PLUS_EXPR
, size_one_node
,
2534 size_binop (MINUS_EXPR
,
2539 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2540 && TREE_OVERFLOW (gnu_this_max
))
2541 gnu_max_size
= NULL_TREE
;
2544 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2548 /* We need special types for debugging information to point to
2549 the index types if they have variable bounds, are not integer
2550 types, are biased or are wider than sizetype. */
2551 if (!integer_onep (gnu_orig_min
)
2552 || TREE_CODE (gnu_orig_max
) != INTEGER_CST
2553 || TREE_CODE (gnu_index_type
) != INTEGER_TYPE
2554 || (TREE_TYPE (gnu_index_type
)
2555 && TREE_CODE (TREE_TYPE (gnu_index_type
))
2557 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type
)
2558 || compare_tree_int (rm_size (gnu_index_type
),
2559 TYPE_PRECISION (sizetype
)) > 0)
2560 need_index_type_struct
= true;
2563 /* Then flatten: create the array of arrays. For an array type
2564 used to implement a packed array, get the component type from
2565 the original array type since the representation clauses that
2566 can affect it are on the latter. */
2567 if (Is_Packed_Array_Type (gnat_entity
)
2568 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
2570 gnu_type
= gnat_to_gnu_type (Original_Array_Type (gnat_entity
));
2571 for (index
= ndim
- 1; index
>= 0; index
--)
2572 gnu_type
= TREE_TYPE (gnu_type
);
2574 /* One of the above calls might have caused us to be elaborated,
2575 so don't blow up if so. */
2576 if (present_gnu_tree (gnat_entity
))
2578 maybe_present
= true;
2584 gnu_type
= gnat_to_gnu_component_type (gnat_entity
, definition
,
2587 /* One of the above calls might have caused us to be elaborated,
2588 so don't blow up if so. */
2589 if (present_gnu_tree (gnat_entity
))
2591 maybe_present
= true;
2596 /* Compute the maximum size of the array in units and bits. */
2599 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2600 TYPE_SIZE_UNIT (gnu_type
));
2601 gnu_max_size
= size_binop (MULT_EXPR
,
2602 convert (bitsizetype
, gnu_max_size
),
2603 TYPE_SIZE (gnu_type
));
2606 gnu_max_size_unit
= NULL_TREE
;
2608 /* Now build the array type. */
2609 for (index
= ndim
- 1; index
>= 0; index
--)
2611 gnu_type
= build_nonshared_array_type (gnu_type
,
2612 gnu_index_types
[index
]);
2613 TYPE_MULTI_ARRAY_P (gnu_type
) = (index
> 0);
2614 if (array_type_has_nonaliased_component (gnu_type
, gnat_entity
))
2615 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2617 /* See the E_Array_Type case for the rationale. */
2618 if (TYPE_MODE (gnu_type
) != BLKmode
2619 && Is_By_Reference_Type (gnat_entity
))
2620 SET_TYPE_MODE (gnu_type
, BLKmode
);
2623 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2624 TYPE_STUB_DECL (gnu_type
)
2625 = create_type_stub_decl (gnu_entity_name
, gnu_type
);
2627 /* If we are at file level and this is a multi-dimensional array,
2628 we need to make a variable corresponding to the stride of the
2629 inner dimensions. */
2630 if (global_bindings_p () && ndim
> 1)
2632 tree gnu_st_name
= get_identifier ("ST");
2635 for (gnu_arr_type
= TREE_TYPE (gnu_type
);
2636 TREE_CODE (gnu_arr_type
) == ARRAY_TYPE
;
2637 gnu_arr_type
= TREE_TYPE (gnu_arr_type
),
2638 gnu_st_name
= concat_name (gnu_st_name
, "ST"))
2640 tree eltype
= TREE_TYPE (gnu_arr_type
);
2642 TYPE_SIZE (gnu_arr_type
)
2643 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type
),
2644 gnat_entity
, gnu_st_name
,
2647 /* ??? For now, store the size as a multiple of the
2648 alignment of the element type in bytes so that we
2649 can see the alignment from the tree. */
2650 TYPE_SIZE_UNIT (gnu_arr_type
)
2651 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type
),
2653 concat_name (gnu_st_name
, "A_U"),
2655 TYPE_ALIGN (eltype
));
2657 /* ??? create_type_decl is not invoked on the inner types so
2658 the MULT_EXPR node built above will never be marked. */
2659 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type
));
2663 /* If we need to write out a record type giving the names of the
2664 bounds for debugging purposes, do it now and make the record
2665 type a parallel type. This is not needed for a packed array
2666 since the bounds are conveyed by the original array type. */
2667 if (need_index_type_struct
2669 && !Is_Packed_Array_Type (gnat_entity
))
2671 tree gnu_bound_rec
= make_node (RECORD_TYPE
);
2672 tree gnu_field_list
= NULL_TREE
;
2675 TYPE_NAME (gnu_bound_rec
)
2676 = create_concat_name (gnat_entity
, "XA");
2678 for (index
= ndim
- 1; index
>= 0; index
--)
2680 tree gnu_index
= TYPE_INDEX_TYPE (gnu_index_types
[index
]);
2681 tree gnu_index_name
= TYPE_NAME (gnu_index
);
2683 if (TREE_CODE (gnu_index_name
) == TYPE_DECL
)
2684 gnu_index_name
= DECL_NAME (gnu_index_name
);
2686 /* Make sure to reference the types themselves, and not just
2687 their names, as the debugger may fall back on them. */
2688 gnu_field
= create_field_decl (gnu_index_name
, gnu_index
,
2689 gnu_bound_rec
, NULL_TREE
,
2691 DECL_CHAIN (gnu_field
) = gnu_field_list
;
2692 gnu_field_list
= gnu_field
;
2695 finish_record_type (gnu_bound_rec
, gnu_field_list
, 0, true);
2696 add_parallel_type (gnu_type
, gnu_bound_rec
);
2699 /* If this is a packed array type, make the original array type a
2700 parallel type. Otherwise, do it for the base array type if it
2701 isn't artificial to make sure it is kept in the debug info. */
2704 if (Is_Packed_Array_Type (gnat_entity
)
2705 && present_gnu_tree (Original_Array_Type (gnat_entity
)))
2706 add_parallel_type (gnu_type
,
2708 (Original_Array_Type (gnat_entity
)));
2712 = gnat_to_gnu_entity (Etype (gnat_entity
), NULL_TREE
, 0);
2713 if (!DECL_ARTIFICIAL (gnu_base_decl
))
2714 add_parallel_type (gnu_type
,
2715 TREE_TYPE (TREE_TYPE (gnu_base_decl
)));
2719 TYPE_CONVENTION_FORTRAN_P (gnu_type
) = convention_fortran_p
;
2720 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
2721 = (Is_Packed_Array_Type (gnat_entity
)
2722 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
2724 /* If the size is self-referential and the maximum size doesn't
2725 overflow, use it. */
2726 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
2728 && !(TREE_CODE (gnu_max_size
) == INTEGER_CST
2729 && TREE_OVERFLOW (gnu_max_size
))
2730 && !(TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2731 && TREE_OVERFLOW (gnu_max_size_unit
)))
2733 TYPE_SIZE (gnu_type
) = size_binop (MIN_EXPR
, gnu_max_size
,
2734 TYPE_SIZE (gnu_type
));
2735 TYPE_SIZE_UNIT (gnu_type
)
2736 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2737 TYPE_SIZE_UNIT (gnu_type
));
2740 /* Set our alias set to that of our base type. This gives all
2741 array subtypes the same alias set. */
2742 relate_alias_sets (gnu_type
, gnu_base_type
, ALIAS_SET_COPY
);
2744 /* If this is a packed type, make this type the same as the packed
2745 array type, but do some adjusting in the type first. */
2746 if (Present (Packed_Array_Type (gnat_entity
)))
2748 Entity_Id gnat_index
;
2751 /* First finish the type we had been making so that we output
2752 debugging information for it. */
2753 process_attributes (&gnu_type
, &attr_list
, false, gnat_entity
);
2754 if (Treat_As_Volatile (gnat_entity
))
2756 = build_qualified_type (gnu_type
,
2757 TYPE_QUALS (gnu_type
)
2758 | TYPE_QUAL_VOLATILE
);
2759 /* Make it artificial only if the base type was artificial too.
2760 That's sort of "morally" true and will make it possible for
2761 the debugger to look it up by name in DWARF, which is needed
2762 in order to decode the packed array type. */
2764 = create_type_decl (gnu_entity_name
, gnu_type
,
2765 !Comes_From_Source (Etype (gnat_entity
))
2766 && !Comes_From_Source (gnat_entity
),
2767 debug_info_p
, gnat_entity
);
2769 /* Save it as our equivalent in case the call below elaborates
2771 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2773 gnu_decl
= gnat_to_gnu_entity (Packed_Array_Type (gnat_entity
),
2775 this_made_decl
= true;
2776 gnu_type
= TREE_TYPE (gnu_decl
);
2777 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
2779 gnu_inner
= gnu_type
;
2780 while (TREE_CODE (gnu_inner
) == RECORD_TYPE
2781 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner
)
2782 || TYPE_PADDING_P (gnu_inner
)))
2783 gnu_inner
= TREE_TYPE (TYPE_FIELDS (gnu_inner
));
2785 /* We need to attach the index type to the type we just made so
2786 that the actual bounds can later be put into a template. */
2787 if ((TREE_CODE (gnu_inner
) == ARRAY_TYPE
2788 && !TYPE_ACTUAL_BOUNDS (gnu_inner
))
2789 || (TREE_CODE (gnu_inner
) == INTEGER_TYPE
2790 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner
)))
2792 if (TREE_CODE (gnu_inner
) == INTEGER_TYPE
)
2794 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2795 TYPE_MODULUS for modular types so we make an extra
2796 subtype if necessary. */
2797 if (TYPE_MODULAR_P (gnu_inner
))
2800 = make_unsigned_type (TYPE_PRECISION (gnu_inner
));
2801 TREE_TYPE (gnu_subtype
) = gnu_inner
;
2802 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
2803 SET_TYPE_RM_MIN_VALUE (gnu_subtype
,
2804 TYPE_MIN_VALUE (gnu_inner
));
2805 SET_TYPE_RM_MAX_VALUE (gnu_subtype
,
2806 TYPE_MAX_VALUE (gnu_inner
));
2807 gnu_inner
= gnu_subtype
;
2810 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner
) = 1;
2812 #ifdef ENABLE_CHECKING
2813 /* Check for other cases of overloading. */
2814 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner
));
2818 for (gnat_index
= First_Index (gnat_entity
);
2819 Present (gnat_index
);
2820 gnat_index
= Next_Index (gnat_index
))
2821 SET_TYPE_ACTUAL_BOUNDS
2823 tree_cons (NULL_TREE
,
2824 get_unpadded_type (Etype (gnat_index
)),
2825 TYPE_ACTUAL_BOUNDS (gnu_inner
)));
2827 if (Convention (gnat_entity
) != Convention_Fortran
)
2828 SET_TYPE_ACTUAL_BOUNDS
2829 (gnu_inner
, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner
)));
2831 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2832 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
2833 TREE_TYPE (TYPE_FIELDS (gnu_type
)) = gnu_inner
;
2838 /* Abort if packed array with no Packed_Array_Type field set. */
2839 gcc_assert (!Is_Packed (gnat_entity
));
2843 case E_String_Literal_Subtype
:
2844 /* Create the type for a string literal. */
2846 Entity_Id gnat_full_type
2847 = (IN (Ekind (Etype (gnat_entity
)), Private_Kind
)
2848 && Present (Full_View (Etype (gnat_entity
)))
2849 ? Full_View (Etype (gnat_entity
)) : Etype (gnat_entity
));
2850 tree gnu_string_type
= get_unpadded_type (gnat_full_type
);
2851 tree gnu_string_array_type
2852 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type
))));
2853 tree gnu_string_index_type
2854 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2855 (TYPE_DOMAIN (gnu_string_array_type
))));
2856 tree gnu_lower_bound
2857 = convert (gnu_string_index_type
,
2858 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity
)));
2860 = UI_To_gnu (String_Literal_Length (gnat_entity
),
2861 gnu_string_index_type
);
2862 tree gnu_upper_bound
2863 = build_binary_op (PLUS_EXPR
, gnu_string_index_type
,
2865 int_const_binop (MINUS_EXPR
, gnu_length
,
2868 = create_index_type (convert (sizetype
, gnu_lower_bound
),
2869 convert (sizetype
, gnu_upper_bound
),
2870 create_range_type (gnu_string_index_type
,
2876 = build_nonshared_array_type (gnat_to_gnu_type
2877 (Component_Type (gnat_entity
)),
2879 if (array_type_has_nonaliased_component (gnu_type
, gnat_entity
))
2880 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2881 relate_alias_sets (gnu_type
, gnu_string_type
, ALIAS_SET_COPY
);
2885 /* Record Types and Subtypes
2887 The following fields are defined on record types:
2889 Has_Discriminants True if the record has discriminants
2890 First_Discriminant Points to head of list of discriminants
2891 First_Entity Points to head of list of fields
2892 Is_Tagged_Type True if the record is tagged
2894 Implementation of Ada records and discriminated records:
2896 A record type definition is transformed into the equivalent of a C
2897 struct definition. The fields that are the discriminants which are
2898 found in the Full_Type_Declaration node and the elements of the
2899 Component_List found in the Record_Type_Definition node. The
2900 Component_List can be a recursive structure since each Variant of
2901 the Variant_Part of the Component_List has a Component_List.
2903 Processing of a record type definition comprises starting the list of
2904 field declarations here from the discriminants and the calling the
2905 function components_to_record to add the rest of the fields from the
2906 component list and return the gnu type node. The function
2907 components_to_record will call itself recursively as it traverses
2911 if (Has_Complex_Representation (gnat_entity
))
2914 = build_complex_type
2916 (Etype (Defining_Entity
2917 (First (Component_Items
2920 (Declaration_Node (gnat_entity
)))))))));
2926 Node_Id full_definition
= Declaration_Node (gnat_entity
);
2927 Node_Id record_definition
= Type_Definition (full_definition
);
2928 Node_Id gnat_constr
;
2929 Entity_Id gnat_field
;
2930 tree gnu_field
, gnu_field_list
= NULL_TREE
;
2931 tree gnu_get_parent
;
2932 /* Set PACKED in keeping with gnat_to_gnu_field. */
2934 = Is_Packed (gnat_entity
)
2936 : Component_Alignment (gnat_entity
) == Calign_Storage_Unit
2938 : (Known_Alignment (gnat_entity
)
2939 || (Strict_Alignment (gnat_entity
)
2940 && Known_RM_Size (gnat_entity
)))
2943 const bool has_discr
= Has_Discriminants (gnat_entity
);
2944 const bool has_rep
= Has_Specified_Layout (gnat_entity
);
2945 const bool is_extension
2946 = (Is_Tagged_Type (gnat_entity
)
2947 && Nkind (record_definition
) == N_Derived_Type_Definition
);
2948 const bool is_unchecked_union
= Is_Unchecked_Union (gnat_entity
);
2949 bool all_rep
= has_rep
;
2951 /* See if all fields have a rep clause. Stop when we find one
2954 for (gnat_field
= First_Entity (gnat_entity
);
2955 Present (gnat_field
);
2956 gnat_field
= Next_Entity (gnat_field
))
2957 if ((Ekind (gnat_field
) == E_Component
2958 || Ekind (gnat_field
) == E_Discriminant
)
2959 && No (Component_Clause (gnat_field
)))
2965 /* If this is a record extension, go a level further to find the
2966 record definition. Also, verify we have a Parent_Subtype. */
2969 if (!type_annotate_only
2970 || Present (Record_Extension_Part (record_definition
)))
2971 record_definition
= Record_Extension_Part (record_definition
);
2973 gcc_assert (type_annotate_only
2974 || Present (Parent_Subtype (gnat_entity
)));
2977 /* Make a node for the record. If we are not defining the record,
2978 suppress expanding incomplete types. */
2979 gnu_type
= make_node (tree_code_for_record_type (gnat_entity
));
2980 TYPE_NAME (gnu_type
) = gnu_entity_name
;
2981 TYPE_PACKED (gnu_type
) = (packed
!= 0) || has_rep
;
2982 if (Reverse_Storage_Order (gnat_entity
))
2983 sorry ("non-default Scalar_Storage_Order");
2984 process_attributes (&gnu_type
, &attr_list
, true, gnat_entity
);
2988 defer_incomplete_level
++;
2989 this_deferred
= true;
2992 /* If both a size and rep clause was specified, put the size in
2993 the record type now so that it can get the proper mode. */
2994 if (has_rep
&& Known_RM_Size (gnat_entity
))
2995 TYPE_SIZE (gnu_type
)
2996 = UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
);
2998 /* Always set the alignment here so that it can be used to
2999 set the mode, if it is making the alignment stricter. If
3000 it is invalid, it will be checked again below. If this is to
3001 be Atomic, choose a default alignment of a word unless we know
3002 the size and it's smaller. */
3003 if (Known_Alignment (gnat_entity
))
3004 TYPE_ALIGN (gnu_type
)
3005 = validate_alignment (Alignment (gnat_entity
), gnat_entity
, 0);
3006 else if (Is_Atomic (gnat_entity
) && Known_Esize (gnat_entity
))
3008 unsigned int size
= UI_To_Int (Esize (gnat_entity
));
3009 TYPE_ALIGN (gnu_type
)
3010 = size
>= BITS_PER_WORD
? BITS_PER_WORD
: ceil_pow2 (size
);
3012 /* If a type needs strict alignment, the minimum size will be the
3013 type size instead of the RM size (see validate_size). Cap the
3014 alignment, lest it causes this type size to become too large. */
3015 else if (Strict_Alignment (gnat_entity
) && Known_RM_Size (gnat_entity
))
3017 unsigned int raw_size
= UI_To_Int (RM_Size (gnat_entity
));
3018 unsigned int raw_align
= raw_size
& -raw_size
;
3019 if (raw_align
< BIGGEST_ALIGNMENT
)
3020 TYPE_ALIGN (gnu_type
) = raw_align
;
3023 TYPE_ALIGN (gnu_type
) = 0;
3025 /* If we have a Parent_Subtype, make a field for the parent. If
3026 this record has rep clauses, force the position to zero. */
3027 if (Present (Parent_Subtype (gnat_entity
)))
3029 Entity_Id gnat_parent
= Parent_Subtype (gnat_entity
);
3030 tree gnu_dummy_parent_type
= make_node (RECORD_TYPE
);
3033 /* A major complexity here is that the parent subtype will
3034 reference our discriminants in its Stored_Constraint list.
3035 But those must reference the parent component of this record
3036 which is precisely of the parent subtype we have not built yet!
3037 To break the circle we first build a dummy COMPONENT_REF which
3038 represents the "get to the parent" operation and initialize
3039 each of those discriminants to a COMPONENT_REF of the above
3040 dummy parent referencing the corresponding discriminant of the
3041 base type of the parent subtype. */
3042 gnu_get_parent
= build3 (COMPONENT_REF
, gnu_dummy_parent_type
,
3043 build0 (PLACEHOLDER_EXPR
, gnu_type
),
3044 build_decl (input_location
,
3045 FIELD_DECL
, NULL_TREE
,
3046 gnu_dummy_parent_type
),
3050 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3051 Present (gnat_field
);
3052 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3053 if (Present (Corresponding_Discriminant (gnat_field
)))
3056 = gnat_to_gnu_field_decl (Corresponding_Discriminant
3060 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3061 gnu_get_parent
, gnu_field
, NULL_TREE
),
3065 /* Then we build the parent subtype. If it has discriminants but
3066 the type itself has unknown discriminants, this means that it
3067 doesn't contain information about how the discriminants are
3068 derived from those of the ancestor type, so it cannot be used
3069 directly. Instead it is built by cloning the parent subtype
3070 of the underlying record view of the type, for which the above
3071 derivation of discriminants has been made explicit. */
3072 if (Has_Discriminants (gnat_parent
)
3073 && Has_Unknown_Discriminants (gnat_entity
))
3075 Entity_Id gnat_uview
= Underlying_Record_View (gnat_entity
);
3077 /* If we are defining the type, the underlying record
3078 view must already have been elaborated at this point.
3079 Otherwise do it now as its parent subtype cannot be
3080 technically elaborated on its own. */
3082 gcc_assert (present_gnu_tree (gnat_uview
));
3084 gnat_to_gnu_entity (gnat_uview
, NULL_TREE
, 0);
3086 gnu_parent
= gnat_to_gnu_type (Parent_Subtype (gnat_uview
));
3088 /* Substitute the "get to the parent" of the type for that
3089 of its underlying record view in the cloned type. */
3090 for (gnat_field
= First_Stored_Discriminant (gnat_uview
);
3091 Present (gnat_field
);
3092 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3093 if (Present (Corresponding_Discriminant (gnat_field
)))
3095 tree gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
3097 = build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3098 gnu_get_parent
, gnu_field
, NULL_TREE
);
3100 = substitute_in_type (gnu_parent
, gnu_field
, gnu_ref
);
3104 gnu_parent
= gnat_to_gnu_type (gnat_parent
);
3106 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
3107 initially built. The discriminants must reference the fields
3108 of the parent subtype and not those of its base type for the
3109 placeholder machinery to properly work. */
3112 /* The actual parent subtype is the full view. */
3113 if (IN (Ekind (gnat_parent
), Private_Kind
))
3115 if (Present (Full_View (gnat_parent
)))
3116 gnat_parent
= Full_View (gnat_parent
);
3118 gnat_parent
= Underlying_Full_View (gnat_parent
);
3121 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3122 Present (gnat_field
);
3123 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3124 if (Present (Corresponding_Discriminant (gnat_field
)))
3126 Entity_Id field
= Empty
;
3127 for (field
= First_Stored_Discriminant (gnat_parent
);
3129 field
= Next_Stored_Discriminant (field
))
3130 if (same_discriminant_p (gnat_field
, field
))
3132 gcc_assert (Present (field
));
3133 TREE_OPERAND (get_gnu_tree (gnat_field
), 1)
3134 = gnat_to_gnu_field_decl (field
);
3138 /* The "get to the parent" COMPONENT_REF must be given its
3140 TREE_TYPE (gnu_get_parent
) = gnu_parent
;
3142 /* ...and reference the _Parent field of this record. */
3144 = create_field_decl (parent_name_id
,
3145 gnu_parent
, gnu_type
,
3147 ? TYPE_SIZE (gnu_parent
) : NULL_TREE
,
3149 ? bitsize_zero_node
: NULL_TREE
,
3151 DECL_INTERNAL_P (gnu_field
) = 1;
3152 TREE_OPERAND (gnu_get_parent
, 1) = gnu_field
;
3153 TYPE_FIELDS (gnu_type
) = gnu_field
;
3156 /* Make the fields for the discriminants and put them into the record
3157 unless it's an Unchecked_Union. */
3159 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
3160 Present (gnat_field
);
3161 gnat_field
= Next_Stored_Discriminant (gnat_field
))
3163 /* If this is a record extension and this discriminant is the
3164 renaming of another discriminant, we've handled it above. */
3165 if (Present (Parent_Subtype (gnat_entity
))
3166 && Present (Corresponding_Discriminant (gnat_field
)))
3170 = gnat_to_gnu_field (gnat_field
, gnu_type
, packed
, definition
,
3173 /* Make an expression using a PLACEHOLDER_EXPR from the
3174 FIELD_DECL node just created and link that with the
3175 corresponding GNAT defining identifier. */
3176 save_gnu_tree (gnat_field
,
3177 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
3178 build0 (PLACEHOLDER_EXPR
, gnu_type
),
3179 gnu_field
, NULL_TREE
),
3182 if (!is_unchecked_union
)
3184 DECL_CHAIN (gnu_field
) = gnu_field_list
;
3185 gnu_field_list
= gnu_field
;
3189 /* If we have a derived untagged type that renames discriminants in
3190 the root type, the (stored) discriminants are a just copy of the
3191 discriminants of the root type. This means that any constraints
3192 added by the renaming in the derivation are disregarded as far
3193 as the layout of the derived type is concerned. To rescue them,
3194 we change the type of the (stored) discriminants to a subtype
3195 with the bounds of the type of the visible discriminants. */
3198 && Stored_Constraint (gnat_entity
) != No_Elist
)
3199 for (gnat_constr
= First_Elmt (Stored_Constraint (gnat_entity
));
3200 gnat_constr
!= No_Elmt
;
3201 gnat_constr
= Next_Elmt (gnat_constr
))
3202 if (Nkind (Node (gnat_constr
)) == N_Identifier
3203 /* Ignore access discriminants. */
3204 && !Is_Access_Type (Etype (Node (gnat_constr
)))
3205 && Ekind (Entity (Node (gnat_constr
))) == E_Discriminant
)
3207 Entity_Id gnat_discr
= Entity (Node (gnat_constr
));
3208 tree gnu_discr_type
= gnat_to_gnu_type (Etype (gnat_discr
));
3210 = gnat_to_gnu_entity (Original_Record_Component (gnat_discr
),
3213 /* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
3214 just above for one of the stored discriminants. */
3215 gcc_assert (TREE_TYPE (TREE_OPERAND (gnu_ref
, 0)) == gnu_type
);
3217 if (gnu_discr_type
!= TREE_TYPE (gnu_ref
))
3219 const unsigned prec
= TYPE_PRECISION (TREE_TYPE (gnu_ref
));
3221 = TYPE_UNSIGNED (TREE_TYPE (gnu_ref
))
3222 ? make_unsigned_type (prec
) : make_signed_type (prec
);
3223 TREE_TYPE (gnu_subtype
) = TREE_TYPE (gnu_ref
);
3224 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
3225 SET_TYPE_RM_MIN_VALUE (gnu_subtype
,
3226 TYPE_MIN_VALUE (gnu_discr_type
));
3227 SET_TYPE_RM_MAX_VALUE (gnu_subtype
,
3228 TYPE_MAX_VALUE (gnu_discr_type
));
3230 = TREE_TYPE (TREE_OPERAND (gnu_ref
, 1)) = gnu_subtype
;
3234 /* Add the fields into the record type and finish it up. */
3235 components_to_record (gnu_type
, Component_List (record_definition
),
3236 gnu_field_list
, packed
, definition
, false,
3237 all_rep
, is_unchecked_union
,
3238 !Comes_From_Source (gnat_entity
), debug_info_p
,
3239 false, OK_To_Reorder_Components (gnat_entity
),
3240 all_rep
? NULL_TREE
: bitsize_zero_node
, NULL
);
3242 /* If it is passed by reference, force BLKmode to ensure that objects
3243 of this type will always be put in memory. */
3244 if (TYPE_MODE (gnu_type
) != BLKmode
3245 && Is_By_Reference_Type (gnat_entity
))
3246 SET_TYPE_MODE (gnu_type
, BLKmode
);
3248 /* We used to remove the associations of the discriminants and _Parent
3249 for validity checking but we may need them if there's a Freeze_Node
3250 for a subtype used in this record. */
3251 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
3253 /* Fill in locations of fields. */
3254 annotate_rep (gnat_entity
, gnu_type
);
3256 /* If there are any entities in the chain corresponding to components
3257 that we did not elaborate, ensure we elaborate their types if they
3259 for (gnat_temp
= First_Entity (gnat_entity
);
3260 Present (gnat_temp
);
3261 gnat_temp
= Next_Entity (gnat_temp
))
3262 if ((Ekind (gnat_temp
) == E_Component
3263 || Ekind (gnat_temp
) == E_Discriminant
)
3264 && Is_Itype (Etype (gnat_temp
))
3265 && !present_gnu_tree (gnat_temp
))
3266 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
3268 /* If this is a record type associated with an exception definition,
3269 equate its fields to those of the standard exception type. This
3270 will make it possible to convert between them. */
3271 if (gnu_entity_name
== exception_data_name_id
)
3274 for (gnu_field
= TYPE_FIELDS (gnu_type
),
3275 gnu_std_field
= TYPE_FIELDS (except_type_node
);
3277 gnu_field
= DECL_CHAIN (gnu_field
),
3278 gnu_std_field
= DECL_CHAIN (gnu_std_field
))
3279 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field
, gnu_std_field
);
3280 gcc_assert (!gnu_std_field
);
3285 case E_Class_Wide_Subtype
:
3286 /* If an equivalent type is present, that is what we should use.
3287 Otherwise, fall through to handle this like a record subtype
3288 since it may have constraints. */
3289 if (gnat_equiv_type
!= gnat_entity
)
3291 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
3292 maybe_present
= true;
3296 /* ... fall through ... */
3298 case E_Record_Subtype
:
3299 /* If Cloned_Subtype is Present it means this record subtype has
3300 identical layout to that type or subtype and we should use
3301 that GCC type for this one. The front end guarantees that
3302 the component list is shared. */
3303 if (Present (Cloned_Subtype (gnat_entity
)))
3305 gnu_decl
= gnat_to_gnu_entity (Cloned_Subtype (gnat_entity
),
3307 maybe_present
= true;
3311 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3312 changing the type, make a new type with each field having the type of
3313 the field in the new subtype but the position computed by transforming
3314 every discriminant reference according to the constraints. We don't
3315 see any difference between private and non-private type here since
3316 derivations from types should have been deferred until the completion
3317 of the private type. */
3320 Entity_Id gnat_base_type
= Implementation_Base_Type (gnat_entity
);
3325 defer_incomplete_level
++;
3326 this_deferred
= true;
3329 gnu_base_type
= gnat_to_gnu_type (gnat_base_type
);
3331 if (present_gnu_tree (gnat_entity
))
3333 maybe_present
= true;
3337 /* If this is a record subtype associated with a dispatch table,
3338 strip the suffix. This is necessary to make sure 2 different
3339 subtypes associated with the imported and exported views of a
3340 dispatch table are properly merged in LTO mode. */
3341 if (Is_Dispatch_Table_Entity (gnat_entity
))
3344 Get_Encoded_Name (gnat_entity
);
3345 p
= strchr (Name_Buffer
, '_');
3347 strcpy (p
+2, "dtS");
3348 gnu_entity_name
= get_identifier (Name_Buffer
);
3351 /* When the subtype has discriminants and these discriminants affect
3352 the initial shape it has inherited, factor them in. But for an
3353 Unchecked_Union (it must be an Itype), just return the type.
3354 We can't just test Is_Constrained because private subtypes without
3355 discriminants of types with discriminants with default expressions
3356 are Is_Constrained but aren't constrained! */
3357 if (IN (Ekind (gnat_base_type
), Record_Kind
)
3358 && !Is_Unchecked_Union (gnat_base_type
)
3359 && !Is_For_Access_Subtype (gnat_entity
)
3360 && Has_Discriminants (gnat_entity
)
3361 && Is_Constrained (gnat_entity
)
3362 && Stored_Constraint (gnat_entity
) != No_Elist
)
3364 vec
<subst_pair
> gnu_subst_list
3365 = build_subst_list (gnat_entity
, gnat_base_type
, definition
);
3366 tree gnu_unpad_base_type
, gnu_rep_part
, gnu_variant_part
, t
;
3367 tree gnu_pos_list
, gnu_field_list
= NULL_TREE
;
3368 bool selected_variant
= false;
3369 Entity_Id gnat_field
;
3370 vec
<variant_desc
> gnu_variant_list
;
3372 gnu_type
= make_node (RECORD_TYPE
);
3373 TYPE_NAME (gnu_type
) = gnu_entity_name
;
3374 TYPE_PACKED (gnu_type
) = TYPE_PACKED (gnu_base_type
);
3375 process_attributes (&gnu_type
, &attr_list
, true, gnat_entity
);
3377 /* Set the size, alignment and alias set of the new type to
3378 match that of the old one, doing required substitutions. */
3379 copy_and_substitute_in_size (gnu_type
, gnu_base_type
,
3382 if (TYPE_IS_PADDING_P (gnu_base_type
))
3383 gnu_unpad_base_type
= TREE_TYPE (TYPE_FIELDS (gnu_base_type
));
3385 gnu_unpad_base_type
= gnu_base_type
;
3387 /* Look for a variant part in the base type. */
3388 gnu_variant_part
= get_variant_part (gnu_unpad_base_type
);
3390 /* If there is a variant part, we must compute whether the
3391 constraints statically select a particular variant. If
3392 so, we simply drop the qualified union and flatten the
3393 list of fields. Otherwise we'll build a new qualified
3394 union for the variants that are still relevant. */
3395 if (gnu_variant_part
)
3401 = build_variant_list (TREE_TYPE (gnu_variant_part
),
3405 /* If all the qualifiers are unconditionally true, the
3406 innermost variant is statically selected. */
3407 selected_variant
= true;
3408 FOR_EACH_VEC_ELT (gnu_variant_list
, i
, v
)
3409 if (!integer_onep (v
->qual
))
3411 selected_variant
= false;
3415 /* Otherwise, create the new variants. */
3416 if (!selected_variant
)
3417 FOR_EACH_VEC_ELT (gnu_variant_list
, i
, v
)
3419 tree old_variant
= v
->type
;
3420 tree new_variant
= make_node (RECORD_TYPE
);
3422 = concat_name (DECL_NAME (gnu_variant_part
),
3424 (DECL_NAME (v
->field
)));
3425 TYPE_NAME (new_variant
)
3426 = concat_name (TYPE_NAME (gnu_type
),
3427 IDENTIFIER_POINTER (suffix
));
3428 copy_and_substitute_in_size (new_variant
, old_variant
,
3430 v
->new_type
= new_variant
;
3435 gnu_variant_list
.create (0);
3436 selected_variant
= false;
3440 = build_position_list (gnu_unpad_base_type
,
3441 gnu_variant_list
.exists ()
3442 && !selected_variant
,
3443 size_zero_node
, bitsize_zero_node
,
3444 BIGGEST_ALIGNMENT
, NULL_TREE
);
3446 for (gnat_field
= First_Entity (gnat_entity
);
3447 Present (gnat_field
);
3448 gnat_field
= Next_Entity (gnat_field
))
3449 if ((Ekind (gnat_field
) == E_Component
3450 || Ekind (gnat_field
) == E_Discriminant
)
3451 && !(Present (Corresponding_Discriminant (gnat_field
))
3452 && Is_Tagged_Type (gnat_base_type
))
3453 && Underlying_Type (Scope (Original_Record_Component
3457 Name_Id gnat_name
= Chars (gnat_field
);
3458 Entity_Id gnat_old_field
3459 = Original_Record_Component (gnat_field
);
3461 = gnat_to_gnu_field_decl (gnat_old_field
);
3462 tree gnu_context
= DECL_CONTEXT (gnu_old_field
);
3463 tree gnu_field
, gnu_field_type
, gnu_size
;
3464 tree gnu_cont_type
, gnu_last
= NULL_TREE
;
3466 /* If the type is the same, retrieve the GCC type from the
3467 old field to take into account possible adjustments. */
3468 if (Etype (gnat_field
) == Etype (gnat_old_field
))
3469 gnu_field_type
= TREE_TYPE (gnu_old_field
);
3471 gnu_field_type
= gnat_to_gnu_type (Etype (gnat_field
));
3473 /* If there was a component clause, the field types must be
3474 the same for the type and subtype, so copy the data from
3475 the old field to avoid recomputation here. Also if the
3476 field is justified modular and the optimization in
3477 gnat_to_gnu_field was applied. */
3478 if (Present (Component_Clause (gnat_old_field
))
3479 || (TREE_CODE (gnu_field_type
) == RECORD_TYPE
3480 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
3481 && TREE_TYPE (TYPE_FIELDS (gnu_field_type
))
3482 == TREE_TYPE (gnu_old_field
)))
3484 gnu_size
= DECL_SIZE (gnu_old_field
);
3485 gnu_field_type
= TREE_TYPE (gnu_old_field
);
3488 /* If the old field was packed and of constant size, we
3489 have to get the old size here, as it might differ from
3490 what the Etype conveys and the latter might overlap
3491 onto the following field. Try to arrange the type for
3492 possible better packing along the way. */
3493 else if (DECL_PACKED (gnu_old_field
)
3494 && TREE_CODE (DECL_SIZE (gnu_old_field
))
3497 gnu_size
= DECL_SIZE (gnu_old_field
);
3498 if (RECORD_OR_UNION_TYPE_P (gnu_field_type
)
3499 && !TYPE_FAT_POINTER_P (gnu_field_type
)
3500 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type
)))
3502 = make_packable_type (gnu_field_type
, true);
3506 gnu_size
= TYPE_SIZE (gnu_field_type
);
3508 /* If the context of the old field is the base type or its
3509 REP part (if any), put the field directly in the new
3510 type; otherwise look up the context in the variant list
3511 and put the field either in the new type if there is a
3512 selected variant or in one of the new variants. */
3513 if (gnu_context
== gnu_unpad_base_type
3514 || ((gnu_rep_part
= get_rep_part (gnu_unpad_base_type
))
3515 && gnu_context
== TREE_TYPE (gnu_rep_part
)))
3516 gnu_cont_type
= gnu_type
;
3523 FOR_EACH_VEC_ELT (gnu_variant_list
, i
, v
)
3524 if (gnu_context
== v
->type
3525 || ((gnu_rep_part
= get_rep_part (v
->type
))
3526 && gnu_context
== TREE_TYPE (gnu_rep_part
)))
3533 if (selected_variant
)
3534 gnu_cont_type
= gnu_type
;
3536 gnu_cont_type
= v
->new_type
;
3539 /* The front-end may pass us "ghost" components if
3540 it fails to recognize that a constrained subtype
3541 is statically constrained. Discard them. */
3545 /* Now create the new field modeled on the old one. */
3547 = create_field_decl_from (gnu_old_field
, gnu_field_type
,
3548 gnu_cont_type
, gnu_size
,
3549 gnu_pos_list
, gnu_subst_list
);
3551 /* Put it in one of the new variants directly. */
3552 if (gnu_cont_type
!= gnu_type
)
3554 DECL_CHAIN (gnu_field
) = TYPE_FIELDS (gnu_cont_type
);
3555 TYPE_FIELDS (gnu_cont_type
) = gnu_field
;
3558 /* To match the layout crafted in components_to_record,
3559 if this is the _Tag or _Parent field, put it before
3560 any other fields. */
3561 else if (gnat_name
== Name_uTag
3562 || gnat_name
== Name_uParent
)
3563 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
3565 /* Similarly, if this is the _Controller field, put
3566 it before the other fields except for the _Tag or
3568 else if (gnat_name
== Name_uController
&& gnu_last
)
3570 DECL_CHAIN (gnu_field
) = DECL_CHAIN (gnu_last
);
3571 DECL_CHAIN (gnu_last
) = gnu_field
;
3574 /* Otherwise, if this is a regular field, put it after
3575 the other fields. */
3578 DECL_CHAIN (gnu_field
) = gnu_field_list
;
3579 gnu_field_list
= gnu_field
;
3581 gnu_last
= gnu_field
;
3584 save_gnu_tree (gnat_field
, gnu_field
, false);
3587 /* If there is a variant list and no selected variant, we need
3588 to create the nest of variant parts from the old nest. */
3589 if (gnu_variant_list
.exists () && !selected_variant
)
3591 tree new_variant_part
3592 = create_variant_part_from (gnu_variant_part
,
3593 gnu_variant_list
, gnu_type
,
3594 gnu_pos_list
, gnu_subst_list
);
3595 DECL_CHAIN (new_variant_part
) = gnu_field_list
;
3596 gnu_field_list
= new_variant_part
;
3599 /* Now go through the entities again looking for Itypes that
3600 we have not elaborated but should (e.g., Etypes of fields
3601 that have Original_Components). */
3602 for (gnat_field
= First_Entity (gnat_entity
);
3603 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
3604 if ((Ekind (gnat_field
) == E_Discriminant
3605 || Ekind (gnat_field
) == E_Component
)
3606 && !present_gnu_tree (Etype (gnat_field
)))
3607 gnat_to_gnu_entity (Etype (gnat_field
), NULL_TREE
, 0);
3609 /* Do not emit debug info for the type yet since we're going to
3611 finish_record_type (gnu_type
, nreverse (gnu_field_list
), 2,
3613 compute_record_mode (gnu_type
);
3615 /* See the E_Record_Type case for the rationale. */
3616 if (TYPE_MODE (gnu_type
) != BLKmode
3617 && Is_By_Reference_Type (gnat_entity
))
3618 SET_TYPE_MODE (gnu_type
, BLKmode
);
3620 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
3622 /* Fill in locations of fields. */
3623 annotate_rep (gnat_entity
, gnu_type
);
3625 /* If debugging information is being written for the type, write
3626 a record that shows what we are a subtype of and also make a
3627 variable that indicates our size, if still variable. */
3630 tree gnu_subtype_marker
= make_node (RECORD_TYPE
);
3631 tree gnu_unpad_base_name
= TYPE_NAME (gnu_unpad_base_type
);
3632 tree gnu_size_unit
= TYPE_SIZE_UNIT (gnu_type
);
3634 if (TREE_CODE (gnu_unpad_base_name
) == TYPE_DECL
)
3635 gnu_unpad_base_name
= DECL_NAME (gnu_unpad_base_name
);
3637 TYPE_NAME (gnu_subtype_marker
)
3638 = create_concat_name (gnat_entity
, "XVS");
3639 finish_record_type (gnu_subtype_marker
,
3640 create_field_decl (gnu_unpad_base_name
,
3641 build_reference_type
3642 (gnu_unpad_base_type
),
3644 NULL_TREE
, NULL_TREE
,
3648 add_parallel_type (gnu_type
, gnu_subtype_marker
);
3651 && TREE_CODE (gnu_size_unit
) != INTEGER_CST
3652 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit
))
3653 TYPE_SIZE_UNIT (gnu_subtype_marker
)
3654 = create_var_decl (create_concat_name (gnat_entity
,
3656 NULL_TREE
, sizetype
, gnu_size_unit
,
3657 false, false, false, false, NULL
,
3661 gnu_variant_list
.release ();
3662 gnu_subst_list
.release ();
3664 /* Now we can finalize it. */
3665 rest_of_record_type_compilation (gnu_type
);
3668 /* Otherwise, go down all the components in the new type and make
3669 them equivalent to those in the base type. */
3672 gnu_type
= gnu_base_type
;
3674 for (gnat_temp
= First_Entity (gnat_entity
);
3675 Present (gnat_temp
);
3676 gnat_temp
= Next_Entity (gnat_temp
))
3677 if ((Ekind (gnat_temp
) == E_Discriminant
3678 && !Is_Unchecked_Union (gnat_base_type
))
3679 || Ekind (gnat_temp
) == E_Component
)
3680 save_gnu_tree (gnat_temp
,
3681 gnat_to_gnu_field_decl
3682 (Original_Record_Component (gnat_temp
)),
3688 case E_Access_Subprogram_Type
:
3689 /* Use the special descriptor type for dispatch tables if needed,
3690 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3691 Note that we are only required to do so for static tables in
3692 order to be compatible with the C++ ABI, but Ada 2005 allows
3693 to extend library level tagged types at the local level so
3694 we do it in the non-static case as well. */
3695 if (TARGET_VTABLE_USES_DESCRIPTORS
3696 && Is_Dispatch_Table_Entity (gnat_entity
))
3698 gnu_type
= fdesc_type_node
;
3699 gnu_size
= TYPE_SIZE (gnu_type
);
3703 /* ... fall through ... */
3705 case E_Anonymous_Access_Subprogram_Type
:
3706 /* If we are not defining this entity, and we have incomplete
3707 entities being processed above us, make a dummy type and
3708 fill it in later. */
3709 if (!definition
&& defer_incomplete_level
!= 0)
3711 struct incomplete
*p
= XNEW (struct incomplete
);
3714 = build_pointer_type
3715 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
3716 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
,
3717 !Comes_From_Source (gnat_entity
),
3718 debug_info_p
, gnat_entity
);
3719 this_made_decl
= true;
3720 gnu_type
= TREE_TYPE (gnu_decl
);
3721 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3724 p
->old_type
= TREE_TYPE (gnu_type
);
3725 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3726 p
->next
= defer_incomplete_list
;
3727 defer_incomplete_list
= p
;
3731 /* ... fall through ... */
3733 case E_Allocator_Type
:
3735 case E_Access_Attribute_Type
:
3736 case E_Anonymous_Access_Type
:
3737 case E_General_Access_Type
:
3739 /* The designated type and its equivalent type for gigi. */
3740 Entity_Id gnat_desig_type
= Directly_Designated_Type (gnat_entity
);
3741 Entity_Id gnat_desig_equiv
= Gigi_Equivalent_Type (gnat_desig_type
);
3742 /* Whether it comes from a limited with. */
3743 bool is_from_limited_with
3744 = (IN (Ekind (gnat_desig_equiv
), Incomplete_Kind
)
3745 && From_Limited_With (gnat_desig_equiv
));
3746 /* The "full view" of the designated type. If this is an incomplete
3747 entity from a limited with, treat its non-limited view as the full
3748 view. Otherwise, if this is an incomplete or private type, use the
3749 full view. In the former case, we might point to a private type,
3750 in which case, we need its full view. Also, we want to look at the
3751 actual type used for the representation, so this takes a total of
3753 Entity_Id gnat_desig_full_direct_first
3754 = (is_from_limited_with
3755 ? Non_Limited_View (gnat_desig_equiv
)
3756 : (IN (Ekind (gnat_desig_equiv
), Incomplete_Or_Private_Kind
)
3757 ? Full_View (gnat_desig_equiv
) : Empty
));
3758 Entity_Id gnat_desig_full_direct
3759 = ((is_from_limited_with
3760 && Present (gnat_desig_full_direct_first
)
3761 && IN (Ekind (gnat_desig_full_direct_first
), Private_Kind
))
3762 ? Full_View (gnat_desig_full_direct_first
)
3763 : gnat_desig_full_direct_first
);
3764 Entity_Id gnat_desig_full
3765 = Gigi_Equivalent_Type (gnat_desig_full_direct
);
3766 /* The type actually used to represent the designated type, either
3767 gnat_desig_full or gnat_desig_equiv. */
3768 Entity_Id gnat_desig_rep
;
3769 /* True if this is a pointer to an unconstrained array. */
3770 bool is_unconstrained_array
;
3771 /* We want to know if we'll be seeing the freeze node for any
3772 incomplete type we may be pointing to. */
3774 = (Present (gnat_desig_full
)
3775 ? In_Extended_Main_Code_Unit (gnat_desig_full
)
3776 : In_Extended_Main_Code_Unit (gnat_desig_type
));
3777 /* True if we make a dummy type here. */
3778 bool made_dummy
= false;
3779 /* The mode to be used for the pointer type. */
3780 enum machine_mode p_mode
= mode_for_size (esize
, MODE_INT
, 0);
3781 /* The GCC type used for the designated type. */
3782 tree gnu_desig_type
= NULL_TREE
;
3784 if (!targetm
.valid_pointer_mode (p_mode
))
3787 /* If either the designated type or its full view is an unconstrained
3788 array subtype, replace it with the type it's a subtype of. This
3789 avoids problems with multiple copies of unconstrained array types.
3790 Likewise, if the designated type is a subtype of an incomplete
3791 record type, use the parent type to avoid order of elaboration
3792 issues. This can lose some code efficiency, but there is no
3794 if (Ekind (gnat_desig_equiv
) == E_Array_Subtype
3795 && !Is_Constrained (gnat_desig_equiv
))
3796 gnat_desig_equiv
= Etype (gnat_desig_equiv
);
3797 if (Present (gnat_desig_full
)
3798 && ((Ekind (gnat_desig_full
) == E_Array_Subtype
3799 && !Is_Constrained (gnat_desig_full
))
3800 || (Ekind (gnat_desig_full
) == E_Record_Subtype
3801 && Ekind (Etype (gnat_desig_full
)) == E_Record_Type
)))
3802 gnat_desig_full
= Etype (gnat_desig_full
);
3804 /* Set the type that's actually the representation of the designated
3805 type and also flag whether we have a unconstrained array. */
3807 = Present (gnat_desig_full
) ? gnat_desig_full
: gnat_desig_equiv
;
3808 is_unconstrained_array
3809 = Is_Array_Type (gnat_desig_rep
) && !Is_Constrained (gnat_desig_rep
);
3811 /* If we are pointing to an incomplete type whose completion is an
3812 unconstrained array, make dummy fat and thin pointer types to it.
3813 Likewise if the type itself is dummy or an unconstrained array. */
3814 if (is_unconstrained_array
3815 && (Present (gnat_desig_full
)
3816 || (present_gnu_tree (gnat_desig_equiv
)
3818 (TREE_TYPE (get_gnu_tree (gnat_desig_equiv
))))
3820 && defer_incomplete_level
!= 0
3821 && !present_gnu_tree (gnat_desig_equiv
))
3823 && is_from_limited_with
3824 && Present (Freeze_Node (gnat_desig_equiv
)))))
3826 if (present_gnu_tree (gnat_desig_rep
))
3827 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_rep
));
3830 gnu_desig_type
= make_dummy_type (gnat_desig_rep
);
3834 /* If the call above got something that has a pointer, the pointer
3835 is our type. This could have happened either because the type
3836 was elaborated or because somebody else executed the code. */
3837 if (!TYPE_POINTER_TO (gnu_desig_type
))
3838 build_dummy_unc_pointer_types (gnat_desig_equiv
, gnu_desig_type
);
3839 gnu_type
= TYPE_POINTER_TO (gnu_desig_type
);
3842 /* If we already know what the full type is, use it. */
3843 else if (Present (gnat_desig_full
)
3844 && present_gnu_tree (gnat_desig_full
))
3845 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_full
));
3847 /* Get the type of the thing we are to point to and build a pointer to
3848 it. If it is a reference to an incomplete or private type with a
3849 full view that is a record, make a dummy type node and get the
3850 actual type later when we have verified it is safe. */
3851 else if ((!in_main_unit
3852 && !present_gnu_tree (gnat_desig_equiv
)
3853 && Present (gnat_desig_full
)
3854 && !present_gnu_tree (gnat_desig_full
)
3855 && Is_Record_Type (gnat_desig_full
))
3856 /* Likewise if we are pointing to a record or array and we are
3857 to defer elaborating incomplete types. We do this as this
3858 access type may be the full view of a private type. Note
3859 that the unconstrained array case is handled above. */
3860 || ((!in_main_unit
|| imported_p
)
3861 && defer_incomplete_level
!= 0
3862 && !present_gnu_tree (gnat_desig_equiv
)
3863 && (Is_Record_Type (gnat_desig_rep
)
3864 || Is_Array_Type (gnat_desig_rep
)))
3865 /* If this is a reference from a limited_with type back to our
3866 main unit and there's a freeze node for it, either we have
3867 already processed the declaration and made the dummy type,
3868 in which case we just reuse the latter, or we have not yet,
3869 in which case we make the dummy type and it will be reused
3870 when the declaration is finally processed. In both cases,
3871 the pointer eventually created below will be automatically
3872 adjusted when the freeze node is processed. Note that the
3873 unconstrained array case is handled above. */
3875 && is_from_limited_with
3876 && Present (Freeze_Node (gnat_desig_rep
))))
3878 gnu_desig_type
= make_dummy_type (gnat_desig_equiv
);
3882 /* Otherwise handle the case of a pointer to itself. */
3883 else if (gnat_desig_equiv
== gnat_entity
)
3886 = build_pointer_type_for_mode (void_type_node
, p_mode
,
3887 No_Strict_Aliasing (gnat_entity
));
3888 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
) = gnu_type
;
3891 /* If expansion is disabled, the equivalent type of a concurrent type
3892 is absent, so build a dummy pointer type. */
3893 else if (type_annotate_only
&& No (gnat_desig_equiv
))
3894 gnu_type
= ptr_void_type_node
;
3896 /* Finally, handle the default case where we can just elaborate our
3899 gnu_desig_type
= gnat_to_gnu_type (gnat_desig_equiv
);
3901 /* It is possible that a call to gnat_to_gnu_type above resolved our
3902 type. If so, just return it. */
3903 if (present_gnu_tree (gnat_entity
))
3905 maybe_present
= true;
3909 /* If we haven't done it yet, build the pointer type the usual way. */
3912 /* Modify the designated type if we are pointing only to constant
3913 objects, but don't do it for unconstrained arrays. */
3914 if (Is_Access_Constant (gnat_entity
)
3915 && TREE_CODE (gnu_desig_type
) != UNCONSTRAINED_ARRAY_TYPE
)
3918 = build_qualified_type
3920 TYPE_QUALS (gnu_desig_type
) | TYPE_QUAL_CONST
);
3922 /* Some extra processing is required if we are building a
3923 pointer to an incomplete type (in the GCC sense). We might
3924 have such a type if we just made a dummy, or directly out
3925 of the call to gnat_to_gnu_type above if we are processing
3926 an access type for a record component designating the
3927 record type itself. */
3928 if (TYPE_MODE (gnu_desig_type
) == VOIDmode
)
3930 /* We must ensure that the pointer to variant we make will
3931 be processed by update_pointer_to when the initial type
3932 is completed. Pretend we made a dummy and let further
3933 processing act as usual. */
3936 /* We must ensure that update_pointer_to will not retrieve
3937 the dummy variant when building a properly qualified
3938 version of the complete type. We take advantage of the
3939 fact that get_qualified_type is requiring TYPE_NAMEs to
3940 match to influence build_qualified_type and then also
3941 update_pointer_to here. */
3942 TYPE_NAME (gnu_desig_type
)
3943 = create_concat_name (gnat_desig_type
, "INCOMPLETE_CST");
3948 = build_pointer_type_for_mode (gnu_desig_type
, p_mode
,
3949 No_Strict_Aliasing (gnat_entity
));
3952 /* If we are not defining this object and we have made a dummy pointer,
3953 save our current definition, evaluate the actual type, and replace
3954 the tentative type we made with the actual one. If we are to defer
3955 actually looking up the actual type, make an entry in the deferred
3956 list. If this is from a limited with, we may have to defer to the
3957 end of the current unit. */
3958 if ((!in_main_unit
|| is_from_limited_with
) && made_dummy
)
3960 tree gnu_old_desig_type
;
3962 if (TYPE_IS_FAT_POINTER_P (gnu_type
))
3964 gnu_old_desig_type
= TYPE_UNCONSTRAINED_ARRAY (gnu_type
);
3965 if (esize
== POINTER_SIZE
)
3966 gnu_type
= build_pointer_type
3967 (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type
));
3970 gnu_old_desig_type
= TREE_TYPE (gnu_type
);
3972 process_attributes (&gnu_type
, &attr_list
, false, gnat_entity
);
3973 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
,
3974 !Comes_From_Source (gnat_entity
),
3975 debug_info_p
, gnat_entity
);
3976 this_made_decl
= true;
3977 gnu_type
= TREE_TYPE (gnu_decl
);
3978 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3981 /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
3982 update gnu_old_desig_type directly, in which case it will not be
3983 a dummy type any more when we get into update_pointer_to.
3985 This can happen e.g. when the designated type is a record type,
3986 because their elaboration starts with an initial node from
3987 make_dummy_type, which may be the same node as the one we got.
3989 Besides, variants of this non-dummy type might have been created
3990 along the way. update_pointer_to is expected to properly take
3991 care of those situations. */
3992 if (defer_incomplete_level
== 0 && !is_from_limited_with
)
3994 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type
),
3995 gnat_to_gnu_type (gnat_desig_equiv
));
3999 struct incomplete
*p
= XNEW (struct incomplete
);
4000 struct incomplete
**head
4001 = (is_from_limited_with
4002 ? &defer_limited_with
: &defer_incomplete_list
);
4003 p
->old_type
= gnu_old_desig_type
;
4004 p
->full_type
= gnat_desig_equiv
;
4012 case E_Access_Protected_Subprogram_Type
:
4013 case E_Anonymous_Access_Protected_Subprogram_Type
:
4014 if (type_annotate_only
&& No (gnat_equiv_type
))
4015 gnu_type
= ptr_void_type_node
;
4018 /* The run-time representation is the equivalent type. */
4019 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
4020 maybe_present
= true;
4023 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
4024 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
4025 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
)))
4026 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity
))))
4027 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
4032 case E_Access_Subtype
:
4034 /* We treat this as identical to its base type; any constraint is
4035 meaningful only to the front-end.
4037 The designated type must be elaborated as well, if it does
4038 not have its own freeze node. Designated (sub)types created
4039 for constrained components of records with discriminants are
4040 not frozen by the front-end and thus not elaborated by gigi,
4041 because their use may appear before the base type is frozen,
4042 and because it is not clear that they are needed anywhere in
4043 gigi. With the current model, there is no correct place where
4044 they could be elaborated. */
4046 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
4047 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
4048 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
4049 && Is_Frozen (Directly_Designated_Type (gnat_entity
))
4050 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
))))
4052 /* If we are not defining this entity, and we have incomplete
4053 entities being processed above us, make a dummy type and
4054 elaborate it later. */
4055 if (!definition
&& defer_incomplete_level
!= 0)
4057 struct incomplete
*p
= XNEW (struct incomplete
);
4060 = make_dummy_type (Directly_Designated_Type (gnat_entity
));
4061 p
->full_type
= Directly_Designated_Type (gnat_entity
);
4062 p
->next
= defer_incomplete_list
;
4063 defer_incomplete_list
= p
;
4065 else if (!IN (Ekind (Base_Type
4066 (Directly_Designated_Type (gnat_entity
))),
4067 Incomplete_Or_Private_Kind
))
4068 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
4072 maybe_present
= true;
4075 /* Subprogram Entities
4077 The following access functions are defined for subprograms:
4079 Etype Return type or Standard_Void_Type.
4080 First_Formal The first formal parameter.
4081 Is_Imported Indicates that the subprogram has appeared in
4082 an INTERFACE or IMPORT pragma. For now we
4083 assume that the external language is C.
4084 Is_Exported Likewise but for an EXPORT pragma.
4085 Is_Inlined True if the subprogram is to be inlined.
4087 Each parameter is first checked by calling must_pass_by_ref on its
4088 type to determine if it is passed by reference. For parameters which
4089 are copied in, if they are Ada In Out or Out parameters, their return
4090 value becomes part of a record which becomes the return type of the
4091 function (C function - note that this applies only to Ada procedures
4092 so there is no Ada return type). Additional code to store back the
4093 parameters will be generated on the caller side. This transformation
4094 is done here, not in the front-end.
4096 The intended result of the transformation can be seen from the
4097 equivalent source rewritings that follow:
4099 struct temp {int a,b};
4100 procedure P (A,B: In Out ...) is temp P (int A,B)
4103 end P; return {A,B};
4110 For subprogram types we need to perform mainly the same conversions to
4111 GCC form that are needed for procedures and function declarations. The
4112 only difference is that at the end, we make a type declaration instead
4113 of a function declaration. */
4115 case E_Subprogram_Type
:
4119 /* The type returned by a function or else Standard_Void_Type for a
4121 Entity_Id gnat_return_type
= Etype (gnat_entity
);
4122 tree gnu_return_type
;
4123 /* The first GCC parameter declaration (a PARM_DECL node). The
4124 PARM_DECL nodes are chained through the DECL_CHAIN field, so this
4125 actually is the head of this parameter list. */
4126 tree gnu_param_list
= NULL_TREE
;
4127 /* Likewise for the stub associated with an exported procedure. */
4128 tree gnu_stub_param_list
= NULL_TREE
;
4129 /* Non-null for subprograms containing parameters passed by copy-in
4130 copy-out (Ada In Out or Out parameters not passed by reference),
4131 in which case it is the list of nodes used to specify the values
4132 of the In Out/Out parameters that are returned as a record upon
4133 procedure return. The TREE_PURPOSE of an element of this list is
4134 a field of the record and the TREE_VALUE is the PARM_DECL
4135 corresponding to that field. This list will be saved in the
4136 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
4137 tree gnu_cico_list
= NULL_TREE
;
4138 /* List of fields in return type of procedure with copy-in copy-out
4140 tree gnu_field_list
= NULL_TREE
;
4141 /* If an import pragma asks to map this subprogram to a GCC builtin,
4142 this is the builtin DECL node. */
4143 tree gnu_builtin_decl
= NULL_TREE
;
4144 /* For the stub associated with an exported procedure. */
4145 tree gnu_stub_type
= NULL_TREE
, gnu_stub_name
= NULL_TREE
;
4146 tree gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
4147 Entity_Id gnat_param
;
4148 enum inline_status_t inline_status
4149 = Has_Pragma_No_Inline (gnat_entity
)
4151 : (Is_Inlined (gnat_entity
) ? is_enabled
: is_disabled
);
4152 bool public_flag
= Is_Public (gnat_entity
) || imported_p
;
4154 = (Is_Public (gnat_entity
) && !definition
) || imported_p
;
4155 bool artificial_flag
= !Comes_From_Source (gnat_entity
);
4156 /* The semantics of "pure" in Ada essentially matches that of "const"
4157 in the back-end. In particular, both properties are orthogonal to
4158 the "nothrow" property if the EH circuitry is explicit in the
4159 internal representation of the back-end. If we are to completely
4160 hide the EH circuitry from it, we need to declare that calls to pure
4161 Ada subprograms that can throw have side effects since they can
4162 trigger an "abnormal" transfer of control flow; thus they can be
4163 neither "const" nor "pure" in the back-end sense. */
4165 = (Exception_Mechanism
== Back_End_Exceptions
4166 && Is_Pure (gnat_entity
));
4167 bool volatile_flag
= No_Return (gnat_entity
);
4168 bool return_by_direct_ref_p
= false;
4169 bool return_by_invisi_ref_p
= false;
4170 bool return_unconstrained_p
= false;
4171 bool has_stub
= false;
4174 /* A parameter may refer to this type, so defer completion of any
4175 incomplete types. */
4176 if (kind
== E_Subprogram_Type
&& !definition
)
4178 defer_incomplete_level
++;
4179 this_deferred
= true;
4182 /* If the subprogram has an alias, it is probably inherited, so
4183 we can use the original one. If the original "subprogram"
4184 is actually an enumeration literal, it may be the first use
4185 of its type, so we must elaborate that type now. */
4186 if (Present (Alias (gnat_entity
)))
4188 if (Ekind (Alias (gnat_entity
)) == E_Enumeration_Literal
)
4189 gnat_to_gnu_entity (Etype (Alias (gnat_entity
)), NULL_TREE
, 0);
4191 gnu_decl
= gnat_to_gnu_entity (Alias (gnat_entity
), gnu_expr
, 0);
4193 /* Elaborate any Itypes in the parameters of this entity. */
4194 for (gnat_temp
= First_Formal_With_Extras (gnat_entity
);
4195 Present (gnat_temp
);
4196 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
4197 if (Is_Itype (Etype (gnat_temp
)))
4198 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
4203 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
4204 corresponding DECL node. Proper generation of calls later on need
4205 proper parameter associations so we don't "break;" here. */
4206 if (Convention (gnat_entity
) == Convention_Intrinsic
4207 && Present (Interface_Name (gnat_entity
)))
4209 gnu_builtin_decl
= builtin_decl_for (gnu_ext_name
);
4211 /* Inability to find the builtin decl most often indicates a
4212 genuine mistake, but imports of unregistered intrinsics are
4213 sometimes issued on purpose to allow hooking in alternate
4214 bodies. We post a warning conditioned on Wshadow in this case,
4215 to let developers be notified on demand without risking false
4216 positives with common default sets of options. */
4218 if (gnu_builtin_decl
== NULL_TREE
&& warn_shadow
)
4219 post_error ("?gcc intrinsic not found for&!", gnat_entity
);
4222 /* ??? What if we don't find the builtin node above ? warn ? err ?
4223 In the current state we neither warn nor err, and calls will just
4224 be handled as for regular subprograms. */
4226 /* Look into the return type and get its associated GCC tree. If it
4227 is not void, compute various flags for the subprogram type. */
4228 if (Ekind (gnat_return_type
) == E_Void
)
4229 gnu_return_type
= void_type_node
;
4232 /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
4233 context may now appear in parameter and result profiles. If
4234 we are only annotating types, break circularities here. */
4235 if (type_annotate_only
4236 && IN (Ekind (gnat_return_type
), Incomplete_Kind
)
4237 && From_Limited_With (gnat_return_type
)
4238 && In_Extended_Main_Code_Unit
4239 (Non_Limited_View (gnat_return_type
))
4240 && !present_gnu_tree (Non_Limited_View (gnat_return_type
)))
4241 gnu_return_type
= ptr_void_type_node
;
4243 gnu_return_type
= gnat_to_gnu_type (gnat_return_type
);
4245 /* If this function returns by reference, make the actual return
4246 type the pointer type and make a note of that. */
4247 if (Returns_By_Ref (gnat_entity
))
4249 gnu_return_type
= build_pointer_type (gnu_return_type
);
4250 return_by_direct_ref_p
= true;
4253 /* If we are supposed to return an unconstrained array type, make
4254 the actual return type the fat pointer type. */
4255 else if (TREE_CODE (gnu_return_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4257 gnu_return_type
= TREE_TYPE (gnu_return_type
);
4258 return_unconstrained_p
= true;
4261 /* Likewise, if the return type requires a transient scope, the
4262 return value will be allocated on the secondary stack so the
4263 actual return type is the pointer type. */
4264 else if (Requires_Transient_Scope (gnat_return_type
))
4266 gnu_return_type
= build_pointer_type (gnu_return_type
);
4267 return_unconstrained_p
= true;
4270 /* If the Mechanism is By_Reference, ensure this function uses the
4271 target's by-invisible-reference mechanism, which may not be the
4272 same as above (e.g. it might be passing an extra parameter). */
4273 else if (kind
== E_Function
4274 && Mechanism (gnat_entity
) == By_Reference
)
4275 return_by_invisi_ref_p
= true;
4277 /* Likewise, if the return type is itself By_Reference. */
4278 else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type
))
4279 return_by_invisi_ref_p
= true;
4281 /* If the type is a padded type and the underlying type would not
4282 be passed by reference or the function has a foreign convention,
4283 return the underlying type. */
4284 else if (TYPE_IS_PADDING_P (gnu_return_type
)
4285 && (!default_pass_by_ref
4286 (TREE_TYPE (TYPE_FIELDS (gnu_return_type
)))
4287 || Has_Foreign_Convention (gnat_entity
)))
4288 gnu_return_type
= TREE_TYPE (TYPE_FIELDS (gnu_return_type
));
4290 /* If the return type is unconstrained, that means it must have a
4291 maximum size. Use the padded type as the effective return type.
4292 And ensure the function uses the target's by-invisible-reference
4293 mechanism to avoid copying too much data when it returns. */
4294 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type
)))
4296 tree orig_type
= gnu_return_type
;
4299 = maybe_pad_type (gnu_return_type
,
4300 max_size (TYPE_SIZE (gnu_return_type
),
4302 0, gnat_entity
, false, false, false, true);
4304 /* Declare it now since it will never be declared otherwise.
4305 This is necessary to ensure that its subtrees are properly
4307 if (gnu_return_type
!= orig_type
4308 && !DECL_P (TYPE_NAME (gnu_return_type
)))
4309 create_type_decl (TYPE_NAME (gnu_return_type
),
4310 gnu_return_type
, true, debug_info_p
,
4313 return_by_invisi_ref_p
= true;
4316 /* If the return type has a size that overflows, we cannot have
4317 a function that returns that type. This usage doesn't make
4318 sense anyway, so give an error here. */
4319 if (TYPE_SIZE_UNIT (gnu_return_type
)
4320 && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type
)) == INTEGER_CST
4321 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type
)))
4323 post_error ("cannot return type whose size overflows",
4325 gnu_return_type
= copy_node (gnu_return_type
);
4326 TYPE_SIZE (gnu_return_type
) = bitsize_zero_node
;
4327 TYPE_SIZE_UNIT (gnu_return_type
) = size_zero_node
;
4328 TYPE_MAIN_VARIANT (gnu_return_type
) = gnu_return_type
;
4329 TYPE_NEXT_VARIANT (gnu_return_type
) = NULL_TREE
;
4333 /* Loop over the parameters and get their associated GCC tree. While
4334 doing this, build a copy-in copy-out structure if we need one. */
4335 for (gnat_param
= First_Formal_With_Extras (gnat_entity
), parmnum
= 0;
4336 Present (gnat_param
);
4337 gnat_param
= Next_Formal_With_Extras (gnat_param
), parmnum
++)
4339 Entity_Id gnat_param_type
= Etype (gnat_param
);
4340 tree gnu_param_name
= get_entity_name (gnat_param
);
4341 tree gnu_param_type
, gnu_param
, gnu_field
;
4342 Mechanism_Type mech
= Mechanism (gnat_param
);
4343 bool copy_in_copy_out
= false, fake_param_type
;
4345 /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
4346 context may now appear in parameter and result profiles. If
4347 we are only annotating types, break circularities here. */
4348 if (type_annotate_only
4349 && IN (Ekind (gnat_param_type
), Incomplete_Kind
)
4350 && From_Limited_With (Etype (gnat_param_type
))
4351 && In_Extended_Main_Code_Unit
4352 (Non_Limited_View (gnat_param_type
))
4353 && !present_gnu_tree (Non_Limited_View (gnat_param_type
)))
4355 gnu_param_type
= ptr_void_type_node
;
4356 fake_param_type
= true;
4360 gnu_param_type
= gnat_to_gnu_type (gnat_param_type
);
4361 fake_param_type
= false;
4364 /* Builtins are expanded inline and there is no real call sequence
4365 involved. So the type expected by the underlying expander is
4366 always the type of each argument "as is". */
4367 if (gnu_builtin_decl
)
4369 /* Handle the first parameter of a valued procedure specially. */
4370 else if (Is_Valued_Procedure (gnat_entity
) && parmnum
== 0)
4371 mech
= By_Copy_Return
;
4372 /* Otherwise, see if a Mechanism was supplied that forced this
4373 parameter to be passed one way or another. */
4374 else if (mech
== Default
4375 || mech
== By_Copy
|| mech
== By_Reference
)
4377 else if (By_Descriptor_Last
<= mech
&& mech
<= By_Descriptor
)
4378 mech
= By_Descriptor
;
4380 else if (By_Short_Descriptor_Last
<= mech
&&
4381 mech
<= By_Short_Descriptor
)
4382 mech
= By_Short_Descriptor
;
4386 if (TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
4387 || TREE_CODE (TYPE_SIZE (gnu_param_type
)) != INTEGER_CST
4388 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type
),
4390 mech
= By_Reference
;
4396 post_error ("unsupported mechanism for&", gnat_param
);
4400 /* Do not call gnat_to_gnu_param for a fake parameter type since
4401 it will try to use the real type again. */
4402 if (fake_param_type
)
4404 if (Ekind (gnat_param
) == E_Out_Parameter
)
4405 gnu_param
= NULL_TREE
;
4409 = create_param_decl (gnu_param_name
, gnu_param_type
,
4411 Set_Mechanism (gnat_param
,
4412 mech
== Default
? By_Copy
: mech
);
4413 if (Ekind (gnat_param
) == E_In_Out_Parameter
)
4414 copy_in_copy_out
= true;
4419 = gnat_to_gnu_param (gnat_param
, mech
, gnat_entity
,
4420 Has_Foreign_Convention (gnat_entity
),
4423 /* We are returned either a PARM_DECL or a type if no parameter
4424 needs to be passed; in either case, adjust the type. */
4425 if (DECL_P (gnu_param
))
4426 gnu_param_type
= TREE_TYPE (gnu_param
);
4429 gnu_param_type
= gnu_param
;
4430 gnu_param
= NULL_TREE
;
4433 /* The failure of this assertion will very likely come from an
4434 order of elaboration issue for the type of the parameter. */
4435 gcc_assert (kind
== E_Subprogram_Type
4436 || !TYPE_IS_DUMMY_P (gnu_param_type
)
4437 || type_annotate_only
);
4441 /* If it's an exported subprogram, we build a parameter list
4442 in parallel, in case we need to emit a stub for it. */
4443 if (Is_Exported (gnat_entity
))
4446 = chainon (gnu_param
, gnu_stub_param_list
);
4447 /* Change By_Descriptor parameter to By_Reference for
4448 the internal version of an exported subprogram. */
4449 if (mech
== By_Descriptor
|| mech
== By_Short_Descriptor
)
4452 = gnat_to_gnu_param (gnat_param
, By_Reference
,
4458 gnu_param
= copy_node (gnu_param
);
4461 gnu_param_list
= chainon (gnu_param
, gnu_param_list
);
4462 Sloc_to_locus (Sloc (gnat_param
),
4463 &DECL_SOURCE_LOCATION (gnu_param
));
4464 save_gnu_tree (gnat_param
, gnu_param
, false);
4466 /* If a parameter is a pointer, this function may modify
4467 memory through it and thus shouldn't be considered
4468 a const function. Also, the memory may be modified
4469 between two calls, so they can't be CSE'ed. The latter
4470 case also handles by-ref parameters. */
4471 if (POINTER_TYPE_P (gnu_param_type
)
4472 || TYPE_IS_FAT_POINTER_P (gnu_param_type
))
4476 if (copy_in_copy_out
)
4480 tree gnu_new_ret_type
= make_node (RECORD_TYPE
);
4482 /* If this is a function, we also need a field for the
4483 return value to be placed. */
4484 if (TREE_CODE (gnu_return_type
) != VOID_TYPE
)
4487 = create_field_decl (get_identifier ("RETVAL"),
4489 gnu_new_ret_type
, NULL_TREE
,
4491 Sloc_to_locus (Sloc (gnat_entity
),
4492 &DECL_SOURCE_LOCATION (gnu_field
));
4493 gnu_field_list
= gnu_field
;
4495 = tree_cons (gnu_field
, void_type_node
, NULL_TREE
);
4498 gnu_return_type
= gnu_new_ret_type
;
4499 TYPE_NAME (gnu_return_type
) = get_identifier ("RETURN");
4500 /* Set a default alignment to speed up accesses. But we
4501 shouldn't increase the size of the structure too much,
4502 lest it doesn't fit in return registers anymore. */
4503 TYPE_ALIGN (gnu_return_type
)
4504 = get_mode_alignment (ptr_mode
);
4508 = create_field_decl (gnu_param_name
, gnu_param_type
,
4509 gnu_return_type
, NULL_TREE
, NULL_TREE
,
4511 Sloc_to_locus (Sloc (gnat_param
),
4512 &DECL_SOURCE_LOCATION (gnu_field
));
4513 DECL_CHAIN (gnu_field
) = gnu_field_list
;
4514 gnu_field_list
= gnu_field
;
4516 = tree_cons (gnu_field
, gnu_param
, gnu_cico_list
);
4522 /* If we have a CICO list but it has only one entry, we convert
4523 this function into a function that returns this object. */
4524 if (list_length (gnu_cico_list
) == 1)
4525 gnu_return_type
= TREE_TYPE (TREE_PURPOSE (gnu_cico_list
));
4527 /* Do not finalize the return type if the subprogram is stubbed
4528 since structures are incomplete for the back-end. */
4529 else if (Convention (gnat_entity
) != Convention_Stubbed
)
4531 finish_record_type (gnu_return_type
, nreverse (gnu_field_list
),
4534 /* Try to promote the mode of the return type if it is passed
4535 in registers, again to speed up accesses. */
4536 if (TYPE_MODE (gnu_return_type
) == BLKmode
4537 && !targetm
.calls
.return_in_memory (gnu_return_type
,
4541 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type
));
4542 unsigned int i
= BITS_PER_UNIT
;
4543 enum machine_mode mode
;
4547 mode
= mode_for_size (i
, MODE_INT
, 0);
4548 if (mode
!= BLKmode
)
4550 SET_TYPE_MODE (gnu_return_type
, mode
);
4551 TYPE_ALIGN (gnu_return_type
)
4552 = GET_MODE_ALIGNMENT (mode
);
4553 TYPE_SIZE (gnu_return_type
)
4554 = bitsize_int (GET_MODE_BITSIZE (mode
));
4555 TYPE_SIZE_UNIT (gnu_return_type
)
4556 = size_int (GET_MODE_SIZE (mode
));
4561 rest_of_record_type_compilation (gnu_return_type
);
4565 if (Has_Stdcall_Convention (gnat_entity
))
4566 prepend_one_attribute_to
4567 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4568 get_identifier ("stdcall"), NULL_TREE
,
4570 else if (Has_Thiscall_Convention (gnat_entity
))
4571 prepend_one_attribute_to
4572 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4573 get_identifier ("thiscall"), NULL_TREE
,
4576 /* If we should request stack realignment for a foreign convention
4577 subprogram, do so. Note that this applies to task entry points in
4579 if (FOREIGN_FORCE_REALIGN_STACK
4580 && Has_Foreign_Convention (gnat_entity
))
4581 prepend_one_attribute_to
4582 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4583 get_identifier ("force_align_arg_pointer"), NULL_TREE
,
4586 /* The lists have been built in reverse. */
4587 gnu_param_list
= nreverse (gnu_param_list
);
4589 gnu_stub_param_list
= nreverse (gnu_stub_param_list
);
4590 gnu_cico_list
= nreverse (gnu_cico_list
);
4592 if (kind
== E_Function
)
4593 Set_Mechanism (gnat_entity
, return_unconstrained_p
4594 || return_by_direct_ref_p
4595 || return_by_invisi_ref_p
4596 ? By_Reference
: By_Copy
);
4598 = create_subprog_type (gnu_return_type
, gnu_param_list
,
4599 gnu_cico_list
, return_unconstrained_p
,
4600 return_by_direct_ref_p
,
4601 return_by_invisi_ref_p
);
4605 = create_subprog_type (gnu_return_type
, gnu_stub_param_list
,
4606 gnu_cico_list
, return_unconstrained_p
,
4607 return_by_direct_ref_p
,
4608 return_by_invisi_ref_p
);
4610 /* A subprogram (something that doesn't return anything) shouldn't
4611 be considered const since there would be no reason for such a
4612 subprogram. Note that procedures with Out (or In Out) parameters
4613 have already been converted into a function with a return type. */
4614 if (TREE_CODE (gnu_return_type
) == VOID_TYPE
)
4618 = build_qualified_type (gnu_type
,
4619 TYPE_QUALS (gnu_type
)
4620 | (TYPE_QUAL_CONST
* const_flag
)
4621 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
4625 = build_qualified_type (gnu_stub_type
,
4626 TYPE_QUALS (gnu_stub_type
)
4627 | (TYPE_QUAL_CONST
* const_flag
)
4628 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
4630 /* If we have a builtin decl for that function, use it. Check if the
4631 profiles are compatible and warn if they are not. The checker is
4632 expected to post extra diagnostics in this case. */
4633 if (gnu_builtin_decl
)
4635 intrin_binding_t inb
;
4637 inb
.gnat_entity
= gnat_entity
;
4638 inb
.ada_fntype
= gnu_type
;
4639 inb
.btin_fntype
= TREE_TYPE (gnu_builtin_decl
);
4641 if (!intrin_profiles_compatible_p (&inb
))
4643 ("?profile of& doesn''t match the builtin it binds!",
4646 gnu_decl
= gnu_builtin_decl
;
4647 gnu_type
= TREE_TYPE (gnu_builtin_decl
);
4651 /* If there was no specified Interface_Name and the external and
4652 internal names of the subprogram are the same, only use the
4653 internal name to allow disambiguation of nested subprograms. */
4654 if (No (Interface_Name (gnat_entity
))
4655 && gnu_ext_name
== gnu_entity_name
)
4656 gnu_ext_name
= NULL_TREE
;
4658 /* If we are defining the subprogram and it has an Address clause
4659 we must get the address expression from the saved GCC tree for the
4660 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4661 the address expression here since the front-end has guaranteed
4662 in that case that the elaboration has no effects. If there is
4663 an Address clause and we are not defining the object, just
4664 make it a constant. */
4665 if (Present (Address_Clause (gnat_entity
)))
4667 tree gnu_address
= NULL_TREE
;
4671 = (present_gnu_tree (gnat_entity
)
4672 ? get_gnu_tree (gnat_entity
)
4673 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
4675 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
4677 /* Convert the type of the object to a reference type that can
4678 alias everything as per 13.3(19). */
4680 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
4682 gnu_address
= convert (gnu_type
, gnu_address
);
4685 = create_var_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
4686 gnu_address
, false, Is_Public (gnat_entity
),
4687 extern_flag
, false, NULL
, gnat_entity
);
4688 DECL_BY_REF_P (gnu_decl
) = 1;
4691 else if (kind
== E_Subprogram_Type
)
4693 process_attributes (&gnu_type
, &attr_list
, false, gnat_entity
);
4695 = create_type_decl (gnu_entity_name
, gnu_type
, artificial_flag
,
4696 debug_info_p
, gnat_entity
);
4702 gnu_stub_name
= gnu_ext_name
;
4703 gnu_ext_name
= create_concat_name (gnat_entity
, "internal");
4704 public_flag
= false;
4705 artificial_flag
= true;
4709 = create_subprog_decl (gnu_entity_name
, gnu_ext_name
, gnu_type
,
4710 gnu_param_list
, inline_status
,
4711 public_flag
, extern_flag
, artificial_flag
,
4712 attr_list
, gnat_entity
);
4716 = create_subprog_decl (gnu_entity_name
, gnu_stub_name
,
4717 gnu_stub_type
, gnu_stub_param_list
,
4718 inline_status
, true, extern_flag
,
4719 false, attr_list
, gnat_entity
);
4720 SET_DECL_FUNCTION_STUB (gnu_decl
, gnu_stub_decl
);
4723 /* This is unrelated to the stub built right above. */
4724 DECL_STUBBED_P (gnu_decl
)
4725 = Convention (gnat_entity
) == Convention_Stubbed
;
4730 case E_Incomplete_Type
:
4731 case E_Incomplete_Subtype
:
4732 case E_Private_Type
:
4733 case E_Private_Subtype
:
4734 case E_Limited_Private_Type
:
4735 case E_Limited_Private_Subtype
:
4736 case E_Record_Type_With_Private
:
4737 case E_Record_Subtype_With_Private
:
4739 /* Get the "full view" of this entity. If this is an incomplete
4740 entity from a limited with, treat its non-limited view as the
4741 full view. Otherwise, use either the full view or the underlying
4742 full view, whichever is present. This is used in all the tests
4745 = (IN (kind
, Incomplete_Kind
) && From_Limited_With (gnat_entity
))
4746 ? Non_Limited_View (gnat_entity
)
4747 : Present (Full_View (gnat_entity
))
4748 ? Full_View (gnat_entity
)
4749 : Underlying_Full_View (gnat_entity
);
4751 /* If this is an incomplete type with no full view, it must be a Taft
4752 Amendment type, in which case we return a dummy type. Otherwise,
4753 just get the type from its Etype. */
4756 if (kind
== E_Incomplete_Type
)
4758 gnu_type
= make_dummy_type (gnat_entity
);
4759 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4763 gnu_decl
= gnat_to_gnu_entity (Etype (gnat_entity
),
4765 maybe_present
= true;
4770 /* If we already made a type for the full view, reuse it. */
4771 else if (present_gnu_tree (full_view
))
4773 gnu_decl
= get_gnu_tree (full_view
);
4777 /* Otherwise, if we are not defining the type now, get the type
4778 from the full view. But always get the type from the full view
4779 for define on use types, since otherwise we won't see them! */
4780 else if (!definition
4781 || (Is_Itype (full_view
)
4782 && No (Freeze_Node (gnat_entity
)))
4783 || (Is_Itype (gnat_entity
)
4784 && No (Freeze_Node (full_view
))))
4786 gnu_decl
= gnat_to_gnu_entity (full_view
, NULL_TREE
, 0);
4787 maybe_present
= true;
4791 /* For incomplete types, make a dummy type entry which will be
4792 replaced later. Save it as the full declaration's type so
4793 we can do any needed updates when we see it. */
4794 gnu_type
= make_dummy_type (gnat_entity
);
4795 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4796 if (Has_Completion_In_Body (gnat_entity
))
4797 DECL_TAFT_TYPE_P (gnu_decl
) = 1;
4798 save_gnu_tree (full_view
, gnu_decl
, 0);
4802 case E_Class_Wide_Type
:
4803 /* Class-wide types are always transformed into their root type. */
4804 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
4805 maybe_present
= true;
4809 case E_Task_Subtype
:
4810 case E_Protected_Type
:
4811 case E_Protected_Subtype
:
4812 /* Concurrent types are always transformed into their record type. */
4813 if (type_annotate_only
&& No (gnat_equiv_type
))
4814 gnu_type
= void_type_node
;
4816 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
4817 maybe_present
= true;
4821 gnu_decl
= create_label_decl (gnu_entity_name
, gnat_entity
);
4826 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4827 we've already saved it, so we don't try to. */
4828 gnu_decl
= error_mark_node
;
4832 case E_Abstract_State
:
4833 /* This is a SPARK annotation that only reaches here when compiling in
4834 ASIS mode and has no characteristics to annotate. */
4835 gcc_assert (type_annotate_only
);
4836 return error_mark_node
;
4842 /* If we had a case where we evaluated another type and it might have
4843 defined this one, handle it here. */
4844 if (maybe_present
&& present_gnu_tree (gnat_entity
))
4846 gnu_decl
= get_gnu_tree (gnat_entity
);
4850 /* If we are processing a type and there is either no decl for it or
4851 we just made one, do some common processing for the type, such as
4852 handling alignment and possible padding. */
4853 if (is_type
&& (!gnu_decl
|| this_made_decl
))
4855 /* Process the attributes, if not already done. Note that the type is
4856 already defined so we cannot pass true for IN_PLACE here. */
4857 process_attributes (&gnu_type
, &attr_list
, false, gnat_entity
);
4859 /* Tell the middle-end that objects of tagged types are guaranteed to
4860 be properly aligned. This is necessary because conversions to the
4861 class-wide type are translated into conversions to the root type,
4862 which can be less aligned than some of its derived types. */
4863 if (Is_Tagged_Type (gnat_entity
)
4864 || Is_Class_Wide_Equivalent_Type (gnat_entity
))
4865 TYPE_ALIGN_OK (gnu_type
) = 1;
4867 /* Record whether the type is passed by reference. */
4868 if (!VOID_TYPE_P (gnu_type
) && Is_By_Reference_Type (gnat_entity
))
4869 TYPE_BY_REFERENCE_P (gnu_type
) = 1;
4871 /* ??? Don't set the size for a String_Literal since it is either
4872 confirming or we don't handle it properly (if the low bound is
4874 if (!gnu_size
&& kind
!= E_String_Literal_Subtype
)
4876 Uint gnat_size
= Known_Esize (gnat_entity
)
4877 ? Esize (gnat_entity
) : RM_Size (gnat_entity
);
4879 = validate_size (gnat_size
, gnu_type
, gnat_entity
, TYPE_DECL
,
4880 false, Has_Size_Clause (gnat_entity
));
4883 /* If a size was specified, see if we can make a new type of that size
4884 by rearranging the type, for example from a fat to a thin pointer. */
4888 = make_type_from_size (gnu_type
, gnu_size
,
4889 Has_Biased_Representation (gnat_entity
));
4891 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0)
4892 && operand_equal_p (rm_size (gnu_type
), gnu_size
, 0))
4893 gnu_size
= NULL_TREE
;
4896 /* If the alignment hasn't already been processed and this is
4897 not an unconstrained array, see if an alignment is specified.
4898 If not, we pick a default alignment for atomic objects. */
4899 if (align
!= 0 || TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4901 else if (Known_Alignment (gnat_entity
))
4903 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
4904 TYPE_ALIGN (gnu_type
));
4906 /* Warn on suspiciously large alignments. This should catch
4907 errors about the (alignment,byte)/(size,bit) discrepancy. */
4908 if (align
> BIGGEST_ALIGNMENT
&& Has_Alignment_Clause (gnat_entity
))
4912 /* If a size was specified, take it into account. Otherwise
4913 use the RM size for records or unions as the type size has
4914 already been adjusted to the alignment. */
4917 else if (RECORD_OR_UNION_TYPE_P (gnu_type
)
4918 && !TYPE_FAT_POINTER_P (gnu_type
))
4919 size
= rm_size (gnu_type
);
4921 size
= TYPE_SIZE (gnu_type
);
4923 /* Consider an alignment as suspicious if the alignment/size
4924 ratio is greater or equal to the byte/bit ratio. */
4925 if (tree_fits_uhwi_p (size
)
4926 && align
>= tree_to_uhwi (size
) * BITS_PER_UNIT
)
4927 post_error_ne ("?suspiciously large alignment specified for&",
4928 Expression (Alignment_Clause (gnat_entity
)),
4932 else if (Is_Atomic (gnat_entity
) && !gnu_size
4933 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type
))
4934 && integer_pow2p (TYPE_SIZE (gnu_type
)))
4935 align
= MIN (BIGGEST_ALIGNMENT
,
4936 tree_to_uhwi (TYPE_SIZE (gnu_type
)));
4937 else if (Is_Atomic (gnat_entity
) && gnu_size
4938 && tree_fits_uhwi_p (gnu_size
)
4939 && integer_pow2p (gnu_size
))
4940 align
= MIN (BIGGEST_ALIGNMENT
, tree_to_uhwi (gnu_size
));
4942 /* See if we need to pad the type. If we did, and made a record,
4943 the name of the new type may be changed. So get it back for
4944 us when we make the new TYPE_DECL below. */
4945 if (gnu_size
|| align
> 0)
4946 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
4947 false, !gnu_decl
, definition
, false);
4949 if (TYPE_IS_PADDING_P (gnu_type
))
4951 gnu_entity_name
= TYPE_NAME (gnu_type
);
4952 if (TREE_CODE (gnu_entity_name
) == TYPE_DECL
)
4953 gnu_entity_name
= DECL_NAME (gnu_entity_name
);
4956 /* Now set the RM size of the type. We cannot do it before padding
4957 because we need to accept arbitrary RM sizes on integral types. */
4958 set_rm_size (RM_Size (gnat_entity
), gnu_type
, gnat_entity
);
4960 /* If we are at global level, GCC will have applied variable_size to
4961 the type, but that won't have done anything. So, if it's not
4962 a constant or self-referential, call elaborate_expression_1 to
4963 make a variable for the size rather than calculating it each time.
4964 Handle both the RM size and the actual size. */
4965 if (global_bindings_p ()
4966 && TYPE_SIZE (gnu_type
)
4967 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
))
4968 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
4970 tree size
= TYPE_SIZE (gnu_type
);
4972 TYPE_SIZE (gnu_type
)
4973 = elaborate_expression_1 (size
, gnat_entity
,
4974 get_identifier ("SIZE"),
4977 /* ??? For now, store the size as a multiple of the alignment in
4978 bytes so that we can see the alignment from the tree. */
4979 TYPE_SIZE_UNIT (gnu_type
)
4980 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type
), gnat_entity
,
4981 get_identifier ("SIZE_A_UNIT"),
4983 TYPE_ALIGN (gnu_type
));
4985 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4986 may not be marked by the call to create_type_decl below. */
4987 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type
));
4989 if (TREE_CODE (gnu_type
) == RECORD_TYPE
)
4991 tree variant_part
= get_variant_part (gnu_type
);
4992 tree ada_size
= TYPE_ADA_SIZE (gnu_type
);
4996 tree union_type
= TREE_TYPE (variant_part
);
4997 tree offset
= DECL_FIELD_OFFSET (variant_part
);
4999 /* If the position of the variant part is constant, subtract
5000 it from the size of the type of the parent to get the new
5001 size. This manual CSE reduces the data size. */
5002 if (TREE_CODE (offset
) == INTEGER_CST
)
5004 tree bitpos
= DECL_FIELD_BIT_OFFSET (variant_part
);
5005 TYPE_SIZE (union_type
)
5006 = size_binop (MINUS_EXPR
, TYPE_SIZE (gnu_type
),
5007 bit_from_pos (offset
, bitpos
));
5008 TYPE_SIZE_UNIT (union_type
)
5009 = size_binop (MINUS_EXPR
, TYPE_SIZE_UNIT (gnu_type
),
5010 byte_from_pos (offset
, bitpos
));
5014 TYPE_SIZE (union_type
)
5015 = elaborate_expression_1 (TYPE_SIZE (union_type
),
5017 get_identifier ("VSIZE"),
5020 /* ??? For now, store the size as a multiple of the
5021 alignment in bytes so that we can see the alignment
5023 TYPE_SIZE_UNIT (union_type
)
5024 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type
),
5029 TYPE_ALIGN (union_type
));
5031 /* ??? For now, store the offset as a multiple of the
5032 alignment in bytes so that we can see the alignment
5034 DECL_FIELD_OFFSET (variant_part
)
5035 = elaborate_expression_2 (offset
,
5037 get_identifier ("VOFFSET"),
5043 DECL_SIZE (variant_part
) = TYPE_SIZE (union_type
);
5044 DECL_SIZE_UNIT (variant_part
) = TYPE_SIZE_UNIT (union_type
);
5047 if (operand_equal_p (ada_size
, size
, 0))
5048 ada_size
= TYPE_SIZE (gnu_type
);
5051 = elaborate_expression_1 (ada_size
, gnat_entity
,
5052 get_identifier ("RM_SIZE"),
5054 SET_TYPE_ADA_SIZE (gnu_type
, ada_size
);
5058 /* If this is a record type or subtype, call elaborate_expression_2 on
5059 any field position. Do this for both global and local types.
5060 Skip any fields that we haven't made trees for to avoid problems with
5061 class wide types. */
5062 if (IN (kind
, Record_Kind
))
5063 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
5064 gnat_temp
= Next_Entity (gnat_temp
))
5065 if (Ekind (gnat_temp
) == E_Component
&& present_gnu_tree (gnat_temp
))
5067 tree gnu_field
= get_gnu_tree (gnat_temp
);
5069 /* ??? For now, store the offset as a multiple of the alignment
5070 in bytes so that we can see the alignment from the tree. */
5071 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field
)))
5073 DECL_FIELD_OFFSET (gnu_field
)
5074 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field
),
5076 get_identifier ("OFFSET"),
5078 DECL_OFFSET_ALIGN (gnu_field
));
5080 /* ??? The context of gnu_field is not necessarily gnu_type
5081 so the MULT_EXPR node built above may not be marked by
5082 the call to create_type_decl below. */
5083 if (global_bindings_p ())
5084 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field
));
5088 if (Treat_As_Volatile (gnat_entity
))
5090 = build_qualified_type (gnu_type
,
5091 TYPE_QUALS (gnu_type
) | TYPE_QUAL_VOLATILE
);
5093 if (Is_Atomic (gnat_entity
))
5094 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
5096 if (Present (Alignment_Clause (gnat_entity
)))
5097 TYPE_USER_ALIGN (gnu_type
) = 1;
5099 if (Universal_Aliasing (gnat_entity
))
5100 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type
)) = 1;
5103 gnu_decl
= create_type_decl (gnu_entity_name
, gnu_type
,
5104 !Comes_From_Source (gnat_entity
),
5105 debug_info_p
, gnat_entity
);
5108 TREE_TYPE (gnu_decl
) = gnu_type
;
5109 TYPE_STUB_DECL (gnu_type
) = gnu_decl
;
5113 if (is_type
&& !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
)))
5115 gnu_type
= TREE_TYPE (gnu_decl
);
5117 /* If this is a derived type, relate its alias set to that of its parent
5118 to avoid troubles when a call to an inherited primitive is inlined in
5119 a context where a derived object is accessed. The inlined code works
5120 on the parent view so the resulting code may access the same object
5121 using both the parent and the derived alias sets, which thus have to
5122 conflict. As the same issue arises with component references, the
5123 parent alias set also has to conflict with composite types enclosing
5124 derived components. For instance, if we have:
5131 we want T to conflict with both D and R, in addition to R being a
5132 superset of D by record/component construction.
5134 One way to achieve this is to perform an alias set copy from the
5135 parent to the derived type. This is not quite appropriate, though,
5136 as we don't want separate derived types to conflict with each other:
5138 type I1 is new Integer;
5139 type I2 is new Integer;
5141 We want I1 and I2 to both conflict with Integer but we do not want
5142 I1 to conflict with I2, and an alias set copy on derivation would
5145 The option chosen is to make the alias set of the derived type a
5146 superset of that of its parent type. It trivially fulfills the
5147 simple requirement for the Integer derivation example above, and
5148 the component case as well by superset transitivity:
5151 R ----------> D ----------> T
5153 However, for composite types, conversions between derived types are
5154 translated into VIEW_CONVERT_EXPRs so a sequence like:
5156 type Comp1 is new Comp;
5157 type Comp2 is new Comp;
5158 procedure Proc (C : Comp1);
5166 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
5168 and gimplified into:
5175 i.e. generates code involving type punning. Therefore, Comp1 needs
5176 to conflict with Comp2 and an alias set copy is required.
5178 The language rules ensure the parent type is already frozen here. */
5179 if (Is_Derived_Type (gnat_entity
) && !type_annotate_only
)
5181 tree gnu_parent_type
= gnat_to_gnu_type (Etype (gnat_entity
));
5182 relate_alias_sets (gnu_type
, gnu_parent_type
,
5183 Is_Composite_Type (gnat_entity
)
5184 ? ALIAS_SET_COPY
: ALIAS_SET_SUPERSET
);
5187 /* Back-annotate the Alignment of the type if not already in the
5188 tree. Likewise for sizes. */
5189 if (Unknown_Alignment (gnat_entity
))
5191 unsigned int double_align
, align
;
5192 bool is_capped_double
, align_clause
;
5194 /* If the default alignment of "double" or larger scalar types is
5195 specifically capped and this is not an array with an alignment
5196 clause on the component type, return the cap. */
5197 if ((double_align
= double_float_alignment
) > 0)
5199 = is_double_float_or_array (gnat_entity
, &align_clause
);
5200 else if ((double_align
= double_scalar_alignment
) > 0)
5202 = is_double_scalar_or_array (gnat_entity
, &align_clause
);
5204 is_capped_double
= align_clause
= false;
5206 if (is_capped_double
&& !align_clause
)
5207 align
= double_align
;
5209 align
= TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
;
5211 Set_Alignment (gnat_entity
, UI_From_Int (align
));
5214 if (Unknown_Esize (gnat_entity
) && TYPE_SIZE (gnu_type
))
5216 tree gnu_size
= TYPE_SIZE (gnu_type
);
5218 /* If the size is self-referential, annotate the maximum value. */
5219 if (CONTAINS_PLACEHOLDER_P (gnu_size
))
5220 gnu_size
= max_size (gnu_size
, true);
5222 /* If we are just annotating types and the type is tagged, the tag
5223 and the parent components are not generated by the front-end so
5224 sizes must be adjusted if there is no representation clause. */
5225 if (type_annotate_only
5226 && Is_Tagged_Type (gnat_entity
)
5227 && !VOID_TYPE_P (gnu_type
)
5228 && (!TYPE_FIELDS (gnu_type
)
5229 || integer_zerop (bit_position (TYPE_FIELDS (gnu_type
)))))
5231 tree pointer_size
= bitsize_int (POINTER_SIZE
), offset
;
5234 if (Is_Derived_Type (gnat_entity
))
5236 Entity_Id gnat_parent
= Etype (Base_Type (gnat_entity
));
5237 offset
= UI_To_gnu (Esize (gnat_parent
), bitsizetype
);
5238 Set_Alignment (gnat_entity
, Alignment (gnat_parent
));
5241 offset
= pointer_size
;
5243 if (TYPE_FIELDS (gnu_type
))
5245 = round_up (offset
, DECL_ALIGN (TYPE_FIELDS (gnu_type
)));
5247 gnu_size
= size_binop (PLUS_EXPR
, gnu_size
, offset
);
5248 gnu_size
= round_up (gnu_size
, POINTER_SIZE
);
5249 uint_size
= annotate_value (gnu_size
);
5250 Set_Esize (gnat_entity
, uint_size
);
5251 Set_RM_Size (gnat_entity
, uint_size
);
5254 Set_Esize (gnat_entity
, annotate_value (gnu_size
));
5257 if (Unknown_RM_Size (gnat_entity
) && rm_size (gnu_type
))
5258 Set_RM_Size (gnat_entity
, annotate_value (rm_size (gnu_type
)));
5261 /* If we really have a ..._DECL node, set a couple of flags on it. But we
5262 cannot do so if we are reusing the ..._DECL node made for an equivalent
5263 type or an alias or a renamed object as the predicates don't apply to it
5264 but to GNAT_ENTITY. */
5265 if (DECL_P (gnu_decl
)
5266 && !(is_type
&& gnat_equiv_type
!= gnat_entity
)
5267 && !Present (Alias (gnat_entity
))
5268 && !(Present (Renamed_Object (gnat_entity
)) && saved
))
5270 if (!Comes_From_Source (gnat_entity
))
5271 DECL_ARTIFICIAL (gnu_decl
) = 1;
5274 DECL_IGNORED_P (gnu_decl
) = 1;
5277 /* If we haven't already, associate the ..._DECL node that we just made with
5278 the input GNAT entity node. */
5280 save_gnu_tree (gnat_entity
, gnu_decl
, false);
5282 /* If this is an enumeration or floating-point type, we were not able to set
5283 the bounds since they refer to the type. These are always static. */
5284 if ((kind
== E_Enumeration_Type
&& Present (First_Literal (gnat_entity
)))
5285 || (kind
== E_Floating_Point_Type
&& !Vax_Float (gnat_entity
)))
5287 tree gnu_scalar_type
= gnu_type
;
5288 tree gnu_low_bound
, gnu_high_bound
;
5290 /* If this is a padded type, we need to use the underlying type. */
5291 if (TYPE_IS_PADDING_P (gnu_scalar_type
))
5292 gnu_scalar_type
= TREE_TYPE (TYPE_FIELDS (gnu_scalar_type
));
5294 /* If this is a floating point type and we haven't set a floating
5295 point type yet, use this in the evaluation of the bounds. */
5296 if (!longest_float_type_node
&& kind
== E_Floating_Point_Type
)
5297 longest_float_type_node
= gnu_scalar_type
;
5299 gnu_low_bound
= gnat_to_gnu (Type_Low_Bound (gnat_entity
));
5300 gnu_high_bound
= gnat_to_gnu (Type_High_Bound (gnat_entity
));
5302 if (kind
== E_Enumeration_Type
)
5304 /* Enumeration types have specific RM bounds. */
5305 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type
, gnu_low_bound
);
5306 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type
, gnu_high_bound
);
5310 /* Floating-point types don't have specific RM bounds. */
5311 TYPE_GCC_MIN_VALUE (gnu_scalar_type
) = gnu_low_bound
;
5312 TYPE_GCC_MAX_VALUE (gnu_scalar_type
) = gnu_high_bound
;
5316 /* If we deferred processing of incomplete types, re-enable it. If there
5317 were no other disables and we have deferred types to process, do so. */
5319 && --defer_incomplete_level
== 0
5320 && defer_incomplete_list
)
5322 struct incomplete
*p
, *next
;
5324 /* We are back to level 0 for the deferring of incomplete types.
5325 But processing these incomplete types below may itself require
5326 deferring, so preserve what we have and restart from scratch. */
5327 p
= defer_incomplete_list
;
5328 defer_incomplete_list
= NULL
;
5335 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5336 gnat_to_gnu_type (p
->full_type
));
5341 /* If we are not defining this type, see if it's on one of the lists of
5342 incomplete types. If so, handle the list entry now. */
5343 if (is_type
&& !definition
)
5345 struct incomplete
*p
;
5347 for (p
= defer_incomplete_list
; p
; p
= p
->next
)
5348 if (p
->old_type
&& p
->full_type
== gnat_entity
)
5350 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5351 TREE_TYPE (gnu_decl
));
5352 p
->old_type
= NULL_TREE
;
5355 for (p
= defer_limited_with
; p
; p
= p
->next
)
5356 if (p
->old_type
&& Non_Limited_View (p
->full_type
) == gnat_entity
)
5358 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5359 TREE_TYPE (gnu_decl
));
5360 p
->old_type
= NULL_TREE
;
5367 /* If this is a packed array type whose original array type is itself
5368 an Itype without freeze node, make sure the latter is processed. */
5369 if (Is_Packed_Array_Type (gnat_entity
)
5370 && Is_Itype (Original_Array_Type (gnat_entity
))
5371 && No (Freeze_Node (Original_Array_Type (gnat_entity
)))
5372 && !present_gnu_tree (Original_Array_Type (gnat_entity
)))
5373 gnat_to_gnu_entity (Original_Array_Type (gnat_entity
), NULL_TREE
, 0);
5378 /* Similar, but if the returned value is a COMPONENT_REF, return the
5382 gnat_to_gnu_field_decl (Entity_Id gnat_entity
)
5384 tree gnu_field
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
5386 if (TREE_CODE (gnu_field
) == COMPONENT_REF
)
5387 gnu_field
= TREE_OPERAND (gnu_field
, 1);
5392 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5393 the GCC type corresponding to that entity. */
5396 gnat_to_gnu_type (Entity_Id gnat_entity
)
5400 /* The back end never attempts to annotate generic types. */
5401 if (Is_Generic_Type (gnat_entity
) && type_annotate_only
)
5402 return void_type_node
;
5404 gnu_decl
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
5405 gcc_assert (TREE_CODE (gnu_decl
) == TYPE_DECL
);
5407 return TREE_TYPE (gnu_decl
);
5410 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5411 the unpadded version of the GCC type corresponding to that entity. */
5414 get_unpadded_type (Entity_Id gnat_entity
)
5416 tree type
= gnat_to_gnu_type (gnat_entity
);
5418 if (TYPE_IS_PADDING_P (type
))
5419 type
= TREE_TYPE (TYPE_FIELDS (type
));
5424 /* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
5425 type has been changed to that of the parameterless procedure, except if an
5426 alias is already present, in which case it is returned instead. */
5429 get_minimal_subprog_decl (Entity_Id gnat_entity
)
5431 tree gnu_entity_name
, gnu_ext_name
;
5432 struct attrib
*attr_list
= NULL
;
5434 /* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
5435 of the handling applied here. */
5437 while (Present (Alias (gnat_entity
)))
5439 gnat_entity
= Alias (gnat_entity
);
5440 if (present_gnu_tree (gnat_entity
))
5441 return get_gnu_tree (gnat_entity
);
5444 gnu_entity_name
= get_entity_name (gnat_entity
);
5445 gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
5447 if (Has_Stdcall_Convention (gnat_entity
))
5448 prepend_one_attribute_to (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
5449 get_identifier ("stdcall"), NULL_TREE
,
5451 else if (Has_Thiscall_Convention (gnat_entity
))
5452 prepend_one_attribute_to (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
5453 get_identifier ("thiscall"), NULL_TREE
,
5456 if (No (Interface_Name (gnat_entity
)) && gnu_ext_name
== gnu_entity_name
)
5457 gnu_ext_name
= NULL_TREE
;
5460 create_subprog_decl (gnu_entity_name
, gnu_ext_name
, void_ftype
, NULL_TREE
,
5461 is_disabled
, true, true, true, attr_list
, gnat_entity
);
5464 /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
5465 a C++ imported method or equivalent.
5467 We use the predicate on 32-bit x86/Windows to find out whether we need to
5468 use the "thiscall" calling convention for GNAT_ENTITY. This convention is
5469 used for C++ methods (functions with METHOD_TYPE) by the back-end. */
5472 is_cplusplus_method (Entity_Id gnat_entity
)
5474 if (Convention (gnat_entity
) != Convention_CPP
)
5477 /* This is the main case: C++ method imported as a primitive operation. */
5478 if (Is_Dispatching_Operation (gnat_entity
))
5481 /* A thunk needs to be handled like its associated primitive operation. */
5482 if (Is_Subprogram (gnat_entity
) && Is_Thunk (gnat_entity
))
5485 /* C++ classes with no virtual functions can be imported as limited
5486 record types, but we need to return true for the constructors. */
5487 if (Is_Constructor (gnat_entity
))
5490 /* This is set on the E_Subprogram_Type built for a dispatching call. */
5491 if (Is_Dispatch_Table_Entity (gnat_entity
))
5497 /* Finalize the processing of From_Limited_With incomplete types. */
5500 finalize_from_limited_with (void)
5502 struct incomplete
*p
, *next
;
5504 p
= defer_limited_with
;
5505 defer_limited_with
= NULL
;
5512 update_pointer_to (TYPE_MAIN_VARIANT (p
->old_type
),
5513 gnat_to_gnu_type (p
->full_type
));
5518 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
5519 kind of type (such E_Task_Type) that has a different type which Gigi
5520 uses for its representation. If the type does not have a special type
5521 for its representation, return GNAT_ENTITY. If a type is supposed to
5522 exist, but does not, abort unless annotating types, in which case
5523 return Empty. If GNAT_ENTITY is Empty, return Empty. */
5526 Gigi_Equivalent_Type (Entity_Id gnat_entity
)
5528 Entity_Id gnat_equiv
= gnat_entity
;
5530 if (No (gnat_entity
))
5533 switch (Ekind (gnat_entity
))
5535 case E_Class_Wide_Subtype
:
5536 if (Present (Equivalent_Type (gnat_entity
)))
5537 gnat_equiv
= Equivalent_Type (gnat_entity
);
5540 case E_Access_Protected_Subprogram_Type
:
5541 case E_Anonymous_Access_Protected_Subprogram_Type
:
5542 gnat_equiv
= Equivalent_Type (gnat_entity
);
5545 case E_Class_Wide_Type
:
5546 gnat_equiv
= Root_Type (gnat_entity
);
5550 case E_Task_Subtype
:
5551 case E_Protected_Type
:
5552 case E_Protected_Subtype
:
5553 gnat_equiv
= Corresponding_Record_Type (gnat_entity
);
5560 gcc_assert (Present (gnat_equiv
) || type_annotate_only
);
5565 /* Return a GCC tree for a type corresponding to the component type of the
5566 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5567 is for an array being defined. DEBUG_INFO_P is true if we need to write
5568 debug information for other types that we may create in the process. */
5571 gnat_to_gnu_component_type (Entity_Id gnat_array
, bool definition
,
5574 const Entity_Id gnat_type
= Component_Type (gnat_array
);
5575 tree gnu_type
= gnat_to_gnu_type (gnat_type
);
5578 /* Try to get a smaller form of the component if needed. */
5579 if ((Is_Packed (gnat_array
)
5580 || Has_Component_Size_Clause (gnat_array
))
5581 && !Is_Bit_Packed_Array (gnat_array
)
5582 && !Has_Aliased_Components (gnat_array
)
5583 && !Strict_Alignment (gnat_type
)
5584 && RECORD_OR_UNION_TYPE_P (gnu_type
)
5585 && !TYPE_FAT_POINTER_P (gnu_type
)
5586 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type
)))
5587 gnu_type
= make_packable_type (gnu_type
, false);
5589 if (Has_Atomic_Components (gnat_array
))
5590 check_ok_for_atomic (gnu_type
, gnat_array
, true);
5592 /* Get and validate any specified Component_Size. */
5594 = validate_size (Component_Size (gnat_array
), gnu_type
, gnat_array
,
5595 Is_Bit_Packed_Array (gnat_array
) ? TYPE_DECL
: VAR_DECL
,
5596 true, Has_Component_Size_Clause (gnat_array
));
5598 /* If the array has aliased components and the component size can be zero,
5599 force at least unit size to ensure that the components have distinct
5602 && Has_Aliased_Components (gnat_array
)
5603 && (integer_zerop (TYPE_SIZE (gnu_type
))
5604 || (TREE_CODE (gnu_type
) == ARRAY_TYPE
5605 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
)))))
5607 = size_binop (MAX_EXPR
, TYPE_SIZE (gnu_type
), bitsize_unit_node
);
5609 /* If the component type is a RECORD_TYPE that has a self-referential size,
5610 then use the maximum size for the component size. */
5612 && TREE_CODE (gnu_type
) == RECORD_TYPE
5613 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
5614 gnu_comp_size
= max_size (TYPE_SIZE (gnu_type
), true);
5616 /* Honor the component size. This is not needed for bit-packed arrays. */
5617 if (gnu_comp_size
&& !Is_Bit_Packed_Array (gnat_array
))
5619 tree orig_type
= gnu_type
;
5620 unsigned int max_align
;
5622 /* If an alignment is specified, use it as a cap on the component type
5623 so that it can be honored for the whole type. But ignore it for the
5624 original type of packed array types. */
5625 if (No (Packed_Array_Type (gnat_array
)) && Known_Alignment (gnat_array
))
5626 max_align
= validate_alignment (Alignment (gnat_array
), gnat_array
, 0);
5630 gnu_type
= make_type_from_size (gnu_type
, gnu_comp_size
, false);
5631 if (max_align
> 0 && TYPE_ALIGN (gnu_type
) > max_align
)
5632 gnu_type
= orig_type
;
5634 orig_type
= gnu_type
;
5636 gnu_type
= maybe_pad_type (gnu_type
, gnu_comp_size
, 0, gnat_array
,
5637 true, false, definition
, true);
5639 /* If a padding record was made, declare it now since it will never be
5640 declared otherwise. This is necessary to ensure that its subtrees
5641 are properly marked. */
5642 if (gnu_type
!= orig_type
&& !DECL_P (TYPE_NAME (gnu_type
)))
5643 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, true, debug_info_p
,
5647 if (Has_Volatile_Components (gnat_array
))
5649 = build_qualified_type (gnu_type
,
5650 TYPE_QUALS (gnu_type
) | TYPE_QUAL_VOLATILE
);
5655 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5656 using MECH as its passing mechanism, to be placed in the parameter
5657 list built for GNAT_SUBPROG. Assume a foreign convention for the
5658 latter if FOREIGN is true. Also set CICO to true if the parameter
5659 must use the copy-in copy-out implementation mechanism.
5661 The returned tree is a PARM_DECL, except for those cases where no
5662 parameter needs to be actually passed to the subprogram; the type
5663 of this "shadow" parameter is then returned instead. */
5666 gnat_to_gnu_param (Entity_Id gnat_param
, Mechanism_Type mech
,
5667 Entity_Id gnat_subprog
, bool foreign
, bool *cico
)
5669 tree gnu_param_name
= get_entity_name (gnat_param
);
5670 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
5671 tree gnu_param_type_alt
= NULL_TREE
;
5672 bool in_param
= (Ekind (gnat_param
) == E_In_Parameter
);
5673 /* The parameter can be indirectly modified if its address is taken. */
5674 bool ro_param
= in_param
&& !Address_Taken (gnat_param
);
5675 bool by_return
= false, by_component_ptr
= false;
5676 bool by_ref
= false;
5679 /* Copy-return is used only for the first parameter of a valued procedure.
5680 It's a copy mechanism for which a parameter is never allocated. */
5681 if (mech
== By_Copy_Return
)
5683 gcc_assert (Ekind (gnat_param
) == E_Out_Parameter
);
5688 /* If this is either a foreign function or if the underlying type won't
5689 be passed by reference, strip off possible padding type. */
5690 if (TYPE_IS_PADDING_P (gnu_param_type
))
5692 tree unpadded_type
= TREE_TYPE (TYPE_FIELDS (gnu_param_type
));
5694 if (mech
== By_Reference
5696 || (!must_pass_by_ref (unpadded_type
)
5697 && (mech
== By_Copy
|| !default_pass_by_ref (unpadded_type
))))
5698 gnu_param_type
= unpadded_type
;
5701 /* If this is a read-only parameter, make a variant of the type that is
5702 read-only. ??? However, if this is an unconstrained array, that type
5703 can be very complex, so skip it for now. Likewise for any other
5704 self-referential type. */
5706 && TREE_CODE (gnu_param_type
) != UNCONSTRAINED_ARRAY_TYPE
5707 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type
)))
5708 gnu_param_type
= build_qualified_type (gnu_param_type
,
5709 (TYPE_QUALS (gnu_param_type
)
5710 | TYPE_QUAL_CONST
));
5712 /* For foreign conventions, pass arrays as pointers to the element type.
5713 First check for unconstrained array and get the underlying array. */
5714 if (foreign
&& TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5716 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type
))));
5718 /* For GCC builtins, pass Address integer types as (void *) */
5719 if (Convention (gnat_subprog
) == Convention_Intrinsic
5720 && Present (Interface_Name (gnat_subprog
))
5721 && Is_Descendent_Of_Address (Etype (gnat_param
)))
5722 gnu_param_type
= ptr_void_type_node
;
5724 /* VMS descriptors are themselves passed by reference. */
5725 if (mech
== By_Short_Descriptor
||
5726 (mech
== By_Descriptor
&& TARGET_ABI_OPEN_VMS
&& !flag_vms_malloc64
))
5728 = build_pointer_type (build_vms_descriptor32 (gnu_param_type
,
5729 Mechanism (gnat_param
),
5731 else if (mech
== By_Descriptor
)
5733 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5734 chosen in fill_vms_descriptor. */
5736 = build_pointer_type (build_vms_descriptor32 (gnu_param_type
,
5737 Mechanism (gnat_param
),
5740 = build_pointer_type (build_vms_descriptor (gnu_param_type
,
5741 Mechanism (gnat_param
),
5745 /* Arrays are passed as pointers to element type for foreign conventions. */
5748 && TREE_CODE (gnu_param_type
) == ARRAY_TYPE
)
5750 /* Strip off any multi-dimensional entries, then strip
5751 off the last array to get the component type. */
5752 while (TREE_CODE (TREE_TYPE (gnu_param_type
)) == ARRAY_TYPE
5753 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type
)))
5754 gnu_param_type
= TREE_TYPE (gnu_param_type
);
5756 by_component_ptr
= true;
5757 gnu_param_type
= TREE_TYPE (gnu_param_type
);
5760 gnu_param_type
= build_qualified_type (gnu_param_type
,
5761 (TYPE_QUALS (gnu_param_type
)
5762 | TYPE_QUAL_CONST
));
5764 gnu_param_type
= build_pointer_type (gnu_param_type
);
5767 /* Fat pointers are passed as thin pointers for foreign conventions. */
5768 else if (foreign
&& TYPE_IS_FAT_POINTER_P (gnu_param_type
))
5770 = make_type_from_size (gnu_param_type
, size_int (POINTER_SIZE
), 0);
5772 /* If we must pass or were requested to pass by reference, do so.
5773 If we were requested to pass by copy, do so.
5774 Otherwise, for foreign conventions, pass In Out or Out parameters
5775 or aggregates by reference. For COBOL and Fortran, pass all
5776 integer and FP types that way too. For Convention Ada, use
5777 the standard Ada default. */
5778 else if (must_pass_by_ref (gnu_param_type
)
5779 || mech
== By_Reference
5782 && (!in_param
|| AGGREGATE_TYPE_P (gnu_param_type
)))
5784 && (Convention (gnat_subprog
) == Convention_Fortran
5785 || Convention (gnat_subprog
) == Convention_COBOL
)
5786 && (INTEGRAL_TYPE_P (gnu_param_type
)
5787 || FLOAT_TYPE_P (gnu_param_type
)))
5789 && default_pass_by_ref (gnu_param_type
)))))
5791 /* We take advantage of 6.2(12) by considering that references built for
5792 parameters whose type isn't by-ref and for which the mechanism hasn't
5793 been forced to by-ref are restrict-qualified in the C sense. */
5795 = !TYPE_IS_BY_REFERENCE_P (gnu_param_type
) && mech
!= By_Reference
;
5796 gnu_param_type
= build_reference_type (gnu_param_type
);
5799 = build_qualified_type (gnu_param_type
, TYPE_QUAL_RESTRICT
);
5803 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5807 if (mech
== By_Copy
&& (by_ref
|| by_component_ptr
))
5808 post_error ("?cannot pass & by copy", gnat_param
);
5810 /* If this is an Out parameter that isn't passed by reference and isn't
5811 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5812 it will be a VAR_DECL created when we process the procedure, so just
5813 return its type. For the special parameter of a valued procedure,
5816 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5817 Out parameters with discriminants or implicit initial values to be
5818 handled like In Out parameters. These type are normally built as
5819 aggregates, hence passed by reference, except for some packed arrays
5820 which end up encoded in special integer types.
5822 The exception we need to make is then for packed arrays of records
5823 with discriminants or implicit initial values. We have no light/easy
5824 way to check for the latter case, so we merely check for packed arrays
5825 of records. This may lead to useless copy-in operations, but in very
5826 rare cases only, as these would be exceptions in a set of already
5827 exceptional situations. */
5828 if (Ekind (gnat_param
) == E_Out_Parameter
5831 || (mech
!= By_Descriptor
5832 && mech
!= By_Short_Descriptor
5833 && !POINTER_TYPE_P (gnu_param_type
)
5834 && !AGGREGATE_TYPE_P (gnu_param_type
)))
5835 && !(Is_Array_Type (Etype (gnat_param
))
5836 && Is_Packed (Etype (gnat_param
))
5837 && Is_Composite_Type (Component_Type (Etype (gnat_param
)))))
5838 return gnu_param_type
;
5840 gnu_param
= create_param_decl (gnu_param_name
, gnu_param_type
,
5841 ro_param
|| by_ref
|| by_component_ptr
);
5842 DECL_BY_REF_P (gnu_param
) = by_ref
;
5843 DECL_BY_COMPONENT_PTR_P (gnu_param
) = by_component_ptr
;
5844 DECL_BY_DESCRIPTOR_P (gnu_param
)
5845 = (mech
== By_Descriptor
|| mech
== By_Short_Descriptor
);
5846 DECL_POINTS_TO_READONLY_P (gnu_param
)
5847 = (ro_param
&& (by_ref
|| by_component_ptr
));
5848 DECL_CAN_NEVER_BE_NULL_P (gnu_param
) = Can_Never_Be_Null (gnat_param
);
5850 /* Save the alternate descriptor type, if any. */
5851 if (gnu_param_type_alt
)
5852 SET_DECL_PARM_ALT_TYPE (gnu_param
, gnu_param_type_alt
);
5854 /* If no Mechanism was specified, indicate what we're using, then
5855 back-annotate it. */
5856 if (mech
== Default
)
5857 mech
= (by_ref
|| by_component_ptr
) ? By_Reference
: By_Copy
;
5859 Set_Mechanism (gnat_param
, mech
);
5863 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5866 same_discriminant_p (Entity_Id discr1
, Entity_Id discr2
)
5868 while (Present (Corresponding_Discriminant (discr1
)))
5869 discr1
= Corresponding_Discriminant (discr1
);
5871 while (Present (Corresponding_Discriminant (discr2
)))
5872 discr2
= Corresponding_Discriminant (discr2
);
5875 Original_Record_Component (discr1
) == Original_Record_Component (discr2
);
5878 /* Return true if the array type GNU_TYPE, which represents a dimension of
5879 GNAT_TYPE, has a non-aliased component in the back-end sense. */
5882 array_type_has_nonaliased_component (tree gnu_type
, Entity_Id gnat_type
)
5884 /* If the array type is not the innermost dimension of the GNAT type,
5885 then it has a non-aliased component. */
5886 if (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
5887 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
5890 /* If the array type has an aliased component in the front-end sense,
5891 then it also has an aliased component in the back-end sense. */
5892 if (Has_Aliased_Components (gnat_type
))
5895 /* If this is a derived type, then it has a non-aliased component if
5896 and only if its parent type also has one. */
5897 if (Is_Derived_Type (gnat_type
))
5899 tree gnu_parent_type
= gnat_to_gnu_type (Etype (gnat_type
));
5901 if (TREE_CODE (gnu_parent_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5903 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type
))));
5904 for (index
= Number_Dimensions (gnat_type
) - 1; index
> 0; index
--)
5905 gnu_parent_type
= TREE_TYPE (gnu_parent_type
);
5906 return TYPE_NONALIASED_COMPONENT (gnu_parent_type
);
5909 /* Otherwise, rely exclusively on properties of the element type. */
5910 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type
));
5913 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5916 compile_time_known_address_p (Node_Id gnat_address
)
5918 /* Catch System'To_Address. */
5919 if (Nkind (gnat_address
) == N_Unchecked_Type_Conversion
)
5920 gnat_address
= Expression (gnat_address
);
5922 return Compile_Time_Known_Value (gnat_address
);
5925 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
5926 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
5929 cannot_be_superflat_p (Node_Id gnat_range
)
5931 Node_Id gnat_lb
= Low_Bound (gnat_range
), gnat_hb
= High_Bound (gnat_range
);
5932 Node_Id scalar_range
;
5933 tree gnu_lb
, gnu_hb
, gnu_lb_minus_one
;
5935 /* If the low bound is not constant, try to find an upper bound. */
5936 while (Nkind (gnat_lb
) != N_Integer_Literal
5937 && (Ekind (Etype (gnat_lb
)) == E_Signed_Integer_Subtype
5938 || Ekind (Etype (gnat_lb
)) == E_Modular_Integer_Subtype
)
5939 && (scalar_range
= Scalar_Range (Etype (gnat_lb
)))
5940 && (Nkind (scalar_range
) == N_Signed_Integer_Type_Definition
5941 || Nkind (scalar_range
) == N_Range
))
5942 gnat_lb
= High_Bound (scalar_range
);
5944 /* If the high bound is not constant, try to find a lower bound. */
5945 while (Nkind (gnat_hb
) != N_Integer_Literal
5946 && (Ekind (Etype (gnat_hb
)) == E_Signed_Integer_Subtype
5947 || Ekind (Etype (gnat_hb
)) == E_Modular_Integer_Subtype
)
5948 && (scalar_range
= Scalar_Range (Etype (gnat_hb
)))
5949 && (Nkind (scalar_range
) == N_Signed_Integer_Type_Definition
5950 || Nkind (scalar_range
) == N_Range
))
5951 gnat_hb
= Low_Bound (scalar_range
);
5953 /* If we have failed to find constant bounds, punt. */
5954 if (Nkind (gnat_lb
) != N_Integer_Literal
5955 || Nkind (gnat_hb
) != N_Integer_Literal
)
5958 /* We need at least a signed 64-bit type to catch most cases. */
5959 gnu_lb
= UI_To_gnu (Intval (gnat_lb
), sbitsizetype
);
5960 gnu_hb
= UI_To_gnu (Intval (gnat_hb
), sbitsizetype
);
5961 if (TREE_OVERFLOW (gnu_lb
) || TREE_OVERFLOW (gnu_hb
))
5964 /* If the low bound is the smallest integer, nothing can be smaller. */
5965 gnu_lb_minus_one
= size_binop (MINUS_EXPR
, gnu_lb
, sbitsize_one_node
);
5966 if (TREE_OVERFLOW (gnu_lb_minus_one
))
5969 return !tree_int_cst_lt (gnu_hb
, gnu_lb_minus_one
);
5972 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
5975 constructor_address_p (tree gnu_expr
)
5977 while (TREE_CODE (gnu_expr
) == NOP_EXPR
5978 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
5979 || TREE_CODE (gnu_expr
) == NON_LVALUE_EXPR
)
5980 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
5982 return (TREE_CODE (gnu_expr
) == ADDR_EXPR
5983 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == CONSTRUCTOR
);
5986 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5987 be elaborated at the point of its definition, but do nothing else. */
5990 elaborate_entity (Entity_Id gnat_entity
)
5992 switch (Ekind (gnat_entity
))
5994 case E_Signed_Integer_Subtype
:
5995 case E_Modular_Integer_Subtype
:
5996 case E_Enumeration_Subtype
:
5997 case E_Ordinary_Fixed_Point_Subtype
:
5998 case E_Decimal_Fixed_Point_Subtype
:
5999 case E_Floating_Point_Subtype
:
6001 Node_Id gnat_lb
= Type_Low_Bound (gnat_entity
);
6002 Node_Id gnat_hb
= Type_High_Bound (gnat_entity
);
6004 /* ??? Tests to avoid Constraint_Error in static expressions
6005 are needed until after the front stops generating bogus
6006 conversions on bounds of real types. */
6007 if (!Raises_Constraint_Error (gnat_lb
))
6008 elaborate_expression (gnat_lb
, gnat_entity
, get_identifier ("L"),
6009 true, false, Needs_Debug_Info (gnat_entity
));
6010 if (!Raises_Constraint_Error (gnat_hb
))
6011 elaborate_expression (gnat_hb
, gnat_entity
, get_identifier ("U"),
6012 true, false, Needs_Debug_Info (gnat_entity
));
6016 case E_Record_Subtype
:
6017 case E_Private_Subtype
:
6018 case E_Limited_Private_Subtype
:
6019 case E_Record_Subtype_With_Private
:
6020 if (Has_Discriminants (gnat_entity
) && Is_Constrained (gnat_entity
))
6022 Node_Id gnat_discriminant_expr
;
6023 Entity_Id gnat_field
;
6026 = First_Discriminant (Implementation_Base_Type (gnat_entity
)),
6027 gnat_discriminant_expr
6028 = First_Elmt (Discriminant_Constraint (gnat_entity
));
6029 Present (gnat_field
);
6030 gnat_field
= Next_Discriminant (gnat_field
),
6031 gnat_discriminant_expr
= Next_Elmt (gnat_discriminant_expr
))
6032 /* Ignore access discriminants. */
6033 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr
))))
6034 elaborate_expression (Node (gnat_discriminant_expr
),
6035 gnat_entity
, get_entity_name (gnat_field
),
6036 true, false, false);
6043 /* Return true if the size in units represented by GNU_SIZE can be handled by
6044 an allocation. If STATIC_P is true, consider only what can be done with a
6045 static allocation. */
6048 allocatable_size_p (tree gnu_size
, bool static_p
)
6050 /* We can allocate a fixed size if it is a valid for the middle-end. */
6051 if (TREE_CODE (gnu_size
) == INTEGER_CST
)
6052 return valid_constant_size_p (gnu_size
);
6054 /* We can allocate a variable size if this isn't a static allocation. */
6059 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
6060 NAME, ARGS and ERROR_POINT. */
6063 prepend_one_attribute_to (struct attrib
** attr_list
,
6064 enum attr_type attr_type
,
6067 Node_Id attr_error_point
)
6069 struct attrib
* attr
= (struct attrib
*) xmalloc (sizeof (struct attrib
));
6071 attr
->type
= attr_type
;
6072 attr
->name
= attr_name
;
6073 attr
->args
= attr_args
;
6074 attr
->error_point
= attr_error_point
;
6076 attr
->next
= *attr_list
;
6080 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
6083 prepend_attributes (Entity_Id gnat_entity
, struct attrib
** attr_list
)
6087 /* Attributes are stored as Representation Item pragmas. */
6089 for (gnat_temp
= First_Rep_Item (gnat_entity
); Present (gnat_temp
);
6090 gnat_temp
= Next_Rep_Item (gnat_temp
))
6091 if (Nkind (gnat_temp
) == N_Pragma
)
6093 tree gnu_arg0
= NULL_TREE
, gnu_arg1
= NULL_TREE
;
6094 Node_Id gnat_assoc
= Pragma_Argument_Associations (gnat_temp
);
6095 enum attr_type etype
;
6097 /* Map the kind of pragma at hand. Skip if this is not one
6098 we know how to handle. */
6100 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp
))))
6102 case Pragma_Machine_Attribute
:
6103 etype
= ATTR_MACHINE_ATTRIBUTE
;
6106 case Pragma_Linker_Alias
:
6107 etype
= ATTR_LINK_ALIAS
;
6110 case Pragma_Linker_Section
:
6111 etype
= ATTR_LINK_SECTION
;
6114 case Pragma_Linker_Constructor
:
6115 etype
= ATTR_LINK_CONSTRUCTOR
;
6118 case Pragma_Linker_Destructor
:
6119 etype
= ATTR_LINK_DESTRUCTOR
;
6122 case Pragma_Weak_External
:
6123 etype
= ATTR_WEAK_EXTERNAL
;
6126 case Pragma_Thread_Local_Storage
:
6127 etype
= ATTR_THREAD_LOCAL_STORAGE
;
6134 /* See what arguments we have and turn them into GCC trees for
6135 attribute handlers. These expect identifier for strings. We
6136 handle at most two arguments, static expressions only. */
6138 if (Present (gnat_assoc
) && Present (First (gnat_assoc
)))
6140 Node_Id gnat_arg0
= Next (First (gnat_assoc
));
6141 Node_Id gnat_arg1
= Empty
;
6143 if (Present (gnat_arg0
)
6144 && Is_Static_Expression (Expression (gnat_arg0
)))
6146 gnu_arg0
= gnat_to_gnu (Expression (gnat_arg0
));
6148 if (TREE_CODE (gnu_arg0
) == STRING_CST
)
6149 gnu_arg0
= get_identifier (TREE_STRING_POINTER (gnu_arg0
));
6151 gnat_arg1
= Next (gnat_arg0
);
6154 if (Present (gnat_arg1
)
6155 && Is_Static_Expression (Expression (gnat_arg1
)))
6157 gnu_arg1
= gnat_to_gnu (Expression (gnat_arg1
));
6159 if (TREE_CODE (gnu_arg1
) == STRING_CST
)
6160 gnu_arg1
= get_identifier (TREE_STRING_POINTER (gnu_arg1
));
6164 /* Prepend to the list now. Make a list of the argument we might
6165 have, as GCC expects it. */
6166 prepend_one_attribute_to
6169 (gnu_arg1
!= NULL_TREE
)
6170 ? build_tree_list (NULL_TREE
, gnu_arg1
) : NULL_TREE
,
6171 Present (Next (First (gnat_assoc
)))
6172 ? Expression (Next (First (gnat_assoc
))) : gnat_temp
);
6176 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6177 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6178 return the GCC tree to use for that expression. GNU_NAME is the suffix
6179 to use if a variable needs to be created and DEFINITION is true if this
6180 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6181 otherwise, we are just elaborating the expression for side-effects. If
6182 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6183 isn't needed for code generation. */
6186 elaborate_expression (Node_Id gnat_expr
, Entity_Id gnat_entity
, tree gnu_name
,
6187 bool definition
, bool need_value
, bool need_debug
)
6191 /* If we already elaborated this expression (e.g. it was involved
6192 in the definition of a private type), use the old value. */
6193 if (present_gnu_tree (gnat_expr
))
6194 return get_gnu_tree (gnat_expr
);
6196 /* If we don't need a value and this is static or a discriminant,
6197 we don't need to do anything. */
6199 && (Is_OK_Static_Expression (gnat_expr
)
6200 || (Nkind (gnat_expr
) == N_Identifier
6201 && Ekind (Entity (gnat_expr
)) == E_Discriminant
)))
6204 /* If it's a static expression, we don't need a variable for debugging. */
6205 if (need_debug
&& Is_OK_Static_Expression (gnat_expr
))
6208 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6209 gnu_expr
= elaborate_expression_1 (gnat_to_gnu (gnat_expr
), gnat_entity
,
6210 gnu_name
, definition
, need_debug
);
6212 /* Save the expression in case we try to elaborate this entity again. Since
6213 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6214 if (!CONTAINS_PLACEHOLDER_P (gnu_expr
))
6215 save_gnu_tree (gnat_expr
, gnu_expr
, true);
6217 return need_value
? gnu_expr
: error_mark_node
;
6220 /* Similar, but take a GNU expression and always return a result. */
6223 elaborate_expression_1 (tree gnu_expr
, Entity_Id gnat_entity
, tree gnu_name
,
6224 bool definition
, bool need_debug
)
6226 const bool expr_public_p
= Is_Public (gnat_entity
);
6227 const bool expr_global_p
= expr_public_p
|| global_bindings_p ();
6228 bool expr_variable_p
, use_variable
;
6230 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
6231 reference will have been replaced with a COMPONENT_REF when the type
6232 is being elaborated. However, there are some cases involving child
6233 types where we will. So convert it to a COMPONENT_REF. We hope it
6234 will be at the highest level of the expression in these cases. */
6235 if (TREE_CODE (gnu_expr
) == FIELD_DECL
)
6236 gnu_expr
= build3 (COMPONENT_REF
, TREE_TYPE (gnu_expr
),
6237 build0 (PLACEHOLDER_EXPR
, DECL_CONTEXT (gnu_expr
)),
6238 gnu_expr
, NULL_TREE
);
6240 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6241 that an expression cannot contain both a discriminant and a variable. */
6242 if (CONTAINS_PLACEHOLDER_P (gnu_expr
))
6245 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6246 a variable that is initialized to contain the expression when the package
6247 containing the definition is elaborated. If this entity is defined at top
6248 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6249 if this is necessary. */
6250 if (CONSTANT_CLASS_P (gnu_expr
))
6251 expr_variable_p
= false;
6254 /* Skip any conversions and simple constant arithmetics to see if the
6255 expression is based on a read-only variable.
6256 ??? This really should remain read-only, but we have to think about
6257 the typing of the tree here. */
6258 tree inner
= remove_conversions (gnu_expr
, true);
6260 inner
= skip_simple_constant_arithmetic (inner
);
6262 if (handled_component_p (inner
))
6264 HOST_WIDE_INT bitsize
, bitpos
;
6266 enum machine_mode mode
;
6267 int unsignedp
, volatilep
;
6269 inner
= get_inner_reference (inner
, &bitsize
, &bitpos
, &offset
,
6270 &mode
, &unsignedp
, &volatilep
, false);
6271 /* If the offset is variable, err on the side of caution. */
6278 && TREE_CODE (inner
) == VAR_DECL
6279 && (TREE_READONLY (inner
) || DECL_READONLY_ONCE_ELAB (inner
)));
6282 /* We only need to use the variable if we are in a global context since GCC
6283 can do the right thing in the local case. However, when not optimizing,
6284 use it for bounds of loop iteration scheme to avoid code duplication. */
6285 use_variable
= expr_variable_p
6289 && Is_Itype (gnat_entity
)
6290 && Nkind (Associated_Node_For_Itype (gnat_entity
))
6291 == N_Loop_Parameter_Specification
));
6293 /* Now create it, possibly only for debugging purposes. */
6294 if (use_variable
|| need_debug
)
6298 (create_concat_name (gnat_entity
, IDENTIFIER_POINTER (gnu_name
)),
6299 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
, true, expr_public_p
,
6300 !definition
, expr_global_p
, !need_debug
, NULL
, gnat_entity
);
6306 return expr_variable_p
? gnat_save_expr (gnu_expr
) : gnu_expr
;
6309 /* Similar, but take an alignment factor and make it explicit in the tree. */
6312 elaborate_expression_2 (tree gnu_expr
, Entity_Id gnat_entity
, tree gnu_name
,
6313 bool definition
, bool need_debug
, unsigned int align
)
6315 tree unit_align
= size_int (align
/ BITS_PER_UNIT
);
6317 size_binop (MULT_EXPR
,
6318 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR
,
6321 gnat_entity
, gnu_name
, definition
,
6326 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6327 the value passed against the list of choices. */
6330 choices_to_gnu (tree operand
, Node_Id choices
)
6334 tree result
= boolean_false_node
;
6335 tree this_test
, low
= 0, high
= 0, single
= 0;
6337 for (choice
= First (choices
); Present (choice
); choice
= Next (choice
))
6339 switch (Nkind (choice
))
6342 low
= gnat_to_gnu (Low_Bound (choice
));
6343 high
= gnat_to_gnu (High_Bound (choice
));
6346 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6347 build_binary_op (GE_EXPR
, boolean_type_node
,
6349 build_binary_op (LE_EXPR
, boolean_type_node
,
6354 case N_Subtype_Indication
:
6355 gnat_temp
= Range_Expression (Constraint (choice
));
6356 low
= gnat_to_gnu (Low_Bound (gnat_temp
));
6357 high
= gnat_to_gnu (High_Bound (gnat_temp
));
6360 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6361 build_binary_op (GE_EXPR
, boolean_type_node
,
6363 build_binary_op (LE_EXPR
, boolean_type_node
,
6368 case N_Expanded_Name
:
6369 /* This represents either a subtype range, an enumeration
6370 literal, or a constant Ekind says which. If an enumeration
6371 literal or constant, fall through to the next case. */
6372 if (Ekind (Entity (choice
)) != E_Enumeration_Literal
6373 && Ekind (Entity (choice
)) != E_Constant
)
6375 tree type
= gnat_to_gnu_type (Entity (choice
));
6377 low
= TYPE_MIN_VALUE (type
);
6378 high
= TYPE_MAX_VALUE (type
);
6381 = build_binary_op (TRUTH_ANDIF_EXPR
, boolean_type_node
,
6382 build_binary_op (GE_EXPR
, boolean_type_node
,
6384 build_binary_op (LE_EXPR
, boolean_type_node
,
6389 /* ... fall through ... */
6391 case N_Character_Literal
:
6392 case N_Integer_Literal
:
6393 single
= gnat_to_gnu (choice
);
6394 this_test
= build_binary_op (EQ_EXPR
, boolean_type_node
, operand
,
6398 case N_Others_Choice
:
6399 this_test
= boolean_true_node
;
6406 result
= build_binary_op (TRUTH_ORIF_EXPR
, boolean_type_node
, result
,
6413 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6414 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6417 adjust_packed (tree field_type
, tree record_type
, int packed
)
6419 /* If the field contains an item of variable size, we cannot pack it
6420 because we cannot create temporaries of non-fixed size in case
6421 we need to take the address of the field. See addressable_p and
6422 the notes on the addressability issues for further details. */
6423 if (type_has_variable_size (field_type
))
6426 /* If the alignment of the record is specified and the field type
6427 is over-aligned, request Storage_Unit alignment for the field. */
6430 if (TYPE_ALIGN (field_type
) > TYPE_ALIGN (record_type
))
6439 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6440 placed in GNU_RECORD_TYPE.
6442 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6443 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6444 record has a specified alignment.
6446 DEFINITION is true if this field is for a record being defined.
6448 DEBUG_INFO_P is true if we need to write debug information for types
6449 that we may create in the process. */
6452 gnat_to_gnu_field (Entity_Id gnat_field
, tree gnu_record_type
, int packed
,
6453 bool definition
, bool debug_info_p
)
6455 const Entity_Id gnat_field_type
= Etype (gnat_field
);
6456 tree gnu_field_type
= gnat_to_gnu_type (gnat_field_type
);
6457 tree gnu_field_id
= get_entity_name (gnat_field
);
6458 tree gnu_field
, gnu_size
, gnu_pos
;
6460 = (Treat_As_Volatile (gnat_field
) || Treat_As_Volatile (gnat_field_type
));
6461 bool needs_strict_alignment
6463 || Is_Aliased (gnat_field
)
6464 || Strict_Alignment (gnat_field_type
));
6466 /* If this field requires strict alignment, we cannot pack it because
6467 it would very likely be under-aligned in the record. */
6468 if (needs_strict_alignment
)
6471 packed
= adjust_packed (gnu_field_type
, gnu_record_type
, packed
);
6473 /* If a size is specified, use it. Otherwise, if the record type is packed,
6474 use the official RM size. See "Handling of Type'Size Values" in Einfo
6475 for further details. */
6476 if (Known_Esize (gnat_field
))
6477 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6478 gnat_field
, FIELD_DECL
, false, true);
6479 else if (packed
== 1)
6480 gnu_size
= validate_size (RM_Size (gnat_field_type
), gnu_field_type
,
6481 gnat_field
, FIELD_DECL
, false, true);
6483 gnu_size
= NULL_TREE
;
6485 /* If we have a specified size that is smaller than that of the field's type,
6486 or a position is specified, and the field's type is a record that doesn't
6487 require strict alignment, see if we can get either an integral mode form
6488 of the type or a smaller form. If we can, show a size was specified for
6489 the field if there wasn't one already, so we know to make this a bitfield
6490 and avoid making things wider.
6492 Changing to an integral mode form is useful when the record is packed as
6493 we can then place the field at a non-byte-aligned position and so achieve
6494 tighter packing. This is in addition required if the field shares a byte
6495 with another field and the front-end lets the back-end handle the access
6496 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6498 Changing to a smaller form is required if the specified size is smaller
6499 than that of the field's type and the type contains sub-fields that are
6500 padded, in order to avoid generating accesses to these sub-fields that
6501 are wider than the field.
6503 We avoid the transformation if it is not required or potentially useful,
6504 as it might entail an increase of the field's alignment and have ripple
6505 effects on the outer record type. A typical case is a field known to be
6506 byte-aligned and not to share a byte with another field. */
6507 if (!needs_strict_alignment
6508 && RECORD_OR_UNION_TYPE_P (gnu_field_type
)
6509 && !TYPE_FAT_POINTER_P (gnu_field_type
)
6510 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type
))
6513 && (tree_int_cst_lt (gnu_size
, TYPE_SIZE (gnu_field_type
))
6514 || (Present (Component_Clause (gnat_field
))
6515 && !(UI_To_Int (Component_Bit_Offset (gnat_field
))
6516 % BITS_PER_UNIT
== 0
6517 && value_factor_p (gnu_size
, BITS_PER_UNIT
)))))))
6519 tree gnu_packable_type
= make_packable_type (gnu_field_type
, true);
6520 if (gnu_packable_type
!= gnu_field_type
)
6522 gnu_field_type
= gnu_packable_type
;
6524 gnu_size
= rm_size (gnu_field_type
);
6528 if (Is_Atomic (gnat_field
))
6529 check_ok_for_atomic (gnu_field_type
, gnat_field
, false);
6531 if (Present (Component_Clause (gnat_field
)))
6533 Entity_Id gnat_parent
6534 = Parent_Subtype (Underlying_Type (Scope (gnat_field
)));
6536 gnu_pos
= UI_To_gnu (Component_Bit_Offset (gnat_field
), bitsizetype
);
6537 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6538 gnat_field
, FIELD_DECL
, false, true);
6540 /* Ensure the position does not overlap with the parent subtype, if there
6541 is one. This test is omitted if the parent of the tagged type has a
6542 full rep clause since, in this case, component clauses are allowed to
6543 overlay the space allocated for the parent type and the front-end has
6544 checked that there are no overlapping components. */
6545 if (Present (gnat_parent
) && !Is_Fully_Repped_Tagged_Type (gnat_parent
))
6547 tree gnu_parent
= gnat_to_gnu_type (gnat_parent
);
6549 if (TREE_CODE (TYPE_SIZE (gnu_parent
)) == INTEGER_CST
6550 && tree_int_cst_lt (gnu_pos
, TYPE_SIZE (gnu_parent
)))
6553 ("offset of& must be beyond parent{, minimum allowed is ^}",
6554 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6555 TYPE_SIZE_UNIT (gnu_parent
));
6559 /* If this field needs strict alignment, check that the record is
6560 sufficiently aligned and that position and size are consistent with
6561 the alignment. But don't do it if we are just annotating types and
6562 the field's type is tagged, since tagged types aren't fully laid out
6563 in this mode. Also, note that atomic implies volatile so the inner
6564 test sequences ordering is significant here. */
6565 if (needs_strict_alignment
6566 && !(type_annotate_only
&& Is_Tagged_Type (gnat_field_type
)))
6568 TYPE_ALIGN (gnu_record_type
)
6569 = MAX (TYPE_ALIGN (gnu_record_type
), TYPE_ALIGN (gnu_field_type
));
6572 && !operand_equal_p (gnu_size
, TYPE_SIZE (gnu_field_type
), 0))
6574 if (Is_Atomic (gnat_field
) || Is_Atomic (gnat_field_type
))
6576 ("atomic field& must be natural size of type{ (^)}",
6577 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6578 TYPE_SIZE (gnu_field_type
));
6580 else if (is_volatile
)
6582 ("volatile field& must be natural size of type{ (^)}",
6583 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6584 TYPE_SIZE (gnu_field_type
));
6586 else if (Is_Aliased (gnat_field
))
6588 ("size of aliased field& must be ^ bits",
6589 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6590 TYPE_SIZE (gnu_field_type
));
6592 else if (Strict_Alignment (gnat_field_type
))
6594 ("size of & with aliased or tagged components not ^ bits",
6595 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6596 TYPE_SIZE (gnu_field_type
));
6601 gnu_size
= NULL_TREE
;
6604 if (!integer_zerop (size_binop
6605 (TRUNC_MOD_EXPR
, gnu_pos
,
6606 bitsize_int (TYPE_ALIGN (gnu_field_type
)))))
6608 if (Is_Atomic (gnat_field
) || Is_Atomic (gnat_field_type
))
6610 ("position of atomic field& must be multiple of ^ bits",
6611 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6612 TYPE_ALIGN (gnu_field_type
));
6614 else if (is_volatile
)
6616 ("position of volatile field& must be multiple of ^ bits",
6617 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6618 TYPE_ALIGN (gnu_field_type
));
6620 else if (Is_Aliased (gnat_field
))
6622 ("position of aliased field& must be multiple of ^ bits",
6623 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6624 TYPE_ALIGN (gnu_field_type
));
6626 else if (Strict_Alignment (gnat_field_type
))
6628 ("position of & is not compatible with alignment required "
6629 "by its components",
6630 First_Bit (Component_Clause (gnat_field
)), gnat_field
);
6635 gnu_pos
= NULL_TREE
;
6640 /* If the record has rep clauses and this is the tag field, make a rep
6641 clause for it as well. */
6642 else if (Has_Specified_Layout (Scope (gnat_field
))
6643 && Chars (gnat_field
) == Name_uTag
)
6645 gnu_pos
= bitsize_zero_node
;
6646 gnu_size
= TYPE_SIZE (gnu_field_type
);
6651 gnu_pos
= NULL_TREE
;
6653 /* If we are packing the record and the field is BLKmode, round the
6654 size up to a byte boundary. */
6655 if (packed
&& TYPE_MODE (gnu_field_type
) == BLKmode
&& gnu_size
)
6656 gnu_size
= round_up (gnu_size
, BITS_PER_UNIT
);
6659 /* We need to make the size the maximum for the type if it is
6660 self-referential and an unconstrained type. In that case, we can't
6661 pack the field since we can't make a copy to align it. */
6662 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
6664 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type
))
6665 && !Is_Constrained (Underlying_Type (gnat_field_type
)))
6667 gnu_size
= max_size (TYPE_SIZE (gnu_field_type
), true);
6671 /* If a size is specified, adjust the field's type to it. */
6674 tree orig_field_type
;
6676 /* If the field's type is justified modular, we would need to remove
6677 the wrapper to (better) meet the layout requirements. However we
6678 can do so only if the field is not aliased to preserve the unique
6679 layout and if the prescribed size is not greater than that of the
6680 packed array to preserve the justification. */
6681 if (!needs_strict_alignment
6682 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
6683 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
6684 && tree_int_cst_compare (gnu_size
, TYPE_ADA_SIZE (gnu_field_type
))
6686 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
6688 /* Similarly if the field's type is a misaligned integral type, but
6689 there is no restriction on the size as there is no justification. */
6690 if (!needs_strict_alignment
6691 && TYPE_IS_PADDING_P (gnu_field_type
)
6692 && INTEGRAL_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_field_type
))))
6693 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
6696 = make_type_from_size (gnu_field_type
, gnu_size
,
6697 Has_Biased_Representation (gnat_field
));
6699 orig_field_type
= gnu_field_type
;
6700 gnu_field_type
= maybe_pad_type (gnu_field_type
, gnu_size
, 0, gnat_field
,
6701 false, false, definition
, true);
6703 /* If a padding record was made, declare it now since it will never be
6704 declared otherwise. This is necessary to ensure that its subtrees
6705 are properly marked. */
6706 if (gnu_field_type
!= orig_field_type
6707 && !DECL_P (TYPE_NAME (gnu_field_type
)))
6708 create_type_decl (TYPE_NAME (gnu_field_type
), gnu_field_type
, true,
6709 debug_info_p
, gnat_field
);
6712 /* Otherwise (or if there was an error), don't specify a position. */
6714 gnu_pos
= NULL_TREE
;
6716 gcc_assert (TREE_CODE (gnu_field_type
) != RECORD_TYPE
6717 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type
));
6719 /* Now create the decl for the field. */
6721 = create_field_decl (gnu_field_id
, gnu_field_type
, gnu_record_type
,
6722 gnu_size
, gnu_pos
, packed
, Is_Aliased (gnat_field
));
6723 Sloc_to_locus (Sloc (gnat_field
), &DECL_SOURCE_LOCATION (gnu_field
));
6724 DECL_ALIASED_P (gnu_field
) = Is_Aliased (gnat_field
);
6725 TREE_THIS_VOLATILE (gnu_field
) = TREE_SIDE_EFFECTS (gnu_field
) = is_volatile
;
6727 if (Ekind (gnat_field
) == E_Discriminant
)
6728 DECL_DISCRIMINANT_NUMBER (gnu_field
)
6729 = UI_To_gnu (Discriminant_Number (gnat_field
), sizetype
);
6734 /* Return true if at least one member of COMPONENT_LIST needs strict
6738 components_need_strict_alignment (Node_Id component_list
)
6740 Node_Id component_decl
;
6742 for (component_decl
= First_Non_Pragma (Component_Items (component_list
));
6743 Present (component_decl
);
6744 component_decl
= Next_Non_Pragma (component_decl
))
6746 Entity_Id gnat_field
= Defining_Entity (component_decl
);
6748 if (Is_Aliased (gnat_field
))
6751 if (Strict_Alignment (Etype (gnat_field
)))
6758 /* Return true if TYPE is a type with variable size or a padding type with a
6759 field of variable size or a record that has a field with such a type. */
6762 type_has_variable_size (tree type
)
6766 if (!TREE_CONSTANT (TYPE_SIZE (type
)))
6769 if (TYPE_IS_PADDING_P (type
)
6770 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type
))))
6773 if (!RECORD_OR_UNION_TYPE_P (type
))
6776 for (field
= TYPE_FIELDS (type
); field
; field
= DECL_CHAIN (field
))
6777 if (type_has_variable_size (TREE_TYPE (field
)))
6783 /* Return true if FIELD is an artificial field. */
6786 field_is_artificial (tree field
)
6788 /* These fields are generated by the front-end proper. */
6789 if (IDENTIFIER_POINTER (DECL_NAME (field
)) [0] == '_')
6792 /* These fields are generated by gigi. */
6793 if (DECL_INTERNAL_P (field
))
6799 /* Return true if FIELD is a non-artificial aliased field. */
6802 field_is_aliased (tree field
)
6804 if (field_is_artificial (field
))
6807 return DECL_ALIASED_P (field
);
6810 /* Return true if FIELD is a non-artificial field with self-referential
6814 field_has_self_size (tree field
)
6816 if (field_is_artificial (field
))
6819 if (DECL_SIZE (field
) && TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
)
6822 return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field
)));
6825 /* Return true if FIELD is a non-artificial field with variable size. */
6828 field_has_variable_size (tree field
)
6830 if (field_is_artificial (field
))
6833 if (DECL_SIZE (field
) && TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
)
6836 return TREE_CODE (TYPE_SIZE (TREE_TYPE (field
))) != INTEGER_CST
;
6839 /* qsort comparer for the bit positions of two record components. */
6842 compare_field_bitpos (const PTR rt1
, const PTR rt2
)
6844 const_tree
const field1
= * (const_tree
const *) rt1
;
6845 const_tree
const field2
= * (const_tree
const *) rt2
;
6847 = tree_int_cst_compare (bit_position (field1
), bit_position (field2
));
6849 return ret
? ret
: (int) (DECL_UID (field1
) - DECL_UID (field2
));
6852 /* Structure holding information for a given variant. */
6853 typedef struct vinfo
6855 /* The record type of the variant. */
6858 /* The name of the variant. */
6861 /* The qualifier of the variant. */
6864 /* Whether the variant has a rep clause. */
6867 /* Whether the variant is packed. */
6872 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set the
6873 result as the field list of GNU_RECORD_TYPE and finish it up. Return true
6874 if GNU_RECORD_TYPE has a rep clause which affects the layout (see below).
6875 When called from gnat_to_gnu_entity during the processing of a record type
6876 definition, the GCC node for the parent, if any, will be the single field
6877 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
6878 GNU_FIELD_LIST. The other calls to this function are recursive calls for
6879 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
6881 PACKED is 1 if this is for a packed record, -1 if this is for a record
6882 with Component_Alignment of Storage_Unit, -2 if this is for a record
6883 with a specified alignment.
6885 DEFINITION is true if we are defining this record type.
6887 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
6888 out the record. This means the alignment only serves to force fields to
6889 be bitfields, but not to require the record to be that aligned. This is
6892 ALL_REP is true if a rep clause is present for all the fields.
6894 UNCHECKED_UNION is true if we are building this type for a record with a
6895 Pragma Unchecked_Union.
6897 ARTIFICIAL is true if this is a type that was generated by the compiler.
6899 DEBUG_INFO is true if we need to write debug information about the type.
6901 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
6902 mean that its contents may be unused as well, only the container itself.
6904 REORDER is true if we are permitted to reorder components of this type.
6906 FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
6907 the outer record type down to this variant level. It is nonzero only if
6908 all the fields down to this level have a rep clause and ALL_REP is false.
6910 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6911 with a rep clause is to be added; in this case, that is all that should
6912 be done with such fields and the return value will be false. */
6915 components_to_record (tree gnu_record_type
, Node_Id gnat_component_list
,
6916 tree gnu_field_list
, int packed
, bool definition
,
6917 bool cancel_alignment
, bool all_rep
,
6918 bool unchecked_union
, bool artificial
,
6919 bool debug_info
, bool maybe_unused
, bool reorder
,
6920 tree first_free_pos
, tree
*p_gnu_rep_list
)
6922 bool all_rep_and_size
= all_rep
&& TYPE_SIZE (gnu_record_type
);
6923 bool variants_have_rep
= all_rep
;
6924 bool layout_with_rep
= false;
6925 bool has_self_field
= false;
6926 bool has_aliased_after_self_field
= false;
6927 Node_Id component_decl
, variant_part
;
6928 tree gnu_field
, gnu_next
, gnu_last
;
6929 tree gnu_variant_part
= NULL_TREE
;
6930 tree gnu_rep_list
= NULL_TREE
;
6931 tree gnu_var_list
= NULL_TREE
;
6932 tree gnu_self_list
= NULL_TREE
;
6934 /* For each component referenced in a component declaration create a GCC
6935 field and add it to the list, skipping pragmas in the GNAT list. */
6936 gnu_last
= tree_last (gnu_field_list
);
6937 if (Present (Component_Items (gnat_component_list
)))
6939 = First_Non_Pragma (Component_Items (gnat_component_list
));
6940 Present (component_decl
);
6941 component_decl
= Next_Non_Pragma (component_decl
))
6943 Entity_Id gnat_field
= Defining_Entity (component_decl
);
6944 Name_Id gnat_name
= Chars (gnat_field
);
6946 /* If present, the _Parent field must have been created as the single
6947 field of the record type. Put it before any other fields. */
6948 if (gnat_name
== Name_uParent
)
6950 gnu_field
= TYPE_FIELDS (gnu_record_type
);
6951 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
6955 gnu_field
= gnat_to_gnu_field (gnat_field
, gnu_record_type
, packed
,
6956 definition
, debug_info
);
6958 /* If this is the _Tag field, put it before any other fields. */
6959 if (gnat_name
== Name_uTag
)
6960 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
6962 /* If this is the _Controller field, put it before the other
6963 fields except for the _Tag or _Parent field. */
6964 else if (gnat_name
== Name_uController
&& gnu_last
)
6966 DECL_CHAIN (gnu_field
) = DECL_CHAIN (gnu_last
);
6967 DECL_CHAIN (gnu_last
) = gnu_field
;
6970 /* If this is a regular field, put it after the other fields. */
6973 DECL_CHAIN (gnu_field
) = gnu_field_list
;
6974 gnu_field_list
= gnu_field
;
6976 gnu_last
= gnu_field
;
6978 /* And record information for the final layout. */
6979 if (field_has_self_size (gnu_field
))
6980 has_self_field
= true;
6981 else if (has_self_field
&& field_is_aliased (gnu_field
))
6982 has_aliased_after_self_field
= true;
6986 save_gnu_tree (gnat_field
, gnu_field
, false);
6989 /* At the end of the component list there may be a variant part. */
6990 variant_part
= Variant_Part (gnat_component_list
);
6992 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6993 mutually exclusive and should go in the same memory. To do this we need
6994 to treat each variant as a record whose elements are created from the
6995 component list for the variant. So here we create the records from the
6996 lists for the variants and put them all into the QUAL_UNION_TYPE.
6997 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6998 use GNU_RECORD_TYPE if there are no fields so far. */
6999 if (Present (variant_part
))
7001 Node_Id gnat_discr
= Name (variant_part
), variant
;
7002 tree gnu_discr
= gnat_to_gnu (gnat_discr
);
7003 tree gnu_name
= TYPE_NAME (gnu_record_type
);
7005 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr
))),
7007 tree gnu_union_type
, gnu_union_name
;
7008 tree this_first_free_pos
, gnu_variant_list
= NULL_TREE
;
7009 bool union_field_needs_strict_alignment
= false;
7010 stack_vec
<vinfo_t
, 16> variant_types
;
7011 vinfo_t
*gnu_variant
;
7012 unsigned int variants_align
= 0;
7015 if (TREE_CODE (gnu_name
) == TYPE_DECL
)
7016 gnu_name
= DECL_NAME (gnu_name
);
7019 = concat_name (gnu_name
, IDENTIFIER_POINTER (gnu_var_name
));
7021 /* Reuse the enclosing union if this is an Unchecked_Union whose fields
7022 are all in the variant part, to match the layout of C unions. There
7023 is an associated check below. */
7024 if (TREE_CODE (gnu_record_type
) == UNION_TYPE
)
7025 gnu_union_type
= gnu_record_type
;
7029 = make_node (unchecked_union
? UNION_TYPE
: QUAL_UNION_TYPE
);
7031 TYPE_NAME (gnu_union_type
) = gnu_union_name
;
7032 TYPE_ALIGN (gnu_union_type
) = 0;
7033 TYPE_PACKED (gnu_union_type
) = TYPE_PACKED (gnu_record_type
);
7036 /* If all the fields down to this level have a rep clause, find out
7037 whether all the fields at this level also have one. If so, then
7038 compute the new first free position to be passed downward. */
7039 this_first_free_pos
= first_free_pos
;
7040 if (this_first_free_pos
)
7042 for (gnu_field
= gnu_field_list
;
7044 gnu_field
= DECL_CHAIN (gnu_field
))
7045 if (DECL_FIELD_OFFSET (gnu_field
))
7047 tree pos
= bit_position (gnu_field
);
7048 if (!tree_int_cst_lt (pos
, this_first_free_pos
))
7050 = size_binop (PLUS_EXPR
, pos
, DECL_SIZE (gnu_field
));
7054 this_first_free_pos
= NULL_TREE
;
7059 /* We build the variants in two passes. The bulk of the work is done in
7060 the first pass, that is to say translating the GNAT nodes, building
7061 the container types and computing the associated properties. However
7062 we cannot finish up the container types during this pass because we
7063 don't know where the variant part will be placed until the end. */
7064 for (variant
= First_Non_Pragma (Variants (variant_part
));
7066 variant
= Next_Non_Pragma (variant
))
7068 tree gnu_variant_type
= make_node (RECORD_TYPE
);
7069 tree gnu_inner_name
, gnu_qual
;
7074 Get_Variant_Encoding (variant
);
7075 gnu_inner_name
= get_identifier_with_length (Name_Buffer
, Name_Len
);
7076 TYPE_NAME (gnu_variant_type
)
7077 = concat_name (gnu_union_name
,
7078 IDENTIFIER_POINTER (gnu_inner_name
));
7080 /* Set the alignment of the inner type in case we need to make
7081 inner objects into bitfields, but then clear it out so the
7082 record actually gets only the alignment required. */
7083 TYPE_ALIGN (gnu_variant_type
) = TYPE_ALIGN (gnu_record_type
);
7084 TYPE_PACKED (gnu_variant_type
) = TYPE_PACKED (gnu_record_type
);
7086 /* Similarly, if the outer record has a size specified and all
7087 the fields have a rep clause, we can propagate the size. */
7088 if (all_rep_and_size
)
7090 TYPE_SIZE (gnu_variant_type
) = TYPE_SIZE (gnu_record_type
);
7091 TYPE_SIZE_UNIT (gnu_variant_type
)
7092 = TYPE_SIZE_UNIT (gnu_record_type
);
7095 /* Add the fields into the record type for the variant. Note that
7096 we aren't sure to really use it at this point, see below. */
7098 = components_to_record (gnu_variant_type
, Component_List (variant
),
7099 NULL_TREE
, packed
, definition
,
7100 !all_rep_and_size
, all_rep
,
7102 true, debug_info
, true, reorder
,
7103 this_first_free_pos
,
7104 all_rep
|| this_first_free_pos
7105 ? NULL
: &gnu_rep_list
);
7107 /* Translate the qualifier and annotate the GNAT node. */
7108 gnu_qual
= choices_to_gnu (gnu_discr
, Discrete_Choices (variant
));
7109 Set_Present_Expr (variant
, annotate_value (gnu_qual
));
7111 /* Deal with packedness like in gnat_to_gnu_field. */
7112 if (components_need_strict_alignment (Component_List (variant
)))
7115 union_field_needs_strict_alignment
= true;
7119 = adjust_packed (gnu_variant_type
, gnu_record_type
, packed
);
7121 /* Push this variant onto the stack for the second pass. */
7122 vinfo
.type
= gnu_variant_type
;
7123 vinfo
.name
= gnu_inner_name
;
7124 vinfo
.qual
= gnu_qual
;
7125 vinfo
.has_rep
= has_rep
;
7126 vinfo
.packed
= field_packed
;
7127 variant_types
.safe_push (vinfo
);
7129 /* Compute the global properties that will determine the placement of
7130 the variant part. */
7131 variants_have_rep
|= has_rep
;
7132 if (!field_packed
&& TYPE_ALIGN (gnu_variant_type
) > variants_align
)
7133 variants_align
= TYPE_ALIGN (gnu_variant_type
);
7136 /* Round up the first free position to the alignment of the variant part
7137 for the variants without rep clause. This will guarantee a consistent
7138 layout independently of the placement of the variant part. */
7139 if (variants_have_rep
&& variants_align
> 0 && this_first_free_pos
)
7140 this_first_free_pos
= round_up (this_first_free_pos
, variants_align
);
7142 /* In the second pass, the container types are adjusted if necessary and
7143 finished up, then the corresponding fields of the variant part are
7144 built with their qualifier, unless this is an unchecked union. */
7145 FOR_EACH_VEC_ELT (variant_types
, i
, gnu_variant
)
7147 tree gnu_variant_type
= gnu_variant
->type
;
7148 tree gnu_field_list
= TYPE_FIELDS (gnu_variant_type
);
7150 /* If this is an Unchecked_Union whose fields are all in the variant
7151 part and we have a single field with no representation clause or
7152 placed at offset zero, use the field directly to match the layout
7154 if (TREE_CODE (gnu_record_type
) == UNION_TYPE
7156 && !DECL_CHAIN (gnu_field_list
)
7157 && (!DECL_FIELD_OFFSET (gnu_field_list
)
7158 || integer_zerop (bit_position (gnu_field_list
))))
7160 gnu_field
= gnu_field_list
;
7161 DECL_CONTEXT (gnu_field
) = gnu_record_type
;
7165 /* Finalize the variant type now. We used to throw away empty
7166 record types but we no longer do that because we need them to
7167 generate complete debug info for the variant; otherwise, the
7168 union type definition will be lacking the fields associated
7169 with these empty variants. */
7170 if (gnu_field_list
&& variants_have_rep
&& !gnu_variant
->has_rep
)
7172 /* The variant part will be at offset 0 so we need to ensure
7173 that the fields are laid out starting from the first free
7174 position at this level. */
7175 tree gnu_rep_type
= make_node (RECORD_TYPE
);
7177 finish_record_type (gnu_rep_type
, NULL_TREE
, 0, debug_info
);
7179 = create_rep_part (gnu_rep_type
, gnu_variant_type
,
7180 this_first_free_pos
);
7181 DECL_CHAIN (gnu_rep_part
) = gnu_field_list
;
7182 gnu_field_list
= gnu_rep_part
;
7183 finish_record_type (gnu_variant_type
, gnu_field_list
, 0,
7188 rest_of_record_type_compilation (gnu_variant_type
);
7189 create_type_decl (TYPE_NAME (gnu_variant_type
), gnu_variant_type
,
7190 true, debug_info
, gnat_component_list
);
7193 = create_field_decl (gnu_variant
->name
, gnu_variant_type
,
7196 ? TYPE_SIZE (gnu_variant_type
) : 0,
7197 variants_have_rep
? bitsize_zero_node
: 0,
7198 gnu_variant
->packed
, 0);
7200 DECL_INTERNAL_P (gnu_field
) = 1;
7202 if (!unchecked_union
)
7203 DECL_QUALIFIER (gnu_field
) = gnu_variant
->qual
;
7206 DECL_CHAIN (gnu_field
) = gnu_variant_list
;
7207 gnu_variant_list
= gnu_field
;
7210 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7211 if (gnu_variant_list
)
7213 int union_field_packed
;
7215 if (all_rep_and_size
)
7217 TYPE_SIZE (gnu_union_type
) = TYPE_SIZE (gnu_record_type
);
7218 TYPE_SIZE_UNIT (gnu_union_type
)
7219 = TYPE_SIZE_UNIT (gnu_record_type
);
7222 finish_record_type (gnu_union_type
, nreverse (gnu_variant_list
),
7223 all_rep_and_size
? 1 : 0, debug_info
);
7225 /* If GNU_UNION_TYPE is our record type, it means we must have an
7226 Unchecked_Union with no fields. Verify that and, if so, just
7228 if (gnu_union_type
== gnu_record_type
)
7230 gcc_assert (unchecked_union
7233 return variants_have_rep
;
7236 create_type_decl (TYPE_NAME (gnu_union_type
), gnu_union_type
, true,
7237 debug_info
, gnat_component_list
);
7239 /* Deal with packedness like in gnat_to_gnu_field. */
7240 if (union_field_needs_strict_alignment
)
7241 union_field_packed
= 0;
7244 = adjust_packed (gnu_union_type
, gnu_record_type
, packed
);
7247 = create_field_decl (gnu_var_name
, gnu_union_type
, gnu_record_type
,
7249 ? TYPE_SIZE (gnu_union_type
) : 0,
7250 variants_have_rep
? bitsize_zero_node
: 0,
7251 union_field_packed
, 0);
7253 DECL_INTERNAL_P (gnu_variant_part
) = 1;
7257 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
7258 permitted to reorder components, self-referential sizes or variable sizes.
7259 If they do, pull them out and put them onto the appropriate list. We have
7260 to do this in a separate pass since we want to handle the discriminants
7261 but can't play with them until we've used them in debugging data above.
7263 ??? If we reorder them, debugging information will be wrong but there is
7264 nothing that can be done about this at the moment. */
7265 gnu_last
= NULL_TREE
;
7267 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7270 DECL_CHAIN (gnu_last) = gnu_next; \
7272 gnu_field_list = gnu_next; \
7274 DECL_CHAIN (gnu_field) = (LIST); \
7275 (LIST) = gnu_field; \
7278 for (gnu_field
= gnu_field_list
; gnu_field
; gnu_field
= gnu_next
)
7280 gnu_next
= DECL_CHAIN (gnu_field
);
7282 if (DECL_FIELD_OFFSET (gnu_field
))
7284 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list
);
7288 if ((reorder
|| has_aliased_after_self_field
)
7289 && field_has_self_size (gnu_field
))
7291 MOVE_FROM_FIELD_LIST_TO (gnu_self_list
);
7295 if (reorder
&& field_has_variable_size (gnu_field
))
7297 MOVE_FROM_FIELD_LIST_TO (gnu_var_list
);
7301 gnu_last
= gnu_field
;
7304 #undef MOVE_FROM_FIELD_LIST_TO
7306 gnu_field_list
= nreverse (gnu_field_list
);
7308 /* If permitted, we reorder the fields as follows:
7310 1) all fixed length fields,
7311 2) all fields whose length doesn't depend on discriminants,
7312 3) all fields whose length depends on discriminants,
7313 4) the variant part,
7315 within the record and within each variant recursively. */
7318 = chainon (gnu_field_list
, chainon (gnu_var_list
, gnu_self_list
));
7320 /* Otherwise, if there is an aliased field placed after a field whose length
7321 depends on discriminants, we put all the fields of the latter sort, last.
7322 We need to do this in case an object of this record type is mutable. */
7323 else if (has_aliased_after_self_field
)
7324 gnu_field_list
= chainon (gnu_field_list
, gnu_self_list
);
7326 /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
7327 in our REP list to the previous level because this level needs them in
7328 order to do a correct layout, i.e. avoid having overlapping fields. */
7329 if (p_gnu_rep_list
&& gnu_rep_list
)
7330 *p_gnu_rep_list
= chainon (*p_gnu_rep_list
, gnu_rep_list
);
7332 /* Otherwise, sort the fields by bit position and put them into their own
7333 record, before the others, if we also have fields without rep clause. */
7334 else if (gnu_rep_list
)
7336 tree gnu_rep_type
, gnu_rep_part
;
7337 int i
, len
= list_length (gnu_rep_list
);
7338 tree
*gnu_arr
= XALLOCAVEC (tree
, len
);
7340 /* If all the fields have a rep clause, we can do a flat layout. */
7341 layout_with_rep
= !gnu_field_list
7342 && (!gnu_variant_part
|| variants_have_rep
);
7344 = layout_with_rep
? gnu_record_type
: make_node (RECORD_TYPE
);
7346 for (gnu_field
= gnu_rep_list
, i
= 0;
7348 gnu_field
= DECL_CHAIN (gnu_field
), i
++)
7349 gnu_arr
[i
] = gnu_field
;
7351 qsort (gnu_arr
, len
, sizeof (tree
), compare_field_bitpos
);
7353 /* Put the fields in the list in order of increasing position, which
7354 means we start from the end. */
7355 gnu_rep_list
= NULL_TREE
;
7356 for (i
= len
- 1; i
>= 0; i
--)
7358 DECL_CHAIN (gnu_arr
[i
]) = gnu_rep_list
;
7359 gnu_rep_list
= gnu_arr
[i
];
7360 DECL_CONTEXT (gnu_arr
[i
]) = gnu_rep_type
;
7363 if (layout_with_rep
)
7364 gnu_field_list
= gnu_rep_list
;
7367 finish_record_type (gnu_rep_type
, gnu_rep_list
, 1, debug_info
);
7369 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
7370 without rep clause are laid out starting from this position.
7371 Therefore, we force it as a minimal size on the REP part. */
7373 = create_rep_part (gnu_rep_type
, gnu_record_type
, first_free_pos
);
7375 /* Chain the REP part at the beginning of the field list. */
7376 DECL_CHAIN (gnu_rep_part
) = gnu_field_list
;
7377 gnu_field_list
= gnu_rep_part
;
7381 /* Chain the variant part at the end of the field list. */
7382 if (gnu_variant_part
)
7383 gnu_field_list
= chainon (gnu_field_list
, gnu_variant_part
);
7385 if (cancel_alignment
)
7386 TYPE_ALIGN (gnu_record_type
) = 0;
7388 TYPE_ARTIFICIAL (gnu_record_type
) = artificial
;
7390 finish_record_type (gnu_record_type
, gnu_field_list
, layout_with_rep
? 1 : 0,
7391 debug_info
&& !maybe_unused
);
7393 return (gnu_rep_list
&& !p_gnu_rep_list
) || variants_have_rep
;
7396 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7397 placed into an Esize, Component_Bit_Offset, or Component_Size value
7398 in the GNAT tree. */
7401 annotate_value (tree gnu_size
)
7404 Node_Ref_Or_Val ops
[3], ret
, pre_op1
= No_Uint
;
7405 struct tree_int_map in
;
7408 /* See if we've already saved the value for this node. */
7409 if (EXPR_P (gnu_size
))
7411 struct tree_int_map
*e
;
7413 if (!annotate_value_cache
)
7414 annotate_value_cache
= htab_create_ggc (512, tree_int_map_hash
,
7415 tree_int_map_eq
, 0);
7416 in
.base
.from
= gnu_size
;
7417 e
= (struct tree_int_map
*)
7418 htab_find (annotate_value_cache
, &in
);
7421 return (Node_Ref_Or_Val
) e
->to
;
7424 in
.base
.from
= NULL_TREE
;
7426 /* If we do not return inside this switch, TCODE will be set to the
7427 code to use for a Create_Node operand and LEN (set above) will be
7428 the number of recursive calls for us to make. */
7430 switch (TREE_CODE (gnu_size
))
7433 return TREE_OVERFLOW (gnu_size
) ? No_Uint
: UI_From_gnu (gnu_size
);
7436 /* The only case we handle here is a simple discriminant reference. */
7437 if (DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size
, 1)))
7439 tree n
= DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size
, 1));
7441 /* Climb up the chain of successive extensions, if any. */
7442 while (TREE_CODE (TREE_OPERAND (gnu_size
, 0)) == COMPONENT_REF
7443 && DECL_NAME (TREE_OPERAND (TREE_OPERAND (gnu_size
, 0), 1))
7445 gnu_size
= TREE_OPERAND (gnu_size
, 0);
7447 if (TREE_CODE (TREE_OPERAND (gnu_size
, 0)) == PLACEHOLDER_EXPR
)
7449 Create_Node (Discrim_Val
, annotate_value (n
), No_Uint
, No_Uint
);
7454 CASE_CONVERT
: case NON_LVALUE_EXPR
:
7455 return annotate_value (TREE_OPERAND (gnu_size
, 0));
7457 /* Now just list the operations we handle. */
7458 case COND_EXPR
: tcode
= Cond_Expr
; break;
7459 case PLUS_EXPR
: tcode
= Plus_Expr
; break;
7460 case MINUS_EXPR
: tcode
= Minus_Expr
; break;
7461 case MULT_EXPR
: tcode
= Mult_Expr
; break;
7462 case TRUNC_DIV_EXPR
: tcode
= Trunc_Div_Expr
; break;
7463 case CEIL_DIV_EXPR
: tcode
= Ceil_Div_Expr
; break;
7464 case FLOOR_DIV_EXPR
: tcode
= Floor_Div_Expr
; break;
7465 case TRUNC_MOD_EXPR
: tcode
= Trunc_Mod_Expr
; break;
7466 case CEIL_MOD_EXPR
: tcode
= Ceil_Mod_Expr
; break;
7467 case FLOOR_MOD_EXPR
: tcode
= Floor_Mod_Expr
; break;
7468 case EXACT_DIV_EXPR
: tcode
= Exact_Div_Expr
; break;
7469 case NEGATE_EXPR
: tcode
= Negate_Expr
; break;
7470 case MIN_EXPR
: tcode
= Min_Expr
; break;
7471 case MAX_EXPR
: tcode
= Max_Expr
; break;
7472 case ABS_EXPR
: tcode
= Abs_Expr
; break;
7473 case TRUTH_ANDIF_EXPR
: tcode
= Truth_Andif_Expr
; break;
7474 case TRUTH_ORIF_EXPR
: tcode
= Truth_Orif_Expr
; break;
7475 case TRUTH_AND_EXPR
: tcode
= Truth_And_Expr
; break;
7476 case TRUTH_OR_EXPR
: tcode
= Truth_Or_Expr
; break;
7477 case TRUTH_XOR_EXPR
: tcode
= Truth_Xor_Expr
; break;
7478 case TRUTH_NOT_EXPR
: tcode
= Truth_Not_Expr
; break;
7479 case LT_EXPR
: tcode
= Lt_Expr
; break;
7480 case LE_EXPR
: tcode
= Le_Expr
; break;
7481 case GT_EXPR
: tcode
= Gt_Expr
; break;
7482 case GE_EXPR
: tcode
= Ge_Expr
; break;
7483 case EQ_EXPR
: tcode
= Eq_Expr
; break;
7484 case NE_EXPR
: tcode
= Ne_Expr
; break;
7487 tcode
= Bit_And_Expr
;
7488 /* For negative values, build NEGATE_EXPR of the opposite. Such values
7489 appear in expressions containing aligning patterns. Note that, since
7490 sizetype is unsigned, we have to jump through some hoops. */
7491 if (TREE_CODE (TREE_OPERAND (gnu_size
, 1)) == INTEGER_CST
)
7493 tree op1
= TREE_OPERAND (gnu_size
, 1);
7494 if (wi::neg_p (op1
))
7496 op1
= wide_int_to_tree (sizetype
, wi::neg (op1
));
7497 pre_op1
= annotate_value (build1 (NEGATE_EXPR
, sizetype
, op1
));
7504 tree t
= maybe_inline_call_in_expr (gnu_size
);
7506 return annotate_value (t
);
7509 /* Fall through... */
7515 /* Now get each of the operands that's relevant for this code. If any
7516 cannot be expressed as a repinfo node, say we can't. */
7517 for (i
= 0; i
< 3; i
++)
7520 for (i
= 0; i
< TREE_CODE_LENGTH (TREE_CODE (gnu_size
)); i
++)
7522 if (i
== 1 && pre_op1
!= No_Uint
)
7525 ops
[i
] = annotate_value (TREE_OPERAND (gnu_size
, i
));
7526 if (ops
[i
] == No_Uint
)
7530 ret
= Create_Node (tcode
, ops
[0], ops
[1], ops
[2]);
7532 /* Save the result in the cache. */
7535 struct tree_int_map
**h
;
7536 /* We can't assume the hash table data hasn't moved since the
7537 initial look up, so we have to search again. Allocating and
7538 inserting an entry at that point would be an alternative, but
7539 then we'd better discard the entry if we decided not to cache
7541 h
= (struct tree_int_map
**)
7542 htab_find_slot (annotate_value_cache
, &in
, INSERT
);
7544 *h
= ggc_alloc_tree_int_map ();
7545 (*h
)->base
.from
= gnu_size
;
7552 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7553 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7554 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7555 BY_REF is true if the object is used by reference. */
7558 annotate_object (Entity_Id gnat_entity
, tree gnu_type
, tree size
, bool by_ref
)
7562 if (TYPE_IS_FAT_POINTER_P (gnu_type
))
7563 gnu_type
= TYPE_UNCONSTRAINED_ARRAY (gnu_type
);
7565 gnu_type
= TREE_TYPE (gnu_type
);
7568 if (Unknown_Esize (gnat_entity
))
7570 if (TREE_CODE (gnu_type
) == RECORD_TYPE
7571 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7572 size
= TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
))));
7574 size
= TYPE_SIZE (gnu_type
);
7577 Set_Esize (gnat_entity
, annotate_value (size
));
7580 if (Unknown_Alignment (gnat_entity
))
7581 Set_Alignment (gnat_entity
,
7582 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
7585 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7586 Return NULL_TREE if there is no such element in the list. */
7589 purpose_member_field (const_tree elem
, tree list
)
7593 tree field
= TREE_PURPOSE (list
);
7594 if (SAME_FIELD_P (field
, elem
))
7596 list
= TREE_CHAIN (list
);
7601 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7602 set Component_Bit_Offset and Esize of the components to the position and
7603 size used by Gigi. */
7606 annotate_rep (Entity_Id gnat_entity
, tree gnu_type
)
7608 Entity_Id gnat_field
;
7611 /* We operate by first making a list of all fields and their position (we
7612 can get the size easily) and then update all the sizes in the tree. */
7614 = build_position_list (gnu_type
, false, size_zero_node
, bitsize_zero_node
,
7615 BIGGEST_ALIGNMENT
, NULL_TREE
);
7617 for (gnat_field
= First_Entity (gnat_entity
);
7618 Present (gnat_field
);
7619 gnat_field
= Next_Entity (gnat_field
))
7620 if (Ekind (gnat_field
) == E_Component
7621 || (Ekind (gnat_field
) == E_Discriminant
7622 && !Is_Unchecked_Union (Scope (gnat_field
))))
7624 tree t
= purpose_member_field (gnat_to_gnu_field_decl (gnat_field
),
7630 /* If we are just annotating types and the type is tagged, the tag
7631 and the parent components are not generated by the front-end so
7632 we need to add the appropriate offset to each component without
7633 representation clause. */
7634 if (type_annotate_only
7635 && Is_Tagged_Type (gnat_entity
)
7636 && No (Component_Clause (gnat_field
)))
7638 /* For a component appearing in the current extension, the
7639 offset is the size of the parent. */
7640 if (Is_Derived_Type (gnat_entity
)
7641 && Original_Record_Component (gnat_field
) == gnat_field
)
7643 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity
))),
7646 parent_offset
= bitsize_int (POINTER_SIZE
);
7648 if (TYPE_FIELDS (gnu_type
))
7650 = round_up (parent_offset
,
7651 DECL_ALIGN (TYPE_FIELDS (gnu_type
)));
7654 parent_offset
= bitsize_zero_node
;
7656 Set_Component_Bit_Offset
7659 (size_binop (PLUS_EXPR
,
7660 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t
), 0),
7661 TREE_VEC_ELT (TREE_VALUE (t
), 2)),
7664 Set_Esize (gnat_field
,
7665 annotate_value (DECL_SIZE (TREE_PURPOSE (t
))));
7667 else if (Is_Tagged_Type (gnat_entity
) && Is_Derived_Type (gnat_entity
))
7669 /* If there is no entry, this is an inherited component whose
7670 position is the same as in the parent type. */
7671 Set_Component_Bit_Offset
7673 Component_Bit_Offset (Original_Record_Component (gnat_field
)));
7675 Set_Esize (gnat_field
,
7676 Esize (Original_Record_Component (gnat_field
)));
7681 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7682 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7683 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7684 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7685 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7686 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7687 pre-existing list to be chained to the newly created entries. */
7690 build_position_list (tree gnu_type
, bool do_not_flatten_variant
, tree gnu_pos
,
7691 tree gnu_bitpos
, unsigned int offset_align
, tree gnu_list
)
7695 for (gnu_field
= TYPE_FIELDS (gnu_type
);
7697 gnu_field
= DECL_CHAIN (gnu_field
))
7699 tree gnu_our_bitpos
= size_binop (PLUS_EXPR
, gnu_bitpos
,
7700 DECL_FIELD_BIT_OFFSET (gnu_field
));
7701 tree gnu_our_offset
= size_binop (PLUS_EXPR
, gnu_pos
,
7702 DECL_FIELD_OFFSET (gnu_field
));
7703 unsigned int our_offset_align
7704 = MIN (offset_align
, DECL_OFFSET_ALIGN (gnu_field
));
7705 tree v
= make_tree_vec (3);
7707 TREE_VEC_ELT (v
, 0) = gnu_our_offset
;
7708 TREE_VEC_ELT (v
, 1) = size_int (our_offset_align
);
7709 TREE_VEC_ELT (v
, 2) = gnu_our_bitpos
;
7710 gnu_list
= tree_cons (gnu_field
, v
, gnu_list
);
7712 /* Recurse on internal fields, flattening the nested fields except for
7713 those in the variant part, if requested. */
7714 if (DECL_INTERNAL_P (gnu_field
))
7716 tree gnu_field_type
= TREE_TYPE (gnu_field
);
7717 if (do_not_flatten_variant
7718 && TREE_CODE (gnu_field_type
) == QUAL_UNION_TYPE
)
7720 = build_position_list (gnu_field_type
, do_not_flatten_variant
,
7721 size_zero_node
, bitsize_zero_node
,
7722 BIGGEST_ALIGNMENT
, gnu_list
);
7725 = build_position_list (gnu_field_type
, do_not_flatten_variant
,
7726 gnu_our_offset
, gnu_our_bitpos
,
7727 our_offset_align
, gnu_list
);
7734 /* Return a list describing the substitutions needed to reflect the
7735 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7736 be in any order. The values in an element of the list are in the form
7737 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
7738 a definition of GNAT_SUBTYPE. */
7740 static vec
<subst_pair
>
7741 build_subst_list (Entity_Id gnat_subtype
, Entity_Id gnat_type
, bool definition
)
7743 vec
<subst_pair
> gnu_list
= vNULL
;
7744 Entity_Id gnat_discrim
;
7745 Node_Id gnat_constr
;
7747 for (gnat_discrim
= First_Stored_Discriminant (gnat_type
),
7748 gnat_constr
= First_Elmt (Stored_Constraint (gnat_subtype
));
7749 Present (gnat_discrim
);
7750 gnat_discrim
= Next_Stored_Discriminant (gnat_discrim
),
7751 gnat_constr
= Next_Elmt (gnat_constr
))
7752 /* Ignore access discriminants. */
7753 if (!Is_Access_Type (Etype (Node (gnat_constr
))))
7755 tree gnu_field
= gnat_to_gnu_field_decl (gnat_discrim
);
7756 tree replacement
= convert (TREE_TYPE (gnu_field
),
7757 elaborate_expression
7758 (Node (gnat_constr
), gnat_subtype
,
7759 get_entity_name (gnat_discrim
),
7760 definition
, true, false));
7761 subst_pair s
= {gnu_field
, replacement
};
7762 gnu_list
.safe_push (s
);
7768 /* Scan all fields in QUAL_UNION_TYPE and return a list describing the
7769 variants of QUAL_UNION_TYPE that are still relevant after applying
7770 the substitutions described in SUBST_LIST. GNU_LIST is a pre-existing
7771 list to be prepended to the newly created entries. */
7773 static vec
<variant_desc
>
7774 build_variant_list (tree qual_union_type
, vec
<subst_pair
> subst_list
,
7775 vec
<variant_desc
> gnu_list
)
7779 for (gnu_field
= TYPE_FIELDS (qual_union_type
);
7781 gnu_field
= DECL_CHAIN (gnu_field
))
7783 tree qual
= DECL_QUALIFIER (gnu_field
);
7787 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
7788 qual
= SUBSTITUTE_IN_EXPR (qual
, s
->discriminant
, s
->replacement
);
7790 /* If the new qualifier is not unconditionally false, its variant may
7791 still be accessed. */
7792 if (!integer_zerop (qual
))
7794 tree variant_type
= TREE_TYPE (gnu_field
), variant_subpart
;
7795 variant_desc v
= {variant_type
, gnu_field
, qual
, NULL_TREE
};
7797 gnu_list
.safe_push (v
);
7799 /* Recurse on the variant subpart of the variant, if any. */
7800 variant_subpart
= get_variant_part (variant_type
);
7801 if (variant_subpart
)
7802 gnu_list
= build_variant_list (TREE_TYPE (variant_subpart
),
7803 subst_list
, gnu_list
);
7805 /* If the new qualifier is unconditionally true, the subsequent
7806 variants cannot be accessed. */
7807 if (integer_onep (qual
))
7815 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7816 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
7817 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
7818 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
7819 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
7820 true if we are being called to process the Component_Size of GNAT_OBJECT;
7821 this is used only for error messages. ZERO_OK is true if a size of zero
7822 is permitted; if ZERO_OK is false, it means that a size of zero should be
7823 treated as an unspecified size. */
7826 validate_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_object
,
7827 enum tree_code kind
, bool component_p
, bool zero_ok
)
7829 Node_Id gnat_error_node
;
7830 tree type_size
, size
;
7832 /* Return 0 if no size was specified. */
7833 if (uint_size
== No_Uint
)
7836 /* Ignore a negative size since that corresponds to our back-annotation. */
7837 if (UI_Lt (uint_size
, Uint_0
))
7840 /* Find the node to use for error messages. */
7841 if ((Ekind (gnat_object
) == E_Component
7842 || Ekind (gnat_object
) == E_Discriminant
)
7843 && Present (Component_Clause (gnat_object
)))
7844 gnat_error_node
= Last_Bit (Component_Clause (gnat_object
));
7845 else if (Present (Size_Clause (gnat_object
)))
7846 gnat_error_node
= Expression (Size_Clause (gnat_object
));
7848 gnat_error_node
= gnat_object
;
7850 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7851 but cannot be represented in bitsizetype. */
7852 size
= UI_To_gnu (uint_size
, bitsizetype
);
7853 if (TREE_OVERFLOW (size
))
7856 post_error_ne ("component size for& is too large", gnat_error_node
,
7859 post_error_ne ("size for& is too large", gnat_error_node
,
7864 /* Ignore a zero size if it is not permitted. */
7865 if (!zero_ok
&& integer_zerop (size
))
7868 /* The size of objects is always a multiple of a byte. */
7869 if (kind
== VAR_DECL
7870 && !integer_zerop (size_binop (TRUNC_MOD_EXPR
, size
, bitsize_unit_node
)))
7873 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7874 gnat_error_node
, gnat_object
);
7876 post_error_ne ("size for& is not a multiple of Storage_Unit",
7877 gnat_error_node
, gnat_object
);
7881 /* If this is an integral type or a packed array type, the front-end has
7882 already verified the size, so we need not do it here (which would mean
7883 checking against the bounds). However, if this is an aliased object,
7884 it may not be smaller than the type of the object. */
7885 if ((INTEGRAL_TYPE_P (gnu_type
) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type
))
7886 && !(kind
== VAR_DECL
&& Is_Aliased (gnat_object
)))
7889 /* If the object is a record that contains a template, add the size of the
7890 template to the specified size. */
7891 if (TREE_CODE (gnu_type
) == RECORD_TYPE
7892 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7893 size
= size_binop (PLUS_EXPR
, DECL_SIZE (TYPE_FIELDS (gnu_type
)), size
);
7895 if (kind
== VAR_DECL
7896 /* If a type needs strict alignment, a component of this type in
7897 a packed record cannot be packed and thus uses the type size. */
7898 || (kind
== TYPE_DECL
&& Strict_Alignment (gnat_object
)))
7899 type_size
= TYPE_SIZE (gnu_type
);
7901 type_size
= rm_size (gnu_type
);
7903 /* Modify the size of a discriminated type to be the maximum size. */
7904 if (type_size
&& CONTAINS_PLACEHOLDER_P (type_size
))
7905 type_size
= max_size (type_size
, true);
7907 /* If this is an access type or a fat pointer, the minimum size is that given
7908 by the smallest integral mode that's valid for pointers. */
7909 if (TREE_CODE (gnu_type
) == POINTER_TYPE
|| TYPE_IS_FAT_POINTER_P (gnu_type
))
7911 enum machine_mode p_mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
7912 while (!targetm
.valid_pointer_mode (p_mode
))
7913 p_mode
= GET_MODE_WIDER_MODE (p_mode
);
7914 type_size
= bitsize_int (GET_MODE_BITSIZE (p_mode
));
7917 /* Issue an error either if the default size of the object isn't a constant
7918 or if the new size is smaller than it. */
7919 if (TREE_CODE (type_size
) != INTEGER_CST
7920 || TREE_OVERFLOW (type_size
)
7921 || tree_int_cst_lt (size
, type_size
))
7925 ("component size for& too small{, minimum allowed is ^}",
7926 gnat_error_node
, gnat_object
, type_size
);
7929 ("size for& too small{, minimum allowed is ^}",
7930 gnat_error_node
, gnat_object
, type_size
);
7937 /* Similarly, but both validate and process a value of RM size. This routine
7938 is only called for types. */
7941 set_rm_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_entity
)
7943 Node_Id gnat_attr_node
;
7944 tree old_size
, size
;
7946 /* Do nothing if no size was specified. */
7947 if (uint_size
== No_Uint
)
7950 /* Ignore a negative size since that corresponds to our back-annotation. */
7951 if (UI_Lt (uint_size
, Uint_0
))
7954 /* Only issue an error if a Value_Size clause was explicitly given.
7955 Otherwise, we'd be duplicating an error on the Size clause. */
7957 = Get_Attribute_Definition_Clause (gnat_entity
, Attr_Value_Size
);
7959 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7960 but cannot be represented in bitsizetype. */
7961 size
= UI_To_gnu (uint_size
, bitsizetype
);
7962 if (TREE_OVERFLOW (size
))
7964 if (Present (gnat_attr_node
))
7965 post_error_ne ("Value_Size for& is too large", gnat_attr_node
,
7970 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
7971 exists, or this is an integer type, in which case the front-end will
7972 have always set it. */
7973 if (No (gnat_attr_node
)
7974 && integer_zerop (size
)
7975 && !Has_Size_Clause (gnat_entity
)
7976 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
7979 old_size
= rm_size (gnu_type
);
7981 /* If the old size is self-referential, get the maximum size. */
7982 if (CONTAINS_PLACEHOLDER_P (old_size
))
7983 old_size
= max_size (old_size
, true);
7985 /* Issue an error either if the old size of the object isn't a constant or
7986 if the new size is smaller than it. The front-end has already verified
7987 this for scalar and packed array types. */
7988 if (TREE_CODE (old_size
) != INTEGER_CST
7989 || TREE_OVERFLOW (old_size
)
7990 || (AGGREGATE_TYPE_P (gnu_type
)
7991 && !(TREE_CODE (gnu_type
) == ARRAY_TYPE
7992 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type
))
7993 && !(TYPE_IS_PADDING_P (gnu_type
)
7994 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
))) == ARRAY_TYPE
7995 && TYPE_PACKED_ARRAY_TYPE_P
7996 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))
7997 && tree_int_cst_lt (size
, old_size
)))
7999 if (Present (gnat_attr_node
))
8001 ("Value_Size for& too small{, minimum allowed is ^}",
8002 gnat_attr_node
, gnat_entity
, old_size
);
8006 /* Otherwise, set the RM size proper for integral types... */
8007 if ((TREE_CODE (gnu_type
) == INTEGER_TYPE
8008 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
8009 || (TREE_CODE (gnu_type
) == ENUMERAL_TYPE
8010 || TREE_CODE (gnu_type
) == BOOLEAN_TYPE
))
8011 SET_TYPE_RM_SIZE (gnu_type
, size
);
8013 /* ...or the Ada size for record and union types. */
8014 else if (RECORD_OR_UNION_TYPE_P (gnu_type
)
8015 && !TYPE_FAT_POINTER_P (gnu_type
))
8016 SET_TYPE_ADA_SIZE (gnu_type
, size
);
8019 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8020 a type or object whose present alignment is ALIGN. If this alignment is
8021 valid, return it. Otherwise, give an error and return ALIGN. */
8024 validate_alignment (Uint alignment
, Entity_Id gnat_entity
, unsigned int align
)
8026 unsigned int max_allowed_alignment
= get_target_maximum_allowed_alignment ();
8027 unsigned int new_align
;
8028 Node_Id gnat_error_node
;
8030 /* Don't worry about checking alignment if alignment was not specified
8031 by the source program and we already posted an error for this entity. */
8032 if (Error_Posted (gnat_entity
) && !Has_Alignment_Clause (gnat_entity
))
8035 /* Post the error on the alignment clause if any. Note, for the implicit
8036 base type of an array type, the alignment clause is on the first
8038 if (Present (Alignment_Clause (gnat_entity
)))
8039 gnat_error_node
= Expression (Alignment_Clause (gnat_entity
));
8041 else if (Is_Itype (gnat_entity
)
8042 && Is_Array_Type (gnat_entity
)
8043 && Etype (gnat_entity
) == gnat_entity
8044 && Present (Alignment_Clause (First_Subtype (gnat_entity
))))
8046 Expression (Alignment_Clause (First_Subtype (gnat_entity
)));
8049 gnat_error_node
= gnat_entity
;
8051 /* Within GCC, an alignment is an integer, so we must make sure a value is
8052 specified that fits in that range. Also, there is an upper bound to
8053 alignments we can support/allow. */
8054 if (!UI_Is_In_Int_Range (alignment
)
8055 || ((new_align
= UI_To_Int (alignment
)) > max_allowed_alignment
))
8056 post_error_ne_num ("largest supported alignment for& is ^",
8057 gnat_error_node
, gnat_entity
, max_allowed_alignment
);
8058 else if (!(Present (Alignment_Clause (gnat_entity
))
8059 && From_At_Mod (Alignment_Clause (gnat_entity
)))
8060 && new_align
* BITS_PER_UNIT
< align
)
8062 unsigned int double_align
;
8063 bool is_capped_double
, align_clause
;
8065 /* If the default alignment of "double" or larger scalar types is
8066 specifically capped and the new alignment is above the cap, do
8067 not post an error and change the alignment only if there is an
8068 alignment clause; this makes it possible to have the associated
8069 GCC type overaligned by default for performance reasons. */
8070 if ((double_align
= double_float_alignment
) > 0)
8073 = Is_Type (gnat_entity
) ? gnat_entity
: Etype (gnat_entity
);
8075 = is_double_float_or_array (gnat_type
, &align_clause
);
8077 else if ((double_align
= double_scalar_alignment
) > 0)
8080 = Is_Type (gnat_entity
) ? gnat_entity
: Etype (gnat_entity
);
8082 = is_double_scalar_or_array (gnat_type
, &align_clause
);
8085 is_capped_double
= align_clause
= false;
8087 if (is_capped_double
&& new_align
>= double_align
)
8090 align
= new_align
* BITS_PER_UNIT
;
8094 if (is_capped_double
)
8095 align
= double_align
* BITS_PER_UNIT
;
8097 post_error_ne_num ("alignment for& must be at least ^",
8098 gnat_error_node
, gnat_entity
,
8099 align
/ BITS_PER_UNIT
);
8104 new_align
= (new_align
> 0 ? new_align
* BITS_PER_UNIT
: 1);
8105 if (new_align
> align
)
8112 /* Verify that OBJECT, a type or decl, is something we can implement
8113 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
8114 if we require atomic components. */
8117 check_ok_for_atomic (tree object
, Entity_Id gnat_entity
, bool comp_p
)
8119 Node_Id gnat_error_point
= gnat_entity
;
8121 enum machine_mode mode
;
8125 /* There are three case of what OBJECT can be. It can be a type, in which
8126 case we take the size, alignment and mode from the type. It can be a
8127 declaration that was indirect, in which case the relevant values are
8128 that of the type being pointed to, or it can be a normal declaration,
8129 in which case the values are of the decl. The code below assumes that
8130 OBJECT is either a type or a decl. */
8131 if (TYPE_P (object
))
8133 /* If this is an anonymous base type, nothing to check. Error will be
8134 reported on the source type. */
8135 if (!Comes_From_Source (gnat_entity
))
8138 mode
= TYPE_MODE (object
);
8139 align
= TYPE_ALIGN (object
);
8140 size
= TYPE_SIZE (object
);
8142 else if (DECL_BY_REF_P (object
))
8144 mode
= TYPE_MODE (TREE_TYPE (TREE_TYPE (object
)));
8145 align
= TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object
)));
8146 size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (object
)));
8150 mode
= DECL_MODE (object
);
8151 align
= DECL_ALIGN (object
);
8152 size
= DECL_SIZE (object
);
8155 /* Consider all floating-point types atomic and any types that that are
8156 represented by integers no wider than a machine word. */
8157 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
8158 || ((GET_MODE_CLASS (mode
) == MODE_INT
8159 || GET_MODE_CLASS (mode
) == MODE_PARTIAL_INT
)
8160 && GET_MODE_BITSIZE (mode
) <= BITS_PER_WORD
))
8163 /* For the moment, also allow anything that has an alignment equal
8164 to its size and which is smaller than a word. */
8165 if (size
&& TREE_CODE (size
) == INTEGER_CST
8166 && compare_tree_int (size
, align
) == 0
8167 && align
<= BITS_PER_WORD
)
8170 for (gnat_node
= First_Rep_Item (gnat_entity
); Present (gnat_node
);
8171 gnat_node
= Next_Rep_Item (gnat_node
))
8173 if (!comp_p
&& Nkind (gnat_node
) == N_Pragma
8174 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
8176 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
8177 else if (comp_p
&& Nkind (gnat_node
) == N_Pragma
8178 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
8179 == Pragma_Atomic_Components
))
8180 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
8184 post_error_ne ("atomic access to component of & cannot be guaranteed",
8185 gnat_error_point
, gnat_entity
);
8187 post_error_ne ("atomic access to & cannot be guaranteed",
8188 gnat_error_point
, gnat_entity
);
8192 /* Helper for the intrin compatibility checks family. Evaluate whether
8193 two types are definitely incompatible. */
8196 intrin_types_incompatible_p (tree t1
, tree t2
)
8198 enum tree_code code
;
8200 if (TYPE_MAIN_VARIANT (t1
) == TYPE_MAIN_VARIANT (t2
))
8203 if (TYPE_MODE (t1
) != TYPE_MODE (t2
))
8206 if (TREE_CODE (t1
) != TREE_CODE (t2
))
8209 code
= TREE_CODE (t1
);
8215 return TYPE_PRECISION (t1
) != TYPE_PRECISION (t2
);
8218 case REFERENCE_TYPE
:
8219 /* Assume designated types are ok. We'd need to account for char * and
8220 void * variants to do better, which could rapidly get messy and isn't
8221 clearly worth the effort. */
8231 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8232 on the Ada/builtin argument lists for the INB binding. */
8235 intrin_arglists_compatible_p (intrin_binding_t
* inb
)
8237 function_args_iterator ada_iter
, btin_iter
;
8239 function_args_iter_init (&ada_iter
, inb
->ada_fntype
);
8240 function_args_iter_init (&btin_iter
, inb
->btin_fntype
);
8242 /* Sequence position of the last argument we checked. */
8247 tree ada_type
= function_args_iter_cond (&ada_iter
);
8248 tree btin_type
= function_args_iter_cond (&btin_iter
);
8250 /* If we've exhausted both lists simultaneously, we're done. */
8251 if (ada_type
== NULL_TREE
&& btin_type
== NULL_TREE
)
8254 /* If one list is shorter than the other, they fail to match. */
8255 if (ada_type
== NULL_TREE
|| btin_type
== NULL_TREE
)
8258 /* If we're done with the Ada args and not with the internal builtin
8259 args, or the other way around, complain. */
8260 if (ada_type
== void_type_node
8261 && btin_type
!= void_type_node
)
8263 post_error ("?Ada arguments list too short!", inb
->gnat_entity
);
8267 if (btin_type
== void_type_node
8268 && ada_type
!= void_type_node
)
8270 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8271 inb
->gnat_entity
, inb
->gnat_entity
, argpos
);
8275 /* Otherwise, check that types match for the current argument. */
8277 if (intrin_types_incompatible_p (ada_type
, btin_type
))
8279 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8280 inb
->gnat_entity
, inb
->gnat_entity
, argpos
);
8285 function_args_iter_next (&ada_iter
);
8286 function_args_iter_next (&btin_iter
);
8292 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8293 on the Ada/builtin return values for the INB binding. */
8296 intrin_return_compatible_p (intrin_binding_t
* inb
)
8298 tree ada_return_type
= TREE_TYPE (inb
->ada_fntype
);
8299 tree btin_return_type
= TREE_TYPE (inb
->btin_fntype
);
8301 /* Accept function imported as procedure, common and convenient. */
8302 if (VOID_TYPE_P (ada_return_type
)
8303 && !VOID_TYPE_P (btin_return_type
))
8306 /* If return type is Address (integer type), map it to void *. */
8307 if (Is_Descendent_Of_Address (Etype (inb
->gnat_entity
)))
8308 ada_return_type
= ptr_void_type_node
;
8310 /* Check return types compatibility otherwise. Note that this
8311 handles void/void as well. */
8312 if (intrin_types_incompatible_p (btin_return_type
, ada_return_type
))
8314 post_error ("?intrinsic binding type mismatch on return value!",
8322 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8323 compatible. Issue relevant warnings when they are not.
8325 This is intended as a light check to diagnose the most obvious cases, not
8326 as a full fledged type compatibility predicate. It is the programmer's
8327 responsibility to ensure correctness of the Ada declarations in Imports,
8328 especially when binding straight to a compiler internal. */
8331 intrin_profiles_compatible_p (intrin_binding_t
* inb
)
8333 /* Check compatibility on return values and argument lists, each responsible
8334 for posting warnings as appropriate. Ensure use of the proper sloc for
8337 bool arglists_compatible_p
, return_compatible_p
;
8338 location_t saved_location
= input_location
;
8340 Sloc_to_locus (Sloc (inb
->gnat_entity
), &input_location
);
8342 return_compatible_p
= intrin_return_compatible_p (inb
);
8343 arglists_compatible_p
= intrin_arglists_compatible_p (inb
);
8345 input_location
= saved_location
;
8347 return return_compatible_p
&& arglists_compatible_p
;
8350 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
8351 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
8352 specified size for this field. POS_LIST is a position list describing
8353 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
8357 create_field_decl_from (tree old_field
, tree field_type
, tree record_type
,
8358 tree size
, tree pos_list
,
8359 vec
<subst_pair
> subst_list
)
8361 tree t
= TREE_VALUE (purpose_member (old_field
, pos_list
));
8362 tree pos
= TREE_VEC_ELT (t
, 0), bitpos
= TREE_VEC_ELT (t
, 2);
8363 unsigned int offset_align
= tree_to_uhwi (TREE_VEC_ELT (t
, 1));
8364 tree new_pos
, new_field
;
8368 if (CONTAINS_PLACEHOLDER_P (pos
))
8369 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
8370 pos
= SUBSTITUTE_IN_EXPR (pos
, s
->discriminant
, s
->replacement
);
8372 /* If the position is now a constant, we can set it as the position of the
8373 field when we make it. Otherwise, we need to deal with it specially. */
8374 if (TREE_CONSTANT (pos
))
8375 new_pos
= bit_from_pos (pos
, bitpos
);
8377 new_pos
= NULL_TREE
;
8380 = create_field_decl (DECL_NAME (old_field
), field_type
, record_type
,
8381 size
, new_pos
, DECL_PACKED (old_field
),
8382 !DECL_NONADDRESSABLE_P (old_field
));
8386 normalize_offset (&pos
, &bitpos
, offset_align
);
8387 DECL_FIELD_OFFSET (new_field
) = pos
;
8388 DECL_FIELD_BIT_OFFSET (new_field
) = bitpos
;
8389 SET_DECL_OFFSET_ALIGN (new_field
, offset_align
);
8390 DECL_SIZE (new_field
) = size
;
8391 DECL_SIZE_UNIT (new_field
)
8392 = convert (sizetype
,
8393 size_binop (CEIL_DIV_EXPR
, size
, bitsize_unit_node
));
8394 layout_decl (new_field
, DECL_OFFSET_ALIGN (new_field
));
8397 DECL_INTERNAL_P (new_field
) = DECL_INTERNAL_P (old_field
);
8398 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field
, old_field
);
8399 DECL_DISCRIMINANT_NUMBER (new_field
) = DECL_DISCRIMINANT_NUMBER (old_field
);
8400 TREE_THIS_VOLATILE (new_field
) = TREE_THIS_VOLATILE (old_field
);
8405 /* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
8406 it is the minimal size the REP_PART must have. */
8409 create_rep_part (tree rep_type
, tree record_type
, tree min_size
)
8413 if (min_size
&& !tree_int_cst_lt (TYPE_SIZE (rep_type
), min_size
))
8414 min_size
= NULL_TREE
;
8416 field
= create_field_decl (get_identifier ("REP"), rep_type
, record_type
,
8417 min_size
, NULL_TREE
, 0, 1);
8418 DECL_INTERNAL_P (field
) = 1;
8423 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8426 get_rep_part (tree record_type
)
8428 tree field
= TYPE_FIELDS (record_type
);
8430 /* The REP part is the first field, internal, another record, and its name
8431 starts with an 'R'. */
8433 && DECL_INTERNAL_P (field
)
8434 && TREE_CODE (TREE_TYPE (field
)) == RECORD_TYPE
8435 && IDENTIFIER_POINTER (DECL_NAME (field
)) [0] == 'R')
8441 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8444 get_variant_part (tree record_type
)
8448 /* The variant part is the only internal field that is a qualified union. */
8449 for (field
= TYPE_FIELDS (record_type
); field
; field
= DECL_CHAIN (field
))
8450 if (DECL_INTERNAL_P (field
)
8451 && TREE_CODE (TREE_TYPE (field
)) == QUAL_UNION_TYPE
)
8457 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8458 the list of variants to be used and RECORD_TYPE is the type of the parent.
8459 POS_LIST is a position list describing the layout of fields present in
8460 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8464 create_variant_part_from (tree old_variant_part
,
8465 vec
<variant_desc
> variant_list
,
8466 tree record_type
, tree pos_list
,
8467 vec
<subst_pair
> subst_list
)
8469 tree offset
= DECL_FIELD_OFFSET (old_variant_part
);
8470 tree old_union_type
= TREE_TYPE (old_variant_part
);
8471 tree new_union_type
, new_variant_part
;
8472 tree union_field_list
= NULL_TREE
;
8476 /* First create the type of the variant part from that of the old one. */
8477 new_union_type
= make_node (QUAL_UNION_TYPE
);
8478 TYPE_NAME (new_union_type
)
8479 = concat_name (TYPE_NAME (record_type
),
8480 IDENTIFIER_POINTER (DECL_NAME (old_variant_part
)));
8482 /* If the position of the variant part is constant, subtract it from the
8483 size of the type of the parent to get the new size. This manual CSE
8484 reduces the code size when not optimizing. */
8485 if (TREE_CODE (offset
) == INTEGER_CST
)
8487 tree bitpos
= DECL_FIELD_BIT_OFFSET (old_variant_part
);
8488 tree first_bit
= bit_from_pos (offset
, bitpos
);
8489 TYPE_SIZE (new_union_type
)
8490 = size_binop (MINUS_EXPR
, TYPE_SIZE (record_type
), first_bit
);
8491 TYPE_SIZE_UNIT (new_union_type
)
8492 = size_binop (MINUS_EXPR
, TYPE_SIZE_UNIT (record_type
),
8493 byte_from_pos (offset
, bitpos
));
8494 SET_TYPE_ADA_SIZE (new_union_type
,
8495 size_binop (MINUS_EXPR
, TYPE_ADA_SIZE (record_type
),
8497 TYPE_ALIGN (new_union_type
) = TYPE_ALIGN (old_union_type
);
8498 relate_alias_sets (new_union_type
, old_union_type
, ALIAS_SET_COPY
);
8501 copy_and_substitute_in_size (new_union_type
, old_union_type
, subst_list
);
8503 /* Now finish up the new variants and populate the union type. */
8504 FOR_EACH_VEC_ELT_REVERSE (variant_list
, i
, v
)
8506 tree old_field
= v
->field
, new_field
;
8507 tree old_variant
, old_variant_subpart
, new_variant
, field_list
;
8509 /* Skip variants that don't belong to this nesting level. */
8510 if (DECL_CONTEXT (old_field
) != old_union_type
)
8513 /* Retrieve the list of fields already added to the new variant. */
8514 new_variant
= v
->new_type
;
8515 field_list
= TYPE_FIELDS (new_variant
);
8517 /* If the old variant had a variant subpart, we need to create a new
8518 variant subpart and add it to the field list. */
8519 old_variant
= v
->type
;
8520 old_variant_subpart
= get_variant_part (old_variant
);
8521 if (old_variant_subpart
)
8523 tree new_variant_subpart
8524 = create_variant_part_from (old_variant_subpart
, variant_list
,
8525 new_variant
, pos_list
, subst_list
);
8526 DECL_CHAIN (new_variant_subpart
) = field_list
;
8527 field_list
= new_variant_subpart
;
8530 /* Finish up the new variant and create the field. No need for debug
8531 info thanks to the XVS type. */
8532 finish_record_type (new_variant
, nreverse (field_list
), 2, false);
8533 compute_record_mode (new_variant
);
8534 create_type_decl (TYPE_NAME (new_variant
), new_variant
, true, false,
8538 = create_field_decl_from (old_field
, new_variant
, new_union_type
,
8539 TYPE_SIZE (new_variant
),
8540 pos_list
, subst_list
);
8541 DECL_QUALIFIER (new_field
) = v
->qual
;
8542 DECL_INTERNAL_P (new_field
) = 1;
8543 DECL_CHAIN (new_field
) = union_field_list
;
8544 union_field_list
= new_field
;
8547 /* Finish up the union type and create the variant part. No need for debug
8548 info thanks to the XVS type. Note that we don't reverse the field list
8549 because VARIANT_LIST has been traversed in reverse order. */
8550 finish_record_type (new_union_type
, union_field_list
, 2, false);
8551 compute_record_mode (new_union_type
);
8552 create_type_decl (TYPE_NAME (new_union_type
), new_union_type
, true, false,
8556 = create_field_decl_from (old_variant_part
, new_union_type
, record_type
,
8557 TYPE_SIZE (new_union_type
),
8558 pos_list
, subst_list
);
8559 DECL_INTERNAL_P (new_variant_part
) = 1;
8561 /* With multiple discriminants it is possible for an inner variant to be
8562 statically selected while outer ones are not; in this case, the list
8563 of fields of the inner variant is not flattened and we end up with a
8564 qualified union with a single member. Drop the useless container. */
8565 if (!DECL_CHAIN (union_field_list
))
8567 DECL_CONTEXT (union_field_list
) = record_type
;
8568 DECL_FIELD_OFFSET (union_field_list
)
8569 = DECL_FIELD_OFFSET (new_variant_part
);
8570 DECL_FIELD_BIT_OFFSET (union_field_list
)
8571 = DECL_FIELD_BIT_OFFSET (new_variant_part
);
8572 SET_DECL_OFFSET_ALIGN (union_field_list
,
8573 DECL_OFFSET_ALIGN (new_variant_part
));
8574 new_variant_part
= union_field_list
;
8577 return new_variant_part
;
8580 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8581 which are both RECORD_TYPE, after applying the substitutions described
8585 copy_and_substitute_in_size (tree new_type
, tree old_type
,
8586 vec
<subst_pair
> subst_list
)
8591 TYPE_SIZE (new_type
) = TYPE_SIZE (old_type
);
8592 TYPE_SIZE_UNIT (new_type
) = TYPE_SIZE_UNIT (old_type
);
8593 SET_TYPE_ADA_SIZE (new_type
, TYPE_ADA_SIZE (old_type
));
8594 TYPE_ALIGN (new_type
) = TYPE_ALIGN (old_type
);
8595 relate_alias_sets (new_type
, old_type
, ALIAS_SET_COPY
);
8597 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type
)))
8598 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
8599 TYPE_SIZE (new_type
)
8600 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type
),
8601 s
->discriminant
, s
->replacement
);
8603 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type
)))
8604 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
8605 TYPE_SIZE_UNIT (new_type
)
8606 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type
),
8607 s
->discriminant
, s
->replacement
);
8609 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type
)))
8610 FOR_EACH_VEC_ELT (subst_list
, i
, s
)
8612 (new_type
, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type
),
8613 s
->discriminant
, s
->replacement
));
8615 /* Finalize the size. */
8616 TYPE_SIZE (new_type
) = variable_size (TYPE_SIZE (new_type
));
8617 TYPE_SIZE_UNIT (new_type
) = variable_size (TYPE_SIZE_UNIT (new_type
));
8620 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8621 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8622 updated by replacing F with R.
8624 The function doesn't update the layout of the type, i.e. it assumes
8625 that the substitution is purely formal. That's why the replacement
8626 value R must itself contain a PLACEHOLDER_EXPR. */
8629 substitute_in_type (tree t
, tree f
, tree r
)
8633 gcc_assert (CONTAINS_PLACEHOLDER_P (r
));
8635 switch (TREE_CODE (t
))
8642 /* First the domain types of arrays. */
8643 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t
))
8644 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t
)))
8646 tree low
= SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t
), f
, r
);
8647 tree high
= SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t
), f
, r
);
8649 if (low
== TYPE_GCC_MIN_VALUE (t
) && high
== TYPE_GCC_MAX_VALUE (t
))
8653 TYPE_GCC_MIN_VALUE (nt
) = low
;
8654 TYPE_GCC_MAX_VALUE (nt
) = high
;
8656 if (TREE_CODE (t
) == INTEGER_TYPE
&& TYPE_INDEX_TYPE (t
))
8658 (nt
, substitute_in_type (TYPE_INDEX_TYPE (t
), f
, r
));
8663 /* Then the subtypes. */
8664 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t
))
8665 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t
)))
8667 tree low
= SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t
), f
, r
);
8668 tree high
= SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t
), f
, r
);
8670 if (low
== TYPE_RM_MIN_VALUE (t
) && high
== TYPE_RM_MAX_VALUE (t
))
8674 SET_TYPE_RM_MIN_VALUE (nt
, low
);
8675 SET_TYPE_RM_MAX_VALUE (nt
, high
);
8683 nt
= substitute_in_type (TREE_TYPE (t
), f
, r
);
8684 if (nt
== TREE_TYPE (t
))
8687 return build_complex_type (nt
);
8690 /* These should never show up here. */
8695 tree component
= substitute_in_type (TREE_TYPE (t
), f
, r
);
8696 tree domain
= substitute_in_type (TYPE_DOMAIN (t
), f
, r
);
8698 if (component
== TREE_TYPE (t
) && domain
== TYPE_DOMAIN (t
))
8701 nt
= build_nonshared_array_type (component
, domain
);
8702 TYPE_ALIGN (nt
) = TYPE_ALIGN (t
);
8703 TYPE_USER_ALIGN (nt
) = TYPE_USER_ALIGN (t
);
8704 SET_TYPE_MODE (nt
, TYPE_MODE (t
));
8705 TYPE_SIZE (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t
), f
, r
);
8706 TYPE_SIZE_UNIT (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t
), f
, r
);
8707 TYPE_NONALIASED_COMPONENT (nt
) = TYPE_NONALIASED_COMPONENT (t
);
8708 TYPE_MULTI_ARRAY_P (nt
) = TYPE_MULTI_ARRAY_P (t
);
8709 TYPE_CONVENTION_FORTRAN_P (nt
) = TYPE_CONVENTION_FORTRAN_P (t
);
8715 case QUAL_UNION_TYPE
:
8717 bool changed_field
= false;
8720 /* Start out with no fields, make new fields, and chain them
8721 in. If we haven't actually changed the type of any field,
8722 discard everything we've done and return the old type. */
8724 TYPE_FIELDS (nt
) = NULL_TREE
;
8726 for (field
= TYPE_FIELDS (t
); field
; field
= DECL_CHAIN (field
))
8728 tree new_field
= copy_node (field
), new_n
;
8730 new_n
= substitute_in_type (TREE_TYPE (field
), f
, r
);
8731 if (new_n
!= TREE_TYPE (field
))
8733 TREE_TYPE (new_field
) = new_n
;
8734 changed_field
= true;
8737 new_n
= SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field
), f
, r
);
8738 if (new_n
!= DECL_FIELD_OFFSET (field
))
8740 DECL_FIELD_OFFSET (new_field
) = new_n
;
8741 changed_field
= true;
8744 /* Do the substitution inside the qualifier, if any. */
8745 if (TREE_CODE (t
) == QUAL_UNION_TYPE
)
8747 new_n
= SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field
), f
, r
);
8748 if (new_n
!= DECL_QUALIFIER (field
))
8750 DECL_QUALIFIER (new_field
) = new_n
;
8751 changed_field
= true;
8755 DECL_CONTEXT (new_field
) = nt
;
8756 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field
, field
);
8758 DECL_CHAIN (new_field
) = TYPE_FIELDS (nt
);
8759 TYPE_FIELDS (nt
) = new_field
;
8765 TYPE_FIELDS (nt
) = nreverse (TYPE_FIELDS (nt
));
8766 TYPE_SIZE (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t
), f
, r
);
8767 TYPE_SIZE_UNIT (nt
) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t
), f
, r
);
8768 SET_TYPE_ADA_SIZE (nt
, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t
), f
, r
));
8777 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8778 needed to represent the object. */
8781 rm_size (tree gnu_type
)
8783 /* For integral types, we store the RM size explicitly. */
8784 if (INTEGRAL_TYPE_P (gnu_type
) && TYPE_RM_SIZE (gnu_type
))
8785 return TYPE_RM_SIZE (gnu_type
);
8787 /* Return the RM size of the actual data plus the size of the template. */
8788 if (TREE_CODE (gnu_type
) == RECORD_TYPE
8789 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
8791 size_binop (PLUS_EXPR
,
8792 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type
)))),
8793 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
8795 /* For record or union types, we store the size explicitly. */
8796 if (RECORD_OR_UNION_TYPE_P (gnu_type
)
8797 && !TYPE_FAT_POINTER_P (gnu_type
)
8798 && TYPE_ADA_SIZE (gnu_type
))
8799 return TYPE_ADA_SIZE (gnu_type
);
8801 /* For other types, this is just the size. */
8802 return TYPE_SIZE (gnu_type
);
8805 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8806 fully-qualified name, possibly with type information encoding.
8807 Otherwise, return the name. */
8810 get_entity_name (Entity_Id gnat_entity
)
8812 Get_Encoded_Name (gnat_entity
);
8813 return get_identifier_with_length (Name_Buffer
, Name_Len
);
8816 /* Return an identifier representing the external name to be used for
8817 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8818 and the specified suffix. */
8821 create_concat_name (Entity_Id gnat_entity
, const char *suffix
)
8823 Entity_Kind kind
= Ekind (gnat_entity
);
8827 String_Template temp
= {1, (int) strlen (suffix
)};
8828 Fat_Pointer fp
= {suffix
, &temp
};
8829 Get_External_Name_With_Suffix (gnat_entity
, fp
);
8832 Get_External_Name (gnat_entity
, 0);
8834 /* A variable using the Stdcall convention lives in a DLL. We adjust
8835 its name to use the jump table, the _imp__NAME contains the address
8836 for the NAME variable. */
8837 if ((kind
== E_Variable
|| kind
== E_Constant
)
8838 && Has_Stdcall_Convention (gnat_entity
))
8840 const int len
= 6 + Name_Len
;
8841 char *new_name
= (char *) alloca (len
+ 1);
8842 strcpy (new_name
, "_imp__");
8843 strcat (new_name
, Name_Buffer
);
8844 return get_identifier_with_length (new_name
, len
);
8847 return get_identifier_with_length (Name_Buffer
, Name_Len
);
8850 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8851 string, return a new IDENTIFIER_NODE that is the concatenation of
8852 the name followed by "___" and the specified suffix. */
8855 concat_name (tree gnu_name
, const char *suffix
)
8857 const int len
= IDENTIFIER_LENGTH (gnu_name
) + 3 + strlen (suffix
);
8858 char *new_name
= (char *) alloca (len
+ 1);
8859 strcpy (new_name
, IDENTIFIER_POINTER (gnu_name
));
8860 strcat (new_name
, "___");
8861 strcat (new_name
, suffix
);
8862 return get_identifier_with_length (new_name
, len
);
8865 #include "gt-ada-decl.h"