1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2008, 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"
56 /* Convention_Stdcall should be processed in a specific way on Windows targets
57 only. The macro below is a helper to avoid having to check for a Windows
58 specific attribute throughout this unit. */
60 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
61 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
63 #define Has_Stdcall_Convention(E) (0)
68 struct incomplete
*next
;
73 /* These variables are used to defer recursively expanding incomplete types
74 while we are processing an array, a record or a subprogram type. */
75 static int defer_incomplete_level
= 0;
76 static struct incomplete
*defer_incomplete_list
;
78 /* This variable is used to delay expanding From_With_Type types until the
80 static struct incomplete
*defer_limited_with
;
82 /* These variables are used to defer finalizing types. The element of the
83 list is the TYPE_DECL associated with the type. */
84 static int defer_finalize_level
= 0;
85 static VEC (tree
,heap
) *defer_finalize_list
;
87 /* A hash table used to cache the result of annotate_value. */
88 static GTY ((if_marked ("tree_int_map_marked_p"),
89 param_is (struct tree_int_map
))) htab_t annotate_value_cache
;
91 static void copy_alias_set (tree
, tree
);
92 static tree
substitution_list (Entity_Id
, Entity_Id
, tree
, bool);
93 static bool allocatable_size_p (tree
, bool);
94 static void prepend_one_attribute_to (struct attrib
**,
95 enum attr_type
, tree
, tree
, Node_Id
);
96 static void prepend_attributes (Entity_Id
, struct attrib
**);
97 static tree
elaborate_expression (Node_Id
, Entity_Id
, tree
, bool, bool, bool);
98 static bool is_variable_size (tree
);
99 static tree
elaborate_expression_1 (Node_Id
, Entity_Id
, tree
, tree
,
101 static tree
make_packable_type (tree
);
102 static tree
gnat_to_gnu_field (Entity_Id
, tree
, int, bool);
103 static tree
gnat_to_gnu_param (Entity_Id
, Mechanism_Type
, Entity_Id
, bool,
105 static bool same_discriminant_p (Entity_Id
, Entity_Id
);
106 static bool array_type_has_nonaliased_component (Entity_Id
, tree
);
107 static void components_to_record (tree
, Node_Id
, tree
, int, bool, tree
*,
108 bool, bool, bool, bool);
109 static Uint
annotate_value (tree
);
110 static void annotate_rep (Entity_Id
, tree
);
111 static tree
compute_field_positions (tree
, tree
, tree
, tree
, unsigned int);
112 static tree
validate_size (Uint
, tree
, Entity_Id
, enum tree_code
, bool, bool);
113 static void set_rm_size (Uint
, tree
, Entity_Id
);
114 static tree
make_type_from_size (tree
, tree
, bool);
115 static unsigned int validate_alignment (Uint
, Entity_Id
, unsigned int);
116 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT
);
117 static void check_ok_for_atomic (tree
, Entity_Id
, bool);
118 static int compatible_signatures_p (tree ftype1
, tree ftype2
);
120 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
121 GCC type corresponding to that entity. GNAT_ENTITY is assumed to
122 refer to an Ada type. */
125 gnat_to_gnu_type (Entity_Id gnat_entity
)
129 /* The back end never attempts to annotate generic types */
130 if (Is_Generic_Type (gnat_entity
) && type_annotate_only
)
131 return void_type_node
;
133 /* Convert the ada entity type into a GCC TYPE_DECL node. */
134 gnu_decl
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
135 gcc_assert (TREE_CODE (gnu_decl
) == TYPE_DECL
);
136 return TREE_TYPE (gnu_decl
);
139 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
140 entity, this routine returns the equivalent GCC tree for that entity
141 (an ..._DECL node) and associates the ..._DECL node with the input GNAT
144 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
145 initial value (in GCC tree form). This is optional for variables.
146 For renamed entities, GNU_EXPR gives the object being renamed.
148 DEFINITION is nonzero if this call is intended for a definition. This is
149 used for separate compilation where it necessary to know whether an
150 external declaration or a definition should be created if the GCC equivalent
151 was not created previously. The value of 1 is normally used for a nonzero
152 DEFINITION, but a value of 2 is used in special circumstances, defined in
156 gnat_to_gnu_entity (Entity_Id gnat_entity
, tree gnu_expr
, int definition
)
158 Entity_Id gnat_equiv_type
= Gigi_Equivalent_Type (gnat_entity
);
160 tree gnu_type
= NULL_TREE
;
161 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
162 GNAT tree. This node will be associated with the GNAT node by calling
163 the save_gnu_tree routine at the end of the `switch' statement. */
164 tree gnu_decl
= NULL_TREE
;
165 /* true if we have already saved gnu_decl as a gnat association. */
167 /* Nonzero if we incremented defer_incomplete_level. */
168 bool this_deferred
= false;
169 /* Nonzero if we incremented force_global. */
170 bool this_global
= false;
171 /* Nonzero if we should check to see if elaborated during processing. */
172 bool maybe_present
= false;
173 /* Nonzero if we made GNU_DECL and its type here. */
174 bool this_made_decl
= false;
175 struct attrib
*attr_list
= NULL
;
176 bool debug_info_p
= (Needs_Debug_Info (gnat_entity
)
177 || debug_info_level
== DINFO_LEVEL_VERBOSE
);
178 Entity_Kind kind
= Ekind (gnat_entity
);
181 = ((Known_Esize (gnat_entity
)
182 && UI_Is_In_Int_Range (Esize (gnat_entity
)))
183 ? MIN (UI_To_Int (Esize (gnat_entity
)),
184 IN (kind
, Float_Kind
)
185 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE
)
186 : IN (kind
, Access_Kind
) ? POINTER_SIZE
* 2
187 : LONG_LONG_TYPE_SIZE
)
188 : LONG_LONG_TYPE_SIZE
);
191 = (Is_Imported (gnat_entity
) && No (Address_Clause (gnat_entity
)));
192 unsigned int align
= 0;
194 /* Since a use of an Itype is a definition, process it as such if it
195 is not in a with'ed unit. */
197 if (!definition
&& Is_Itype (gnat_entity
)
198 && !present_gnu_tree (gnat_entity
)
199 && In_Extended_Main_Code_Unit (gnat_entity
))
201 /* Ensure that we are in a subprogram mentioned in the Scope
202 chain of this entity, our current scope is global,
203 or that we encountered a task or entry (where we can't currently
204 accurately check scoping). */
205 if (!current_function_decl
206 || DECL_ELABORATION_PROC_P (current_function_decl
))
208 process_type (gnat_entity
);
209 return get_gnu_tree (gnat_entity
);
212 for (gnat_temp
= Scope (gnat_entity
);
213 Present (gnat_temp
); gnat_temp
= Scope (gnat_temp
))
215 if (Is_Type (gnat_temp
))
216 gnat_temp
= Underlying_Type (gnat_temp
);
218 if (Ekind (gnat_temp
) == E_Subprogram_Body
)
220 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp
)));
222 if (IN (Ekind (gnat_temp
), Subprogram_Kind
)
223 && Present (Protected_Body_Subprogram (gnat_temp
)))
224 gnat_temp
= Protected_Body_Subprogram (gnat_temp
);
226 if (Ekind (gnat_temp
) == E_Entry
227 || Ekind (gnat_temp
) == E_Entry_Family
228 || Ekind (gnat_temp
) == E_Task_Type
229 || (IN (Ekind (gnat_temp
), Subprogram_Kind
)
230 && present_gnu_tree (gnat_temp
)
231 && (current_function_decl
232 == gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0))))
234 process_type (gnat_entity
);
235 return get_gnu_tree (gnat_entity
);
239 /* This abort means the entity "gnat_entity" has an incorrect scope,
240 i.e. that its scope does not correspond to the subprogram in which
245 /* If this is entity 0, something went badly wrong. */
246 gcc_assert (Present (gnat_entity
));
248 /* If we've already processed this entity, return what we got last time.
249 If we are defining the node, we should not have already processed it.
250 In that case, we will abort below when we try to save a new GCC tree for
251 this object. We also need to handle the case of getting a dummy type
252 when a Full_View exists. */
254 if (present_gnu_tree (gnat_entity
)
255 && (!definition
|| (Is_Type (gnat_entity
) && imported_p
)))
257 gnu_decl
= get_gnu_tree (gnat_entity
);
259 if (TREE_CODE (gnu_decl
) == TYPE_DECL
260 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
))
261 && IN (kind
, Incomplete_Or_Private_Kind
)
262 && Present (Full_View (gnat_entity
)))
264 gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity
),
267 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
268 save_gnu_tree (gnat_entity
, gnu_decl
, false);
274 /* If this is a numeric or enumeral type, or an access type, a nonzero
275 Esize must be specified unless it was specified by the programmer. */
276 gcc_assert (!Unknown_Esize (gnat_entity
)
277 || Has_Size_Clause (gnat_entity
)
278 || (!IN (kind
, Numeric_Kind
) && !IN (kind
, Enumeration_Kind
)
279 && (!IN (kind
, Access_Kind
)
280 || kind
== E_Access_Protected_Subprogram_Type
281 || kind
== E_Anonymous_Access_Protected_Subprogram_Type
282 || kind
== E_Access_Subtype
)));
284 /* Likewise, RM_Size must be specified for all discrete and fixed-point
286 gcc_assert (!IN (kind
, Discrete_Or_Fixed_Point_Kind
)
287 || !Unknown_RM_Size (gnat_entity
));
289 /* Get the name of the entity and set up the line number and filename of
290 the original definition for use in any decl we make. */
291 gnu_entity_id
= get_entity_name (gnat_entity
);
292 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
294 /* If we get here, it means we have not yet done anything with this
295 entity. If we are not defining it here, it must be external,
296 otherwise we should have defined it already. */
297 gcc_assert (definition
|| Is_Public (gnat_entity
) || type_annotate_only
298 || kind
== E_Discriminant
|| kind
== E_Component
300 || (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
301 || IN (kind
, Type_Kind
));
303 /* For cases when we are not defining (i.e., we are referencing from
304 another compilation unit) Public entities, show we are at global level
305 for the purpose of computing scopes. Don't do this for components or
306 discriminants since the relevant test is whether or not the record is
307 being defined. But do this for Imported functions or procedures in
309 if ((!definition
&& Is_Public (gnat_entity
)
310 && !Is_Statically_Allocated (gnat_entity
)
311 && kind
!= E_Discriminant
&& kind
!= E_Component
)
312 || (Is_Imported (gnat_entity
)
313 && (kind
== E_Function
|| kind
== E_Procedure
)))
314 force_global
++, this_global
= true;
316 /* Handle any attributes directly attached to the entity. */
317 if (Has_Gigi_Rep_Item (gnat_entity
))
318 prepend_attributes (gnat_entity
, &attr_list
);
320 /* Machine_Attributes on types are expected to be propagated to subtypes.
321 The corresponding Gigi_Rep_Items are only attached to the first subtype
322 though, so we handle the propagation here. */
323 if (Is_Type (gnat_entity
) && Base_Type (gnat_entity
) != gnat_entity
324 && !Is_First_Subtype (gnat_entity
)
325 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity
))))
326 prepend_attributes (First_Subtype (Base_Type (gnat_entity
)), &attr_list
);
331 /* If this is a use of a deferred constant, get its full
333 if (!definition
&& Present (Full_View (gnat_entity
)))
335 gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity
),
341 /* If we have an external constant that we are not defining, get the
342 expression that is was defined to represent. We may throw that
343 expression away later if it is not a constant. Do not retrieve the
344 expression if it is an aggregate or allocator, because in complex
345 instantiation contexts it may not be expanded */
347 && Present (Expression (Declaration_Node (gnat_entity
)))
348 && !No_Initialization (Declaration_Node (gnat_entity
))
349 && (Nkind (Expression (Declaration_Node (gnat_entity
)))
351 && (Nkind (Expression (Declaration_Node (gnat_entity
)))
353 gnu_expr
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
355 /* Ignore deferred constant definitions; they are processed fully in the
356 front-end. For deferred constant references get the full definition.
357 On the other hand, constants that are renamings are handled like
358 variable renamings. If No_Initialization is set, this is not a
359 deferred constant but a constant whose value is built manually. */
360 if (definition
&& !gnu_expr
361 && !No_Initialization (Declaration_Node (gnat_entity
))
362 && No (Renamed_Object (gnat_entity
)))
364 gnu_decl
= error_mark_node
;
368 else if (!definition
&& IN (kind
, Incomplete_Or_Private_Kind
)
369 && Present (Full_View (gnat_entity
)))
371 gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity
),
380 /* We used to special case VMS exceptions here to directly map them to
381 their associated condition code. Since this code had to be masked
382 dynamically to strip off the severity bits, this caused trouble in
383 the GCC/ZCX case because the "type" pointers we store in the tables
384 have to be static. We now don't special case here anymore, and let
385 the regular processing take place, which leaves us with a regular
386 exception data object for VMS exceptions too. The condition code
387 mapping is taken care of by the front end and the bitmasking by the
394 /* The GNAT record where the component was defined. */
395 Entity_Id gnat_record
= Underlying_Type (Scope (gnat_entity
));
397 /* If the variable is an inherited record component (in the case of
398 extended record types), just return the inherited entity, which
399 must be a FIELD_DECL. Likewise for discriminants.
400 For discriminants of untagged records which have explicit
401 stored discriminants, return the entity for the corresponding
402 stored discriminant. Also use Original_Record_Component
403 if the record has a private extension. */
405 if (Present (Original_Record_Component (gnat_entity
))
406 && Original_Record_Component (gnat_entity
) != gnat_entity
)
409 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity
),
410 gnu_expr
, definition
);
415 /* If the enclosing record has explicit stored discriminants,
416 then it is an untagged record. If the Corresponding_Discriminant
417 is not empty then this must be a renamed discriminant and its
418 Original_Record_Component must point to the corresponding explicit
419 stored discriminant (i.e., we should have taken the previous
422 else if (Present (Corresponding_Discriminant (gnat_entity
))
423 && Is_Tagged_Type (gnat_record
))
425 /* A tagged record has no explicit stored discriminants. */
427 gcc_assert (First_Discriminant (gnat_record
)
428 == First_Stored_Discriminant (gnat_record
));
430 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity
),
431 gnu_expr
, definition
);
436 else if (Present (CR_Discriminant (gnat_entity
))
437 && type_annotate_only
)
439 gnu_decl
= gnat_to_gnu_entity (CR_Discriminant (gnat_entity
),
440 gnu_expr
, definition
);
445 /* If the enclosing record has explicit stored discriminants,
446 then it is an untagged record. If the Corresponding_Discriminant
447 is not empty then this must be a renamed discriminant and its
448 Original_Record_Component must point to the corresponding explicit
449 stored discriminant (i.e., we should have taken the first
452 else if (Present (Corresponding_Discriminant (gnat_entity
))
453 && (First_Discriminant (gnat_record
)
454 != First_Stored_Discriminant (gnat_record
)))
457 /* Otherwise, if we are not defining this and we have no GCC type
458 for the containing record, make one for it. Then we should
459 have made our own equivalent. */
460 else if (!definition
&& !present_gnu_tree (gnat_record
))
462 /* ??? If this is in a record whose scope is a protected
463 type and we have an Original_Record_Component, use it.
464 This is a workaround for major problems in protected type
466 Entity_Id Scop
= Scope (Scope (gnat_entity
));
467 if ((Is_Protected_Type (Scop
)
468 || (Is_Private_Type (Scop
)
469 && Present (Full_View (Scop
))
470 && Is_Protected_Type (Full_View (Scop
))))
471 && Present (Original_Record_Component (gnat_entity
)))
474 = gnat_to_gnu_entity (Original_Record_Component
481 gnat_to_gnu_entity (Scope (gnat_entity
), NULL_TREE
, 0);
482 gnu_decl
= get_gnu_tree (gnat_entity
);
488 /* Here we have no GCC type and this is a reference rather than a
489 definition. This should never happen. Most likely the cause is a
490 reference before declaration in the gnat tree for gnat_entity. */
494 case E_Loop_Parameter
:
495 case E_Out_Parameter
:
498 /* Simple variables, loop variables, Out parameters, and exceptions. */
501 bool used_by_ref
= false;
503 = ((kind
== E_Constant
|| kind
== E_Variable
)
504 && Is_True_Constant (gnat_entity
)
505 && (((Nkind (Declaration_Node (gnat_entity
))
506 == N_Object_Declaration
)
507 && Present (Expression (Declaration_Node (gnat_entity
))))
508 || Present (Renamed_Object (gnat_entity
))));
509 bool inner_const_flag
= const_flag
;
510 bool static_p
= Is_Statically_Allocated (gnat_entity
);
511 bool mutable_p
= false;
512 tree gnu_ext_name
= NULL_TREE
;
513 tree renamed_obj
= NULL_TREE
;
515 if (Present (Renamed_Object (gnat_entity
)) && !definition
)
517 if (kind
== E_Exception
)
518 gnu_expr
= gnat_to_gnu_entity (Renamed_Entity (gnat_entity
),
521 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_entity
));
524 /* Get the type after elaborating the renamed object. */
525 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
527 /* For a debug renaming declaration, build a pure debug entity. */
528 if (Present (Debug_Renaming_Link (gnat_entity
)))
531 gnu_decl
= build_decl (VAR_DECL
, gnu_entity_id
, gnu_type
);
532 /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
533 if (global_bindings_p ())
534 addr
= gen_rtx_CONST (VOIDmode
, const0_rtx
);
536 addr
= stack_pointer_rtx
;
537 SET_DECL_RTL (gnu_decl
, gen_rtx_MEM (Pmode
, addr
));
538 gnat_pushdecl (gnu_decl
, gnat_entity
);
542 /* If this is a loop variable, its type should be the base type.
543 This is because the code for processing a loop determines whether
544 a normal loop end test can be done by comparing the bounds of the
545 loop against those of the base type, which is presumed to be the
546 size used for computation. But this is not correct when the size
547 of the subtype is smaller than the type. */
548 if (kind
== E_Loop_Parameter
)
549 gnu_type
= get_base_type (gnu_type
);
551 /* Reject non-renamed objects whose types are unconstrained arrays or
552 any object whose type is a dummy type or VOID_TYPE. */
554 if ((TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
555 && No (Renamed_Object (gnat_entity
)))
556 || TYPE_IS_DUMMY_P (gnu_type
)
557 || TREE_CODE (gnu_type
) == VOID_TYPE
)
559 gcc_assert (type_annotate_only
);
562 return error_mark_node
;
565 /* If an alignment is specified, use it if valid. Note that
566 exceptions are objects but don't have alignments. We must do this
567 before we validate the size, since the alignment can affect the
569 if (kind
!= E_Exception
&& Known_Alignment (gnat_entity
))
571 gcc_assert (Present (Alignment (gnat_entity
)));
572 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
573 TYPE_ALIGN (gnu_type
));
574 gnu_type
= maybe_pad_type (gnu_type
, NULL_TREE
, align
, gnat_entity
,
575 "PAD", false, definition
, true);
578 /* If we are defining the object, see if it has a Size value and
579 validate it if so. If we are not defining the object and a Size
580 clause applies, simply retrieve the value. We don't want to ignore
581 the clause and it is expected to have been validated already. Then
582 get the new type, if any. */
584 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
,
585 gnat_entity
, VAR_DECL
, false,
586 Has_Size_Clause (gnat_entity
));
587 else if (Has_Size_Clause (gnat_entity
))
588 gnu_size
= UI_To_gnu (Esize (gnat_entity
), bitsizetype
);
593 = make_type_from_size (gnu_type
, gnu_size
,
594 Has_Biased_Representation (gnat_entity
));
596 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0))
597 gnu_size
= NULL_TREE
;
600 /* If this object has self-referential size, it must be a record with
601 a default value. We are supposed to allocate an object of the
602 maximum size in this case unless it is a constant with an
603 initializing expression, in which case we can get the size from
604 that. Note that the resulting size may still be a variable, so
605 this may end up with an indirect allocation. */
607 if (No (Renamed_Object (gnat_entity
))
608 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
610 if (gnu_expr
&& kind
== E_Constant
)
612 = SUBSTITUTE_PLACEHOLDER_IN_EXPR
613 (TYPE_SIZE (TREE_TYPE (gnu_expr
)), gnu_expr
);
615 /* We may have no GNU_EXPR because No_Initialization is
616 set even though there's an Expression. */
617 else if (kind
== E_Constant
618 && (Nkind (Declaration_Node (gnat_entity
))
619 == N_Object_Declaration
)
620 && Present (Expression (Declaration_Node (gnat_entity
))))
622 = TYPE_SIZE (gnat_to_gnu_type
624 (Expression (Declaration_Node (gnat_entity
)))));
627 gnu_size
= max_size (TYPE_SIZE (gnu_type
), true);
632 /* If the size is zero bytes, make it one byte since some linkers have
633 trouble with zero-sized objects. If the object will have a
634 template, that will make it nonzero so don't bother. Also avoid
635 doing that for an object renaming or an object with an address
636 clause, as we would lose useful information on the view size
637 (e.g. for null array slices) and we are not allocating the object
639 if (((gnu_size
&& integer_zerop (gnu_size
))
640 || (TYPE_SIZE (gnu_type
) && integer_zerop (TYPE_SIZE (gnu_type
))))
641 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
642 || !Is_Array_Type (Etype (gnat_entity
)))
643 && !Present (Renamed_Object (gnat_entity
))
644 && !Present (Address_Clause (gnat_entity
)))
645 gnu_size
= bitsize_unit_node
;
647 /* If this is an atomic object with no specified size and alignment,
648 but where the size of the type is a constant, set the alignment to
649 the smallest not less than the size, or to the biggest meaningful
650 alignment, whichever is smaller. */
651 if (Is_Atomic (gnat_entity
) && !gnu_size
&& align
== 0
652 && TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
)
654 if (!host_integerp (TYPE_SIZE (gnu_type
), 1)
655 || 0 <= compare_tree_int (TYPE_SIZE (gnu_type
),
657 align
= BIGGEST_ALIGNMENT
;
659 align
= ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type
), 1));
662 /* If the object is set to have atomic components, find the component
663 type and validate it.
665 ??? Note that we ignore Has_Volatile_Components on objects; it's
666 not at all clear what to do in that case. */
668 if (Has_Atomic_Components (gnat_entity
))
670 tree gnu_inner
= (TREE_CODE (gnu_type
) == ARRAY_TYPE
671 ? TREE_TYPE (gnu_type
) : gnu_type
);
673 while (TREE_CODE (gnu_inner
) == ARRAY_TYPE
674 && TYPE_MULTI_ARRAY_P (gnu_inner
))
675 gnu_inner
= TREE_TYPE (gnu_inner
);
677 check_ok_for_atomic (gnu_inner
, gnat_entity
, true);
680 /* Now check if the type of the object allows atomic access. Note
681 that we must test the type, even if this object has size and
682 alignment to allow such access, because we will be going
683 inside the padded record to assign to the object. We could fix
684 this by always copying via an intermediate value, but it's not
685 clear it's worth the effort. */
686 if (Is_Atomic (gnat_entity
))
687 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
689 /* If this is an aliased object with an unconstrained nominal subtype,
690 make a type that includes the template. */
691 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
692 && Is_Array_Type (Etype (gnat_entity
))
693 && !type_annotate_only
)
696 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity
))));
699 = build_unc_object_type_from_ptr (gnu_fat
, gnu_type
,
700 concat_id_with_name (gnu_entity_id
,
704 #ifdef MINIMUM_ATOMIC_ALIGNMENT
705 /* If the size is a constant and no alignment is specified, force
706 the alignment to be the minimum valid atomic alignment. The
707 restriction on constant size avoids problems with variable-size
708 temporaries; if the size is variable, there's no issue with
709 atomic access. Also don't do this for a constant, since it isn't
710 necessary and can interfere with constant replacement. Finally,
711 do not do it for Out parameters since that creates an
712 size inconsistency with In parameters. */
713 if (align
== 0 && MINIMUM_ATOMIC_ALIGNMENT
> TYPE_ALIGN (gnu_type
)
714 && !FLOAT_TYPE_P (gnu_type
)
715 && !const_flag
&& No (Renamed_Object (gnat_entity
))
716 && !imported_p
&& No (Address_Clause (gnat_entity
))
717 && kind
!= E_Out_Parameter
718 && (gnu_size
? TREE_CODE (gnu_size
) == INTEGER_CST
719 : TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
))
720 align
= MINIMUM_ATOMIC_ALIGNMENT
;
723 /* Make a new type with the desired size and alignment, if needed. */
724 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
725 "PAD", false, definition
, true);
727 /* Make a volatile version of this object's type if we are to make
728 the object volatile. We also interpret 13.3(19) conservatively
729 and disallow any optimizations for an object covered by it. */
730 if ((Treat_As_Volatile (gnat_entity
)
731 || (Is_Exported (gnat_entity
)
732 /* Exclude exported constants created by the compiler,
733 which should boil down to static dispatch tables and
734 make it possible to put them in read-only memory. */
735 && (Comes_From_Source (gnat_entity
) || !const_flag
))
736 || Is_Imported (gnat_entity
)
737 || Present (Address_Clause (gnat_entity
)))
738 && !TYPE_VOLATILE (gnu_type
))
739 gnu_type
= build_qualified_type (gnu_type
,
740 (TYPE_QUALS (gnu_type
)
741 | TYPE_QUAL_VOLATILE
));
743 /* If this is a renaming, avoid as much as possible to create a new
744 object. However, in several cases, creating it is required.
745 This processing needs to be applied to the raw expression so
746 as to make it more likely to rename the underlying object. */
747 if (Present (Renamed_Object (gnat_entity
)))
749 bool create_normal_object
= false;
751 /* If the renamed object had padding, strip off the reference
752 to the inner object and reset our type. */
753 if ((TREE_CODE (gnu_expr
) == COMPONENT_REF
754 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
756 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
757 /* Strip useless conversions around the object. */
758 || TREE_CODE (gnu_expr
) == NOP_EXPR
)
760 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
761 gnu_type
= TREE_TYPE (gnu_expr
);
764 /* Case 1: If this is a constant renaming stemming from a function
765 call, treat it as a normal object whose initial value is what
766 is being renamed. RM 3.3 says that the result of evaluating a
767 function call is a constant object. As a consequence, it can
768 be the inner object of a constant renaming. In this case, the
769 renaming must be fully instantiated, i.e. it cannot be a mere
770 reference to (part of) an existing object. */
773 tree inner_object
= gnu_expr
;
774 while (handled_component_p (inner_object
))
775 inner_object
= TREE_OPERAND (inner_object
, 0);
776 if (TREE_CODE (inner_object
) == CALL_EXPR
)
777 create_normal_object
= true;
780 /* Otherwise, see if we can proceed with a stabilized version of
781 the renamed entity or if we need to make a new object. */
782 if (!create_normal_object
)
784 tree maybe_stable_expr
= NULL_TREE
;
787 /* Case 2: If the renaming entity need not be materialized and
788 the renamed expression is something we can stabilize, use
789 that for the renaming. At the global level, we can only do
790 this if we know no SAVE_EXPRs need be made, because the
791 expression we return might be used in arbitrary conditional
792 branches so we must force the SAVE_EXPRs evaluation
793 immediately and this requires a function context. */
794 if (!Materialize_Entity (gnat_entity
)
795 && (!global_bindings_p ()
796 || (staticp (gnu_expr
)
797 && !TREE_SIDE_EFFECTS (gnu_expr
))))
800 = maybe_stabilize_reference (gnu_expr
, true, &stable
);
804 gnu_decl
= maybe_stable_expr
;
805 /* ??? No DECL_EXPR is created so we need to mark
806 the expression manually lest it is shared. */
807 if (global_bindings_p ())
808 TREE_VISITED (gnu_decl
) = 1;
809 save_gnu_tree (gnat_entity
, gnu_decl
, true);
814 /* The stabilization failed. Keep maybe_stable_expr
815 untouched here to let the pointer case below know
816 about that failure. */
819 /* Case 3: If this is a constant renaming and creating a
820 new object is allowed and cheap, treat it as a normal
821 object whose initial value is what is being renamed. */
822 if (const_flag
&& Is_Elementary_Type (Etype (gnat_entity
)))
825 /* Case 4: Make this into a constant pointer to the object we
826 are to rename and attach the object to the pointer if it is
827 something we can stabilize.
829 From the proper scope, attached objects will be referenced
830 directly instead of indirectly via the pointer to avoid
831 subtle aliasing problems with non-addressable entities.
832 They have to be stable because we must not evaluate the
833 variables in the expression every time the renaming is used.
834 The pointer is called a "renaming" pointer in this case.
836 In the rare cases where we cannot stabilize the renamed
837 object, we just make a "bare" pointer, and the renamed
838 entity is always accessed indirectly through it. */
841 gnu_type
= build_reference_type (gnu_type
);
842 inner_const_flag
= TREE_READONLY (gnu_expr
);
845 /* If the previous attempt at stabilizing failed, there
846 is no point in trying again and we reuse the result
847 without attaching it to the pointer. In this case it
848 will only be used as the initializing expression of
849 the pointer and thus needs no special treatment with
850 regard to multiple evaluations. */
851 if (maybe_stable_expr
)
854 /* Otherwise, try to stabilize and attach the expression
855 to the pointer if the stabilization succeeds.
857 Note that this might introduce SAVE_EXPRs and we don't
858 check whether we're at the global level or not. This
859 is fine since we are building a pointer initializer and
860 neither the pointer nor the initializing expression can
861 be accessed before the pointer elaboration has taken
862 place in a correct program.
864 These SAVE_EXPRs will be evaluated at the right place
865 by either the evaluation of the initializer for the
866 non-global case or the elaboration code for the global
867 case, and will be attached to the elaboration procedure
868 in the latter case. */
872 = maybe_stabilize_reference (gnu_expr
, true, &stable
);
875 renamed_obj
= maybe_stable_expr
;
877 /* Attaching is actually performed downstream, as soon
878 as we have a VAR_DECL for the pointer we make. */
882 = build_unary_op (ADDR_EXPR
, gnu_type
, maybe_stable_expr
);
884 gnu_size
= NULL_TREE
;
890 /* If this is an aliased object whose nominal subtype is unconstrained,
891 the object is a record that contains both the template and
892 the object. If there is an initializer, it will have already
893 been converted to the right type, but we need to create the
894 template if there is no initializer. */
896 && TREE_CODE (gnu_type
) == RECORD_TYPE
897 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
898 /* Beware that padding might have been introduced
899 via maybe_pad_type above. */
900 || (TYPE_IS_PADDING_P (gnu_type
)
901 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
903 && TYPE_CONTAINS_TEMPLATE_P
904 (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))
908 = TYPE_IS_PADDING_P (gnu_type
)
909 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
910 : TYPE_FIELDS (gnu_type
);
913 = gnat_build_constructor
917 build_template (TREE_TYPE (template_field
),
918 TREE_TYPE (TREE_CHAIN (template_field
)),
923 /* Convert the expression to the type of the object except in the
924 case where the object's type is unconstrained or the object's type
925 is a padded record whose field is of self-referential size. In
926 the former case, converting will generate unnecessary evaluations
927 of the CONSTRUCTOR to compute the size and in the latter case, we
928 want to only copy the actual data. */
930 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
931 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
932 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
933 && TYPE_IS_PADDING_P (gnu_type
)
934 && (CONTAINS_PLACEHOLDER_P
935 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))))
936 gnu_expr
= convert (gnu_type
, gnu_expr
);
938 /* If this is a pointer and it does not have an initializing
939 expression, initialize it to NULL, unless the object is
942 && (POINTER_TYPE_P (gnu_type
) || TYPE_FAT_POINTER_P (gnu_type
))
943 && !Is_Imported (gnat_entity
) && !gnu_expr
)
944 gnu_expr
= integer_zero_node
;
946 /* If we are defining the object and it has an Address clause we must
947 get the address expression from the saved GCC tree for the
948 object if the object has a Freeze_Node. Otherwise, we elaborate
949 the address expression here since the front-end has guaranteed
950 in that case that the elaboration has no effects. Note that
951 only the latter mechanism is currently in use. */
952 if (definition
&& Present (Address_Clause (gnat_entity
)))
955 = (present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
)
956 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
958 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
960 /* Ignore the size. It's either meaningless or was handled
962 gnu_size
= NULL_TREE
;
963 /* Convert the type of the object to a reference type that can
964 alias everything as per 13.3(19). */
966 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
967 gnu_address
= convert (gnu_type
, gnu_address
);
969 const_flag
= !Is_Public (gnat_entity
);
971 /* If we don't have an initializing expression for the underlying
972 variable, the initializing expression for the pointer is the
973 specified address. Otherwise, we have to make a COMPOUND_EXPR
974 to assign both the address and the initial value. */
976 gnu_expr
= gnu_address
;
979 = build2 (COMPOUND_EXPR
, gnu_type
,
981 (MODIFY_EXPR
, NULL_TREE
,
982 build_unary_op (INDIRECT_REF
, NULL_TREE
,
988 /* If it has an address clause and we are not defining it, mark it
989 as an indirect object. Likewise for Stdcall objects that are
991 if ((!definition
&& Present (Address_Clause (gnat_entity
)))
992 || (Is_Imported (gnat_entity
)
993 && Has_Stdcall_Convention (gnat_entity
)))
995 /* Convert the type of the object to a reference type that can
996 alias everything as per 13.3(19). */
998 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
999 gnu_size
= NULL_TREE
;
1001 gnu_expr
= NULL_TREE
;
1002 /* No point in taking the address of an initializing expression
1003 that isn't going to be used. */
1008 /* If we are at top level and this object is of variable size,
1009 make the actual type a hidden pointer to the real type and
1010 make the initializer be a memory allocation and initialization.
1011 Likewise for objects we aren't defining (presumed to be
1012 external references from other packages), but there we do
1013 not set up an initialization.
1015 If the object's size overflows, make an allocator too, so that
1016 Storage_Error gets raised. Note that we will never free
1017 such memory, so we presume it never will get allocated. */
1019 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type
),
1020 global_bindings_p () || !definition
1023 && ! allocatable_size_p (gnu_size
,
1024 global_bindings_p () || !definition
1027 gnu_type
= build_reference_type (gnu_type
);
1028 gnu_size
= NULL_TREE
;
1032 /* In case this was a aliased object whose nominal subtype is
1033 unconstrained, the pointer above will be a thin pointer and
1034 build_allocator will automatically make the template.
1036 If we have a template initializer only (that we made above),
1037 pretend there is none and rely on what build_allocator creates
1038 again anyway. Otherwise (if we have a full initializer), get
1039 the data part and feed that to build_allocator.
1041 If we are elaborating a mutable object, tell build_allocator to
1042 ignore a possibly simpler size from the initializer, if any, as
1043 we must allocate the maximum possible size in this case. */
1047 tree gnu_alloc_type
= TREE_TYPE (gnu_type
);
1049 if (TREE_CODE (gnu_alloc_type
) == RECORD_TYPE
1050 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type
))
1053 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type
)));
1055 if (TREE_CODE (gnu_expr
) == CONSTRUCTOR
1056 && 1 == VEC_length (constructor_elt
,
1057 CONSTRUCTOR_ELTS (gnu_expr
)))
1061 = build_component_ref
1062 (gnu_expr
, NULL_TREE
,
1063 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr
))),
1067 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type
)) == INTEGER_CST
1068 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type
))
1069 && !Is_Imported (gnat_entity
))
1070 post_error ("?Storage_Error will be raised at run-time!",
1073 gnu_expr
= build_allocator (gnu_alloc_type
, gnu_expr
, gnu_type
,
1074 0, 0, gnat_entity
, mutable_p
);
1078 gnu_expr
= NULL_TREE
;
1083 /* If this object would go into the stack and has an alignment larger
1084 than the largest stack alignment the back-end can honor, resort to
1085 a variable of "aligning type". */
1086 if (!global_bindings_p () && !static_p
&& definition
1087 && !imported_p
&& TYPE_ALIGN (gnu_type
) > BIGGEST_ALIGNMENT
)
1089 /* Create the new variable. No need for extra room before the
1090 aligned field as this is in automatic storage. */
1092 = make_aligning_type (gnu_type
, TYPE_ALIGN (gnu_type
),
1093 TYPE_SIZE_UNIT (gnu_type
),
1094 BIGGEST_ALIGNMENT
, 0);
1096 = create_var_decl (create_concat_name (gnat_entity
, "ALIGN"),
1097 NULL_TREE
, gnu_new_type
, NULL_TREE
, false,
1098 false, false, false, NULL
, gnat_entity
);
1100 /* Initialize the aligned field if we have an initializer. */
1103 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
1105 (gnu_new_var
, NULL_TREE
,
1106 TYPE_FIELDS (gnu_new_type
), false),
1110 /* And setup this entity as a reference to the aligned field. */
1111 gnu_type
= build_reference_type (gnu_type
);
1114 (ADDR_EXPR
, gnu_type
,
1115 build_component_ref (gnu_new_var
, NULL_TREE
,
1116 TYPE_FIELDS (gnu_new_type
), false));
1118 gnu_size
= NULL_TREE
;
1124 gnu_type
= build_qualified_type (gnu_type
, (TYPE_QUALS (gnu_type
)
1125 | TYPE_QUAL_CONST
));
1127 /* Convert the expression to the type of the object except in the
1128 case where the object's type is unconstrained or the object's type
1129 is a padded record whose field is of self-referential size. In
1130 the former case, converting will generate unnecessary evaluations
1131 of the CONSTRUCTOR to compute the size and in the latter case, we
1132 want to only copy the actual data. */
1134 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1135 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1136 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1137 && TYPE_IS_PADDING_P (gnu_type
)
1138 && (CONTAINS_PLACEHOLDER_P
1139 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))))
1140 gnu_expr
= convert (gnu_type
, gnu_expr
);
1142 /* If this name is external or there was a name specified, use it,
1143 unless this is a VMS exception object since this would conflict
1144 with the symbol we need to export in addition. Don't use the
1145 Interface_Name if there is an address clause (see CD30005). */
1146 if (!Is_VMS_Exception (gnat_entity
)
1147 && ((Present (Interface_Name (gnat_entity
))
1148 && No (Address_Clause (gnat_entity
)))
1149 || (Is_Public (gnat_entity
)
1150 && (!Is_Imported (gnat_entity
)
1151 || Is_Exported (gnat_entity
)))))
1152 gnu_ext_name
= create_concat_name (gnat_entity
, 0);
1154 /* If this is constant initialized to a static constant and the
1155 object has an aggregate type, force it to be statically
1157 if (const_flag
&& gnu_expr
&& TREE_CONSTANT (gnu_expr
)
1158 && host_integerp (TYPE_SIZE_UNIT (gnu_type
), 1)
1159 && (AGGREGATE_TYPE_P (gnu_type
)
1160 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1161 && TYPE_IS_PADDING_P (gnu_type
))))
1164 gnu_decl
= create_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
1165 gnu_expr
, const_flag
,
1166 Is_Public (gnat_entity
),
1167 imported_p
|| !definition
,
1168 static_p
, attr_list
, gnat_entity
);
1169 DECL_BY_REF_P (gnu_decl
) = used_by_ref
;
1170 DECL_POINTS_TO_READONLY_P (gnu_decl
) = used_by_ref
&& inner_const_flag
;
1171 if (TREE_CODE (gnu_decl
) == VAR_DECL
&& renamed_obj
)
1173 SET_DECL_RENAMED_OBJECT (gnu_decl
, renamed_obj
);
1174 if (global_bindings_p ())
1176 DECL_RENAMING_GLOBAL_P (gnu_decl
) = 1;
1177 record_global_renaming_pointer (gnu_decl
);
1181 if (definition
&& DECL_SIZE (gnu_decl
)
1182 && get_block_jmpbuf_decl ()
1183 && (TREE_CODE (DECL_SIZE (gnu_decl
)) != INTEGER_CST
1184 || (flag_stack_check
&& !STACK_CHECK_BUILTIN
1185 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl
),
1186 STACK_CHECK_MAX_VAR_SIZE
))))
1187 add_stmt_with_node (build_call_1_expr
1188 (update_setjmp_buf_decl
,
1189 build_unary_op (ADDR_EXPR
, NULL_TREE
,
1190 get_block_jmpbuf_decl ())),
1193 /* If this is a public constant or we're not optimizing and we're not
1194 making a VAR_DECL for it, make one just for export or debugger use.
1195 Likewise if the address is taken or if either the object or type is
1196 aliased. Make an external declaration for a reference, unless this
1197 is a Standard entity since there no real symbol at the object level
1199 if (TREE_CODE (gnu_decl
) == CONST_DECL
1200 && (definition
|| Sloc (gnat_entity
) > Standard_Location
)
1201 && (Is_Public (gnat_entity
)
1203 || Address_Taken (gnat_entity
)
1204 || Is_Aliased (gnat_entity
)
1205 || Is_Aliased (Etype (gnat_entity
))))
1208 = create_true_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
1209 gnu_expr
, true, Is_Public (gnat_entity
),
1210 !definition
, static_p
, NULL
,
1213 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl
, gnu_corr_var
);
1216 /* If this is declared in a block that contains a block with an
1217 exception handler, we must force this variable in memory to
1218 suppress an invalid optimization. */
1219 if (Has_Nested_Block_With_Handler (Scope (gnat_entity
))
1220 && Exception_Mechanism
!= Back_End_Exceptions
)
1221 TREE_ADDRESSABLE (gnu_decl
) = 1;
1223 gnu_type
= TREE_TYPE (gnu_decl
);
1225 /* Back-annotate Alignment and Esize of the object if not already
1226 known, except for when the object is actually a pointer to the
1227 real object, since alignment and size of a pointer don't have
1228 anything to do with those of the designated object. Note that
1229 we pick the values of the type, not those of the object, to
1230 shield ourselves from low-level platform-dependent adjustments
1231 like alignment promotion. This is both consistent with all the
1232 treatment above, where alignment and size are set on the type of
1233 the object and not on the object directly, and makes it possible
1234 to support confirming representation clauses in all cases. */
1236 if (!used_by_ref
&& Unknown_Alignment (gnat_entity
))
1237 Set_Alignment (gnat_entity
,
1238 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
1240 if (!used_by_ref
&& Unknown_Esize (gnat_entity
))
1244 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1245 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1247 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
))));
1249 gnu_back_size
= TYPE_SIZE (gnu_type
);
1251 Set_Esize (gnat_entity
, annotate_value (gnu_back_size
));
1257 /* Return a TYPE_DECL for "void" that we previously made. */
1258 gnu_decl
= void_type_decl_node
;
1261 case E_Enumeration_Type
:
1262 /* A special case, for the types Character and Wide_Character in
1263 Standard, we do not list all the literals. So if the literals
1264 are not specified, make this an unsigned type. */
1265 if (No (First_Literal (gnat_entity
)))
1267 gnu_type
= make_unsigned_type (esize
);
1268 TYPE_NAME (gnu_type
) = gnu_entity_id
;
1270 /* Set the TYPE_STRING_FLAG for Ada Character and
1271 Wide_Character types. This is needed by the dwarf-2 debug writer to
1272 distinguish between unsigned integer types and character types. */
1273 TYPE_STRING_FLAG (gnu_type
) = 1;
1277 /* Normal case of non-character type, or non-Standard character type */
1279 /* Here we have a list of enumeral constants in First_Literal.
1280 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1281 the list to be places into TYPE_FIELDS. Each node in the list
1282 is a TREE_LIST node whose TREE_VALUE is the literal name
1283 and whose TREE_PURPOSE is the value of the literal.
1285 Esize contains the number of bits needed to represent the enumeral
1286 type, Type_Low_Bound also points to the first literal and
1287 Type_High_Bound points to the last literal. */
1289 Entity_Id gnat_literal
;
1290 tree gnu_literal_list
= NULL_TREE
;
1292 if (Is_Unsigned_Type (gnat_entity
))
1293 gnu_type
= make_unsigned_type (esize
);
1295 gnu_type
= make_signed_type (esize
);
1297 TREE_SET_CODE (gnu_type
, ENUMERAL_TYPE
);
1299 for (gnat_literal
= First_Literal (gnat_entity
);
1300 Present (gnat_literal
);
1301 gnat_literal
= Next_Literal (gnat_literal
))
1303 tree gnu_value
= UI_To_gnu (Enumeration_Rep (gnat_literal
),
1306 = create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
1307 gnu_type
, gnu_value
, true, false, false,
1308 false, NULL
, gnat_literal
);
1310 save_gnu_tree (gnat_literal
, gnu_literal
, false);
1311 gnu_literal_list
= tree_cons (DECL_NAME (gnu_literal
),
1312 gnu_value
, gnu_literal_list
);
1315 TYPE_VALUES (gnu_type
) = nreverse (gnu_literal_list
);
1317 /* Note that the bounds are updated at the end of this function
1318 because to avoid an infinite recursion when we get the bounds of
1319 this type, since those bounds are objects of this type. */
1323 case E_Signed_Integer_Type
:
1324 case E_Ordinary_Fixed_Point_Type
:
1325 case E_Decimal_Fixed_Point_Type
:
1326 /* For integer types, just make a signed type the appropriate number
1328 gnu_type
= make_signed_type (esize
);
1331 case E_Modular_Integer_Type
:
1332 /* For modular types, make the unsigned type of the proper number of
1333 bits and then set up the modulus, if required. */
1335 enum machine_mode mode
;
1339 if (Is_Packed_Array_Type (gnat_entity
))
1340 esize
= UI_To_Int (RM_Size (gnat_entity
));
1342 /* Find the smallest mode at least ESIZE bits wide and make a class
1345 for (mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
1346 GET_MODE_BITSIZE (mode
) < esize
;
1347 mode
= GET_MODE_WIDER_MODE (mode
))
1350 gnu_type
= make_unsigned_type (GET_MODE_BITSIZE (mode
));
1351 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
1352 = Is_Packed_Array_Type (gnat_entity
);
1354 /* Get the modulus in this type. If it overflows, assume it is because
1355 it is equal to 2**Esize. Note that there is no overflow checking
1356 done on unsigned type, so we detect the overflow by looking for
1357 a modulus of zero, which is otherwise invalid. */
1358 gnu_modulus
= UI_To_gnu (Modulus (gnat_entity
), gnu_type
);
1360 if (!integer_zerop (gnu_modulus
))
1362 TYPE_MODULAR_P (gnu_type
) = 1;
1363 SET_TYPE_MODULUS (gnu_type
, gnu_modulus
);
1364 gnu_high
= fold_build2 (MINUS_EXPR
, gnu_type
, gnu_modulus
,
1365 convert (gnu_type
, integer_one_node
));
1368 /* If we have to set TYPE_PRECISION different from its natural value,
1369 make a subtype to do do. Likewise if there is a modulus and
1370 it is not one greater than TYPE_MAX_VALUE. */
1371 if (TYPE_PRECISION (gnu_type
) != esize
1372 || (TYPE_MODULAR_P (gnu_type
)
1373 && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type
), gnu_high
)))
1375 tree gnu_subtype
= make_node (INTEGER_TYPE
);
1377 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "UMT");
1378 TREE_TYPE (gnu_subtype
) = gnu_type
;
1379 TYPE_MIN_VALUE (gnu_subtype
) = TYPE_MIN_VALUE (gnu_type
);
1380 TYPE_MAX_VALUE (gnu_subtype
)
1381 = TYPE_MODULAR_P (gnu_type
)
1382 ? gnu_high
: TYPE_MAX_VALUE (gnu_type
);
1383 TYPE_PRECISION (gnu_subtype
) = esize
;
1384 TYPE_UNSIGNED (gnu_subtype
) = 1;
1385 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
1386 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype
)
1387 = Is_Packed_Array_Type (gnat_entity
);
1388 layout_type (gnu_subtype
);
1390 gnu_type
= gnu_subtype
;
1395 case E_Signed_Integer_Subtype
:
1396 case E_Enumeration_Subtype
:
1397 case E_Modular_Integer_Subtype
:
1398 case E_Ordinary_Fixed_Point_Subtype
:
1399 case E_Decimal_Fixed_Point_Subtype
:
1401 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1402 that we do not want to call build_range_type since we would
1403 like each subtype node to be distinct. This will be important
1404 when memory aliasing is implemented.
1406 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1407 parent type; this fact is used by the arithmetic conversion
1410 We elaborate the Ancestor_Subtype if it is not in the current
1411 unit and one of our bounds is non-static. We do this to ensure
1412 consistent naming in the case where several subtypes share the same
1413 bounds by always elaborating the first such subtype first, thus
1417 && Present (Ancestor_Subtype (gnat_entity
))
1418 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1419 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1420 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1421 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1424 gnu_type
= make_node (INTEGER_TYPE
);
1425 if (Is_Packed_Array_Type (gnat_entity
))
1427 esize
= UI_To_Int (RM_Size (gnat_entity
));
1428 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
) = 1;
1431 TYPE_PRECISION (gnu_type
) = esize
;
1432 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1434 TYPE_MIN_VALUE (gnu_type
)
1435 = convert (TREE_TYPE (gnu_type
),
1436 elaborate_expression (Type_Low_Bound (gnat_entity
),
1438 get_identifier ("L"), definition
, 1,
1439 Needs_Debug_Info (gnat_entity
)));
1441 TYPE_MAX_VALUE (gnu_type
)
1442 = convert (TREE_TYPE (gnu_type
),
1443 elaborate_expression (Type_High_Bound (gnat_entity
),
1445 get_identifier ("U"), definition
, 1,
1446 Needs_Debug_Info (gnat_entity
)));
1448 /* One of the above calls might have caused us to be elaborated,
1449 so don't blow up if so. */
1450 if (present_gnu_tree (gnat_entity
))
1452 maybe_present
= true;
1456 TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1457 = Has_Biased_Representation (gnat_entity
);
1459 /* This should be an unsigned type if the lower bound is constant
1460 and non-negative or if the base type is unsigned; a signed type
1462 TYPE_UNSIGNED (gnu_type
)
1463 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type
))
1464 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type
)) == INTEGER_CST
1465 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type
)) >= 0)
1466 || TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1467 || Is_Unsigned_Type (gnat_entity
));
1469 layout_type (gnu_type
);
1471 /* Inherit our alias set from what we're a subtype of. Subtypes
1472 are not different types and a pointer can designate any instance
1473 within a subtype hierarchy. */
1474 copy_alias_set (gnu_type
, TREE_TYPE (gnu_type
));
1476 /* If the type we are dealing with is to represent a packed array,
1477 we need to have the bits left justified on big-endian targets
1478 and right justified on little-endian targets. We also need to
1479 ensure that when the value is read (e.g. for comparison of two
1480 such values), we only get the good bits, since the unused bits
1481 are uninitialized. Both goals are accomplished by wrapping the
1482 modular value in an enclosing struct. */
1483 if (Is_Packed_Array_Type (gnat_entity
))
1485 tree gnu_field_type
= gnu_type
;
1488 TYPE_RM_SIZE_NUM (gnu_field_type
)
1489 = UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
);
1490 gnu_type
= make_node (RECORD_TYPE
);
1491 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "JM");
1492 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_field_type
);
1493 TYPE_USER_ALIGN (gnu_type
) = TYPE_USER_ALIGN (gnu_field_type
);
1494 TYPE_PACKED (gnu_type
) = 1;
1496 /* Create a stripped-down declaration of the original type, mainly
1498 create_type_decl (get_entity_name (gnat_entity
), gnu_field_type
,
1499 NULL
, true, debug_info_p
, gnat_entity
);
1501 /* Don't notify the field as "addressable", since we won't be taking
1502 it's address and it would prevent create_field_decl from making a
1504 gnu_field
= create_field_decl (get_identifier ("OBJECT"),
1505 gnu_field_type
, gnu_type
, 1, 0, 0, 0);
1507 finish_record_type (gnu_type
, gnu_field
, 0, false);
1508 TYPE_JUSTIFIED_MODULAR_P (gnu_type
) = 1;
1509 SET_TYPE_ADA_SIZE (gnu_type
, bitsize_int (esize
));
1511 copy_alias_set (gnu_type
, gnu_field_type
);
1516 case E_Floating_Point_Type
:
1517 /* If this is a VAX floating-point type, use an integer of the proper
1518 size. All the operations will be handled with ASM statements. */
1519 if (Vax_Float (gnat_entity
))
1521 gnu_type
= make_signed_type (esize
);
1522 TYPE_VAX_FLOATING_POINT_P (gnu_type
) = 1;
1523 SET_TYPE_DIGITS_VALUE (gnu_type
,
1524 UI_To_gnu (Digits_Value (gnat_entity
),
1529 /* The type of the Low and High bounds can be our type if this is
1530 a type from Standard, so set them at the end of the function. */
1531 gnu_type
= make_node (REAL_TYPE
);
1532 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1533 layout_type (gnu_type
);
1536 case E_Floating_Point_Subtype
:
1537 if (Vax_Float (gnat_entity
))
1539 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1545 && Present (Ancestor_Subtype (gnat_entity
))
1546 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1547 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1548 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1549 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1552 gnu_type
= make_node (REAL_TYPE
);
1553 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1554 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1556 TYPE_MIN_VALUE (gnu_type
)
1557 = convert (TREE_TYPE (gnu_type
),
1558 elaborate_expression (Type_Low_Bound (gnat_entity
),
1559 gnat_entity
, get_identifier ("L"),
1561 Needs_Debug_Info (gnat_entity
)));
1563 TYPE_MAX_VALUE (gnu_type
)
1564 = convert (TREE_TYPE (gnu_type
),
1565 elaborate_expression (Type_High_Bound (gnat_entity
),
1566 gnat_entity
, get_identifier ("U"),
1568 Needs_Debug_Info (gnat_entity
)));
1570 /* One of the above calls might have caused us to be elaborated,
1571 so don't blow up if so. */
1572 if (present_gnu_tree (gnat_entity
))
1574 maybe_present
= true;
1578 layout_type (gnu_type
);
1580 /* Inherit our alias set from what we're a subtype of, as for
1581 integer subtypes. */
1582 copy_alias_set (gnu_type
, TREE_TYPE (gnu_type
));
1586 /* Array and String Types and Subtypes
1588 Unconstrained array types are represented by E_Array_Type and
1589 constrained array types are represented by E_Array_Subtype. There
1590 are no actual objects of an unconstrained array type; all we have
1591 are pointers to that type.
1593 The following fields are defined on array types and subtypes:
1595 Component_Type Component type of the array.
1596 Number_Dimensions Number of dimensions (an int).
1597 First_Index Type of first index. */
1602 tree gnu_template_fields
= NULL_TREE
;
1603 tree gnu_template_type
= make_node (RECORD_TYPE
);
1604 tree gnu_ptr_template
= build_pointer_type (gnu_template_type
);
1605 tree gnu_fat_type
= make_node (RECORD_TYPE
);
1606 int ndim
= Number_Dimensions (gnat_entity
);
1608 = (Convention (gnat_entity
) == Convention_Fortran
) ? ndim
- 1 : 0;
1610 = (Convention (gnat_entity
) == Convention_Fortran
) ? - 1 : 1;
1611 tree
*gnu_index_types
= (tree
*) alloca (ndim
* sizeof (tree
*));
1612 tree
*gnu_temp_fields
= (tree
*) alloca (ndim
* sizeof (tree
*));
1613 tree gnu_comp_size
= 0;
1614 tree gnu_max_size
= size_one_node
;
1615 tree gnu_max_size_unit
;
1617 Entity_Id gnat_ind_subtype
;
1618 Entity_Id gnat_ind_base_subtype
;
1619 tree gnu_template_reference
;
1622 TYPE_NAME (gnu_template_type
)
1623 = create_concat_name (gnat_entity
, "XUB");
1625 /* Make a node for the array. If we are not defining the array
1626 suppress expanding incomplete types. */
1627 gnu_type
= make_node (UNCONSTRAINED_ARRAY_TYPE
);
1630 defer_incomplete_level
++, this_deferred
= true;
1632 /* Build the fat pointer type. Use a "void *" object instead of
1633 a pointer to the array type since we don't have the array type
1634 yet (it will reference the fat pointer via the bounds). */
1635 tem
= chainon (chainon (NULL_TREE
,
1636 create_field_decl (get_identifier ("P_ARRAY"),
1638 gnu_fat_type
, 0, 0, 0, 0)),
1639 create_field_decl (get_identifier ("P_BOUNDS"),
1641 gnu_fat_type
, 0, 0, 0, 0));
1643 /* Make sure we can put this into a register. */
1644 TYPE_ALIGN (gnu_fat_type
) = MIN (BIGGEST_ALIGNMENT
, 2 * POINTER_SIZE
);
1646 /* Do not finalize this record type since the types of its fields
1647 are still incomplete at this point. */
1648 finish_record_type (gnu_fat_type
, tem
, 0, true);
1649 TYPE_IS_FAT_POINTER_P (gnu_fat_type
) = 1;
1651 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1652 is the fat pointer. This will be used to access the individual
1653 fields once we build them. */
1654 tem
= build3 (COMPONENT_REF
, gnu_ptr_template
,
1655 build0 (PLACEHOLDER_EXPR
, gnu_fat_type
),
1656 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type
)), NULL_TREE
);
1657 gnu_template_reference
1658 = build_unary_op (INDIRECT_REF
, gnu_template_type
, tem
);
1659 TREE_READONLY (gnu_template_reference
) = 1;
1661 /* Now create the GCC type for each index and add the fields for
1662 that index to the template. */
1663 for (index
= firstdim
, gnat_ind_subtype
= First_Index (gnat_entity
),
1664 gnat_ind_base_subtype
1665 = First_Index (Implementation_Base_Type (gnat_entity
));
1666 index
< ndim
&& index
>= 0;
1668 gnat_ind_subtype
= Next_Index (gnat_ind_subtype
),
1669 gnat_ind_base_subtype
= Next_Index (gnat_ind_base_subtype
))
1671 char field_name
[10];
1672 tree gnu_ind_subtype
1673 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype
)));
1674 tree gnu_base_subtype
1675 = get_unpadded_type (Etype (gnat_ind_base_subtype
));
1677 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_subtype
));
1679 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_subtype
));
1680 tree gnu_min_field
, gnu_max_field
, gnu_min
, gnu_max
;
1682 /* Make the FIELD_DECLs for the minimum and maximum of this
1683 type and then make extractions of that field from the
1685 sprintf (field_name
, "LB%d", index
);
1686 gnu_min_field
= create_field_decl (get_identifier (field_name
),
1688 gnu_template_type
, 0, 0, 0, 0);
1689 field_name
[0] = 'U';
1690 gnu_max_field
= create_field_decl (get_identifier (field_name
),
1692 gnu_template_type
, 0, 0, 0, 0);
1694 Sloc_to_locus (Sloc (gnat_entity
),
1695 &DECL_SOURCE_LOCATION (gnu_min_field
));
1696 Sloc_to_locus (Sloc (gnat_entity
),
1697 &DECL_SOURCE_LOCATION (gnu_max_field
));
1698 gnu_temp_fields
[index
] = chainon (gnu_min_field
, gnu_max_field
);
1700 /* We can't use build_component_ref here since the template
1701 type isn't complete yet. */
1702 gnu_min
= build3 (COMPONENT_REF
, gnu_ind_subtype
,
1703 gnu_template_reference
, gnu_min_field
,
1705 gnu_max
= build3 (COMPONENT_REF
, gnu_ind_subtype
,
1706 gnu_template_reference
, gnu_max_field
,
1708 TREE_READONLY (gnu_min
) = TREE_READONLY (gnu_max
) = 1;
1710 /* Make a range type with the new ranges, but using
1711 the Ada subtype. Then we convert to sizetype. */
1712 gnu_index_types
[index
]
1713 = create_index_type (convert (sizetype
, gnu_min
),
1714 convert (sizetype
, gnu_max
),
1715 build_range_type (gnu_ind_subtype
,
1718 /* Update the maximum size of the array, in elements. */
1720 = size_binop (MULT_EXPR
, gnu_max_size
,
1721 size_binop (PLUS_EXPR
, size_one_node
,
1722 size_binop (MINUS_EXPR
, gnu_base_max
,
1725 TYPE_NAME (gnu_index_types
[index
])
1726 = create_concat_name (gnat_entity
, field_name
);
1729 for (index
= 0; index
< ndim
; index
++)
1731 = chainon (gnu_template_fields
, gnu_temp_fields
[index
]);
1733 /* Install all the fields into the template. */
1734 finish_record_type (gnu_template_type
, gnu_template_fields
, 0, false);
1735 TYPE_READONLY (gnu_template_type
) = 1;
1737 /* Now make the array of arrays and update the pointer to the array
1738 in the fat pointer. Note that it is the first field. */
1739 tem
= gnat_to_gnu_type (Component_Type (gnat_entity
));
1741 /* Get and validate any specified Component_Size, but if Packed,
1742 ignore it since the front end will have taken care of it. */
1744 = validate_size (Component_Size (gnat_entity
), tem
,
1746 (Is_Bit_Packed_Array (gnat_entity
)
1747 ? TYPE_DECL
: VAR_DECL
),
1748 true, Has_Component_Size_Clause (gnat_entity
));
1750 if (Has_Atomic_Components (gnat_entity
))
1751 check_ok_for_atomic (tem
, gnat_entity
, true);
1753 /* If the component type is a RECORD_TYPE that has a self-referential
1754 size, use the maxium size. */
1755 if (!gnu_comp_size
&& TREE_CODE (tem
) == RECORD_TYPE
1756 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem
)))
1757 gnu_comp_size
= max_size (TYPE_SIZE (tem
), true);
1759 if (!Is_Bit_Packed_Array (gnat_entity
) && gnu_comp_size
)
1762 tem
= make_type_from_size (tem
, gnu_comp_size
, false);
1764 tem
= maybe_pad_type (tem
, gnu_comp_size
, 0, gnat_entity
,
1765 "C_PAD", false, definition
, true);
1766 /* If a padding record was made, declare it now since it will
1767 never be declared otherwise. This is necessary in order to
1768 ensure that its subtrees are properly marked. */
1769 if (tem
!= orig_tem
)
1770 create_type_decl (TYPE_NAME (tem
), tem
, NULL
, true, false,
1774 if (Has_Volatile_Components (gnat_entity
))
1775 tem
= build_qualified_type (tem
,
1776 TYPE_QUALS (tem
) | TYPE_QUAL_VOLATILE
);
1778 /* If Component_Size is not already specified, annotate it with the
1779 size of the component. */
1780 if (Unknown_Component_Size (gnat_entity
))
1781 Set_Component_Size (gnat_entity
, annotate_value (TYPE_SIZE (tem
)));
1783 gnu_max_size_unit
= size_binop (MAX_EXPR
, size_zero_node
,
1784 size_binop (MULT_EXPR
, gnu_max_size
,
1785 TYPE_SIZE_UNIT (tem
)));
1786 gnu_max_size
= size_binop (MAX_EXPR
, bitsize_zero_node
,
1787 size_binop (MULT_EXPR
,
1788 convert (bitsizetype
,
1792 for (index
= ndim
- 1; index
>= 0; index
--)
1794 tem
= build_array_type (tem
, gnu_index_types
[index
]);
1795 TYPE_MULTI_ARRAY_P (tem
) = (index
> 0);
1796 if (array_type_has_nonaliased_component (gnat_entity
, tem
))
1797 TYPE_NONALIASED_COMPONENT (tem
) = 1;
1800 /* If an alignment is specified, use it if valid. But ignore it for
1801 types that represent the unpacked base type for packed arrays. If
1802 the alignment was requested with an explicit user alignment clause,
1804 if (No (Packed_Array_Type (gnat_entity
))
1805 && Known_Alignment (gnat_entity
))
1807 gcc_assert (Present (Alignment (gnat_entity
)));
1809 = validate_alignment (Alignment (gnat_entity
), gnat_entity
,
1811 if (Present (Alignment_Clause (gnat_entity
)))
1812 TYPE_USER_ALIGN (tem
) = 1;
1815 TYPE_CONVENTION_FORTRAN_P (tem
)
1816 = (Convention (gnat_entity
) == Convention_Fortran
);
1817 TREE_TYPE (TYPE_FIELDS (gnu_fat_type
)) = build_pointer_type (tem
);
1819 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1820 corresponding fat pointer. */
1821 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
)
1822 = TYPE_REFERENCE_TO (gnu_type
) = gnu_fat_type
;
1823 TYPE_MODE (gnu_type
) = BLKmode
;
1824 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (tem
);
1825 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type
, gnu_type
);
1827 /* If the maximum size doesn't overflow, use it. */
1828 if (TREE_CODE (gnu_max_size
) == INTEGER_CST
1829 && !TREE_OVERFLOW (gnu_max_size
))
1831 = size_binop (MIN_EXPR
, gnu_max_size
, TYPE_SIZE (tem
));
1832 if (TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
1833 && !TREE_OVERFLOW (gnu_max_size_unit
))
1834 TYPE_SIZE_UNIT (tem
)
1835 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
1836 TYPE_SIZE_UNIT (tem
));
1838 create_type_decl (create_concat_name (gnat_entity
, "XUA"),
1839 tem
, NULL
, !Comes_From_Source (gnat_entity
),
1840 debug_info_p
, gnat_entity
);
1842 /* Give the fat pointer type a name. */
1843 create_type_decl (create_concat_name (gnat_entity
, "XUP"),
1844 gnu_fat_type
, NULL
, !Comes_From_Source (gnat_entity
),
1845 debug_info_p
, gnat_entity
);
1847 /* Create the type to be used as what a thin pointer designates: an
1848 record type for the object and its template with the field offsets
1849 shifted to have the template at a negative offset. */
1850 tem
= build_unc_object_type (gnu_template_type
, tem
,
1851 create_concat_name (gnat_entity
, "XUT"));
1852 shift_unc_components_for_thin_pointers (tem
);
1854 SET_TYPE_UNCONSTRAINED_ARRAY (tem
, gnu_type
);
1855 TYPE_OBJECT_RECORD_TYPE (gnu_type
) = tem
;
1857 /* Give the thin pointer type a name. */
1858 create_type_decl (create_concat_name (gnat_entity
, "XUX"),
1859 build_pointer_type (tem
), NULL
,
1860 !Comes_From_Source (gnat_entity
), debug_info_p
,
1865 case E_String_Subtype
:
1866 case E_Array_Subtype
:
1868 /* This is the actual data type for array variables. Multidimensional
1869 arrays are implemented in the gnu tree as arrays of arrays. Note
1870 that for the moment arrays which have sparse enumeration subtypes as
1871 index components create sparse arrays, which is obviously space
1872 inefficient but so much easier to code for now.
1874 Also note that the subtype never refers to the unconstrained
1875 array type, which is somewhat at variance with Ada semantics.
1877 First check to see if this is simply a renaming of the array
1878 type. If so, the result is the array type. */
1880 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1881 if (!Is_Constrained (gnat_entity
))
1886 int array_dim
= Number_Dimensions (gnat_entity
);
1888 = ((Convention (gnat_entity
) == Convention_Fortran
)
1889 ? array_dim
- 1 : 0);
1891 = (Convention (gnat_entity
) == Convention_Fortran
) ? -1 : 1;
1892 Entity_Id gnat_ind_subtype
;
1893 Entity_Id gnat_ind_base_subtype
;
1894 tree gnu_base_type
= gnu_type
;
1895 tree
*gnu_index_type
= (tree
*) alloca (array_dim
* sizeof (tree
*));
1896 tree gnu_comp_size
= NULL_TREE
;
1897 tree gnu_max_size
= size_one_node
;
1898 tree gnu_max_size_unit
;
1899 bool need_index_type_struct
= false;
1900 bool max_overflow
= false;
1902 /* First create the gnu types for each index. Create types for
1903 debugging information to point to the index types if the
1904 are not integer types, have variable bounds, or are
1905 wider than sizetype. */
1907 for (index
= first_dim
, gnat_ind_subtype
= First_Index (gnat_entity
),
1908 gnat_ind_base_subtype
1909 = First_Index (Implementation_Base_Type (gnat_entity
));
1910 index
< array_dim
&& index
>= 0;
1912 gnat_ind_subtype
= Next_Index (gnat_ind_subtype
),
1913 gnat_ind_base_subtype
= Next_Index (gnat_ind_base_subtype
))
1915 tree gnu_index_subtype
1916 = get_unpadded_type (Etype (gnat_ind_subtype
));
1918 = convert (sizetype
, TYPE_MIN_VALUE (gnu_index_subtype
));
1920 = convert (sizetype
, TYPE_MAX_VALUE (gnu_index_subtype
));
1921 tree gnu_base_subtype
1922 = get_unpadded_type (Etype (gnat_ind_base_subtype
));
1924 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_subtype
));
1926 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_subtype
));
1927 tree gnu_base_type
= get_base_type (gnu_base_subtype
);
1928 tree gnu_base_base_min
1929 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_type
));
1930 tree gnu_base_base_max
1931 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_type
));
1935 /* If the minimum and maximum values both overflow in
1936 SIZETYPE, but the difference in the original type
1937 does not overflow in SIZETYPE, ignore the overflow
1939 if ((TYPE_PRECISION (gnu_index_subtype
)
1940 > TYPE_PRECISION (sizetype
)
1941 || TYPE_UNSIGNED (gnu_index_subtype
)
1942 != TYPE_UNSIGNED (sizetype
))
1943 && TREE_CODE (gnu_min
) == INTEGER_CST
1944 && TREE_CODE (gnu_max
) == INTEGER_CST
1945 && TREE_OVERFLOW (gnu_min
) && TREE_OVERFLOW (gnu_max
)
1947 (fold_build2 (MINUS_EXPR
, gnu_index_subtype
,
1948 TYPE_MAX_VALUE (gnu_index_subtype
),
1949 TYPE_MIN_VALUE (gnu_index_subtype
)))))
1951 TREE_OVERFLOW (gnu_min
) = 0;
1952 TREE_OVERFLOW (gnu_max
) = 0;
1955 /* Similarly, if the range is null, use bounds of 1..0 for
1956 the sizetype bounds. */
1957 else if ((TYPE_PRECISION (gnu_index_subtype
)
1958 > TYPE_PRECISION (sizetype
)
1959 || TYPE_UNSIGNED (gnu_index_subtype
)
1960 != TYPE_UNSIGNED (sizetype
))
1961 && TREE_CODE (gnu_min
) == INTEGER_CST
1962 && TREE_CODE (gnu_max
) == INTEGER_CST
1963 && (TREE_OVERFLOW (gnu_min
) || TREE_OVERFLOW (gnu_max
))
1964 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype
),
1965 TYPE_MIN_VALUE (gnu_index_subtype
)))
1966 gnu_min
= size_one_node
, gnu_max
= size_zero_node
;
1968 /* Now compute the size of this bound. We need to provide
1969 GCC with an upper bound to use but have to deal with the
1970 "superflat" case. There are three ways to do this. If we
1971 can prove that the array can never be superflat, we can
1972 just use the high bound of the index subtype. If we can
1973 prove that the low bound minus one can't overflow, we
1974 can do this as MAX (hb, lb - 1). Otherwise, we have to use
1975 the expression hb >= lb ? hb : lb - 1. */
1976 gnu_high
= size_binop (MINUS_EXPR
, gnu_min
, size_one_node
);
1978 /* See if the base array type is already flat. If it is, we
1979 are probably compiling an ACVC test, but it will cause the
1980 code below to malfunction if we don't handle it specially. */
1981 if (TREE_CODE (gnu_base_min
) == INTEGER_CST
1982 && TREE_CODE (gnu_base_max
) == INTEGER_CST
1983 && !TREE_OVERFLOW (gnu_base_min
)
1984 && !TREE_OVERFLOW (gnu_base_max
)
1985 && tree_int_cst_lt (gnu_base_max
, gnu_base_min
))
1986 gnu_high
= size_zero_node
, gnu_min
= size_one_node
;
1988 /* If gnu_high is now an integer which overflowed, the array
1989 cannot be superflat. */
1990 else if (TREE_CODE (gnu_high
) == INTEGER_CST
1991 && TREE_OVERFLOW (gnu_high
))
1993 else if (TYPE_UNSIGNED (gnu_base_subtype
)
1994 || TREE_CODE (gnu_high
) == INTEGER_CST
)
1995 gnu_high
= size_binop (MAX_EXPR
, gnu_max
, gnu_high
);
1999 (sizetype
, build_binary_op (GE_EXPR
, integer_type_node
,
2003 gnu_index_type
[index
]
2004 = create_index_type (gnu_min
, gnu_high
, gnu_index_subtype
,
2007 /* Also compute the maximum size of the array. Here we
2008 see if any constraint on the index type of the base type
2009 can be used in the case of self-referential bound on
2010 the index type of the subtype. We look for a non-"infinite"
2011 and non-self-referential bound from any type involved and
2012 handle each bound separately. */
2014 if ((TREE_CODE (gnu_min
) == INTEGER_CST
2015 && !TREE_OVERFLOW (gnu_min
)
2016 && !operand_equal_p (gnu_min
, gnu_base_base_min
, 0))
2017 || !CONTAINS_PLACEHOLDER_P (gnu_min
)
2018 || !(TREE_CODE (gnu_base_min
) == INTEGER_CST
2019 && !TREE_OVERFLOW (gnu_base_min
)))
2020 gnu_base_min
= gnu_min
;
2022 if ((TREE_CODE (gnu_max
) == INTEGER_CST
2023 && !TREE_OVERFLOW (gnu_max
)
2024 && !operand_equal_p (gnu_max
, gnu_base_base_max
, 0))
2025 || !CONTAINS_PLACEHOLDER_P (gnu_max
)
2026 || !(TREE_CODE (gnu_base_max
) == INTEGER_CST
2027 && !TREE_OVERFLOW (gnu_base_max
)))
2028 gnu_base_max
= gnu_max
;
2030 if ((TREE_CODE (gnu_base_min
) == INTEGER_CST
2031 && TREE_OVERFLOW (gnu_base_min
))
2032 || operand_equal_p (gnu_base_min
, gnu_base_base_min
, 0)
2033 || (TREE_CODE (gnu_base_max
) == INTEGER_CST
2034 && TREE_OVERFLOW (gnu_base_max
))
2035 || operand_equal_p (gnu_base_max
, gnu_base_base_max
, 0))
2036 max_overflow
= true;
2038 gnu_base_min
= size_binop (MAX_EXPR
, gnu_base_min
, gnu_min
);
2039 gnu_base_max
= size_binop (MIN_EXPR
, gnu_base_max
, gnu_max
);
2042 = size_binop (MAX_EXPR
,
2043 size_binop (PLUS_EXPR
, size_one_node
,
2044 size_binop (MINUS_EXPR
, gnu_base_max
,
2048 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2049 && TREE_OVERFLOW (gnu_this_max
))
2050 max_overflow
= true;
2053 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2055 if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype
))
2056 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype
))
2058 || TREE_CODE (gnu_index_subtype
) != INTEGER_TYPE
2059 || (TREE_TYPE (gnu_index_subtype
)
2060 && (TREE_CODE (TREE_TYPE (gnu_index_subtype
))
2062 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype
)
2063 || (TYPE_PRECISION (gnu_index_subtype
)
2064 > TYPE_PRECISION (sizetype
)))
2065 need_index_type_struct
= true;
2068 /* Then flatten: create the array of arrays. */
2070 gnu_type
= gnat_to_gnu_type (Component_Type (gnat_entity
));
2072 /* One of the above calls might have caused us to be elaborated,
2073 so don't blow up if so. */
2074 if (present_gnu_tree (gnat_entity
))
2076 maybe_present
= true;
2080 /* Get and validate any specified Component_Size, but if Packed,
2081 ignore it since the front end will have taken care of it. */
2083 = validate_size (Component_Size (gnat_entity
), gnu_type
,
2085 (Is_Bit_Packed_Array (gnat_entity
)
2086 ? TYPE_DECL
: VAR_DECL
),
2087 true, Has_Component_Size_Clause (gnat_entity
));
2089 /* If the component type is a RECORD_TYPE that has a self-referential
2090 size, use the maxium size. */
2091 if (!gnu_comp_size
&& TREE_CODE (gnu_type
) == RECORD_TYPE
2092 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
2093 gnu_comp_size
= max_size (TYPE_SIZE (gnu_type
), true);
2095 if (!Is_Bit_Packed_Array (gnat_entity
) && gnu_comp_size
)
2098 gnu_type
= make_type_from_size (gnu_type
, gnu_comp_size
, false);
2099 orig_gnu_type
= gnu_type
;
2100 gnu_type
= maybe_pad_type (gnu_type
, gnu_comp_size
, 0,
2101 gnat_entity
, "C_PAD", false,
2103 /* If a padding record was made, declare it now since it will
2104 never be declared otherwise. This is necessary in order to
2105 ensure that its subtrees are properly marked. */
2106 if (gnu_type
!= orig_gnu_type
)
2107 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, NULL
, true,
2108 false, gnat_entity
);
2111 if (Has_Volatile_Components (Base_Type (gnat_entity
)))
2112 gnu_type
= build_qualified_type (gnu_type
,
2113 (TYPE_QUALS (gnu_type
)
2114 | TYPE_QUAL_VOLATILE
));
2116 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2117 TYPE_SIZE_UNIT (gnu_type
));
2118 gnu_max_size
= size_binop (MULT_EXPR
,
2119 convert (bitsizetype
, gnu_max_size
),
2120 TYPE_SIZE (gnu_type
));
2122 for (index
= array_dim
- 1; index
>= 0; index
--)
2124 gnu_type
= build_array_type (gnu_type
, gnu_index_type
[index
]);
2125 TYPE_MULTI_ARRAY_P (gnu_type
) = (index
> 0);
2126 if (array_type_has_nonaliased_component (gnat_entity
, gnu_type
))
2127 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2130 /* If we are at file level and this is a multi-dimensional array, we
2131 need to make a variable corresponding to the stride of the
2132 inner dimensions. */
2133 if (global_bindings_p () && array_dim
> 1)
2135 tree gnu_str_name
= get_identifier ("ST");
2138 for (gnu_arr_type
= TREE_TYPE (gnu_type
);
2139 TREE_CODE (gnu_arr_type
) == ARRAY_TYPE
;
2140 gnu_arr_type
= TREE_TYPE (gnu_arr_type
),
2141 gnu_str_name
= concat_id_with_name (gnu_str_name
, "ST"))
2143 tree eltype
= TREE_TYPE (gnu_arr_type
);
2145 TYPE_SIZE (gnu_arr_type
)
2146 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
2147 TYPE_SIZE (gnu_arr_type
),
2148 gnu_str_name
, definition
, 0);
2150 /* ??? For now, store the size as a multiple of the
2151 alignment of the element type in bytes so that we
2152 can see the alignment from the tree. */
2153 TYPE_SIZE_UNIT (gnu_arr_type
)
2155 (MULT_EXPR
, sizetype
,
2156 elaborate_expression_1
2157 (gnat_entity
, gnat_entity
,
2158 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
2159 TYPE_SIZE_UNIT (gnu_arr_type
),
2160 size_int (TYPE_ALIGN (eltype
)
2162 concat_id_with_name (gnu_str_name
, "A_U"),
2164 size_int (TYPE_ALIGN (eltype
) / BITS_PER_UNIT
));
2166 /* ??? create_type_decl is not invoked on the inner types so
2167 the MULT_EXPR node built above will never be marked. */
2168 TREE_VISITED (TYPE_SIZE_UNIT (gnu_arr_type
)) = 1;
2172 /* If we need to write out a record type giving the names of
2173 the bounds, do it now. */
2174 if (need_index_type_struct
&& debug_info_p
)
2176 tree gnu_bound_rec_type
= make_node (RECORD_TYPE
);
2177 tree gnu_field_list
= NULL_TREE
;
2180 TYPE_NAME (gnu_bound_rec_type
)
2181 = create_concat_name (gnat_entity
, "XA");
2183 for (index
= array_dim
- 1; index
>= 0; index
--)
2186 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type
[index
]));
2188 if (TREE_CODE (gnu_type_name
) == TYPE_DECL
)
2189 gnu_type_name
= DECL_NAME (gnu_type_name
);
2191 gnu_field
= create_field_decl (gnu_type_name
,
2194 0, NULL_TREE
, NULL_TREE
, 0);
2195 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2196 gnu_field_list
= gnu_field
;
2199 finish_record_type (gnu_bound_rec_type
, gnu_field_list
,
2203 TYPE_CONVENTION_FORTRAN_P (gnu_type
)
2204 = (Convention (gnat_entity
) == Convention_Fortran
);
2205 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
2206 = Is_Packed_Array_Type (gnat_entity
);
2208 /* If our size depends on a placeholder and the maximum size doesn't
2209 overflow, use it. */
2210 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
2211 && !(TREE_CODE (gnu_max_size
) == INTEGER_CST
2212 && TREE_OVERFLOW (gnu_max_size
))
2213 && !(TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2214 && TREE_OVERFLOW (gnu_max_size_unit
))
2217 TYPE_SIZE (gnu_type
) = size_binop (MIN_EXPR
, gnu_max_size
,
2218 TYPE_SIZE (gnu_type
));
2219 TYPE_SIZE_UNIT (gnu_type
)
2220 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2221 TYPE_SIZE_UNIT (gnu_type
));
2224 /* Set our alias set to that of our base type. This gives all
2225 array subtypes the same alias set. */
2226 copy_alias_set (gnu_type
, gnu_base_type
);
2229 /* If this is a packed type, make this type the same as the packed
2230 array type, but do some adjusting in the type first. */
2232 if (Present (Packed_Array_Type (gnat_entity
)))
2234 Entity_Id gnat_index
;
2235 tree gnu_inner_type
;
2237 /* First finish the type we had been making so that we output
2238 debugging information for it */
2240 = build_qualified_type (gnu_type
,
2241 (TYPE_QUALS (gnu_type
)
2242 | (TYPE_QUAL_VOLATILE
2243 * Treat_As_Volatile (gnat_entity
))));
2244 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
2245 !Comes_From_Source (gnat_entity
),
2246 debug_info_p
, gnat_entity
);
2247 if (!Comes_From_Source (gnat_entity
))
2248 DECL_ARTIFICIAL (gnu_decl
) = 1;
2250 /* Save it as our equivalent in case the call below elaborates
2252 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2254 gnu_decl
= gnat_to_gnu_entity (Packed_Array_Type (gnat_entity
),
2256 this_made_decl
= true;
2257 gnu_type
= TREE_TYPE (gnu_decl
);
2258 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
2260 gnu_inner_type
= gnu_type
;
2261 while (TREE_CODE (gnu_inner_type
) == RECORD_TYPE
2262 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type
)
2263 || TYPE_IS_PADDING_P (gnu_inner_type
)))
2264 gnu_inner_type
= TREE_TYPE (TYPE_FIELDS (gnu_inner_type
));
2266 /* We need to point the type we just made to our index type so
2267 the actual bounds can be put into a template. */
2269 if ((TREE_CODE (gnu_inner_type
) == ARRAY_TYPE
2270 && !TYPE_ACTUAL_BOUNDS (gnu_inner_type
))
2271 || (TREE_CODE (gnu_inner_type
) == INTEGER_TYPE
2272 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type
)))
2274 if (TREE_CODE (gnu_inner_type
) == INTEGER_TYPE
)
2276 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2277 If it is, we need to make another type. */
2278 if (TYPE_MODULAR_P (gnu_inner_type
))
2282 gnu_subtype
= make_node (INTEGER_TYPE
);
2284 TREE_TYPE (gnu_subtype
) = gnu_inner_type
;
2285 TYPE_MIN_VALUE (gnu_subtype
)
2286 = TYPE_MIN_VALUE (gnu_inner_type
);
2287 TYPE_MAX_VALUE (gnu_subtype
)
2288 = TYPE_MAX_VALUE (gnu_inner_type
);
2289 TYPE_PRECISION (gnu_subtype
)
2290 = TYPE_PRECISION (gnu_inner_type
);
2291 TYPE_UNSIGNED (gnu_subtype
)
2292 = TYPE_UNSIGNED (gnu_inner_type
);
2293 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
2294 layout_type (gnu_subtype
);
2296 gnu_inner_type
= gnu_subtype
;
2299 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type
) = 1;
2302 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type
, NULL_TREE
);
2304 for (gnat_index
= First_Index (gnat_entity
);
2305 Present (gnat_index
); gnat_index
= Next_Index (gnat_index
))
2306 SET_TYPE_ACTUAL_BOUNDS
2308 tree_cons (NULL_TREE
,
2309 get_unpadded_type (Etype (gnat_index
)),
2310 TYPE_ACTUAL_BOUNDS (gnu_inner_type
)));
2312 if (Convention (gnat_entity
) != Convention_Fortran
)
2313 SET_TYPE_ACTUAL_BOUNDS
2315 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type
)));
2317 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2318 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
2319 TREE_TYPE (TYPE_FIELDS (gnu_type
)) = gnu_inner_type
;
2323 /* Abort if packed array with no packed array type field set. */
2325 gcc_assert (!Is_Packed (gnat_entity
));
2329 case E_String_Literal_Subtype
:
2330 /* Create the type for a string literal. */
2332 Entity_Id gnat_full_type
2333 = (IN (Ekind (Etype (gnat_entity
)), Private_Kind
)
2334 && Present (Full_View (Etype (gnat_entity
)))
2335 ? Full_View (Etype (gnat_entity
)) : Etype (gnat_entity
));
2336 tree gnu_string_type
= get_unpadded_type (gnat_full_type
);
2337 tree gnu_string_array_type
2338 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type
))));
2339 tree gnu_string_index_type
2340 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2341 (TYPE_DOMAIN (gnu_string_array_type
))));
2342 tree gnu_lower_bound
2343 = convert (gnu_string_index_type
,
2344 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity
)));
2345 int length
= UI_To_Int (String_Literal_Length (gnat_entity
));
2346 tree gnu_length
= ssize_int (length
- 1);
2347 tree gnu_upper_bound
2348 = build_binary_op (PLUS_EXPR
, gnu_string_index_type
,
2350 convert (gnu_string_index_type
, gnu_length
));
2352 = build_range_type (gnu_string_index_type
,
2353 gnu_lower_bound
, gnu_upper_bound
);
2355 = create_index_type (convert (sizetype
,
2356 TYPE_MIN_VALUE (gnu_range_type
)),
2358 TYPE_MAX_VALUE (gnu_range_type
)),
2359 gnu_range_type
, gnat_entity
);
2362 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity
)),
2364 copy_alias_set (gnu_type
, gnu_string_type
);
2368 /* Record Types and Subtypes
2370 The following fields are defined on record types:
2372 Has_Discriminants True if the record has discriminants
2373 First_Discriminant Points to head of list of discriminants
2374 First_Entity Points to head of list of fields
2375 Is_Tagged_Type True if the record is tagged
2377 Implementation of Ada records and discriminated records:
2379 A record type definition is transformed into the equivalent of a C
2380 struct definition. The fields that are the discriminants which are
2381 found in the Full_Type_Declaration node and the elements of the
2382 Component_List found in the Record_Type_Definition node. The
2383 Component_List can be a recursive structure since each Variant of
2384 the Variant_Part of the Component_List has a Component_List.
2386 Processing of a record type definition comprises starting the list of
2387 field declarations here from the discriminants and the calling the
2388 function components_to_record to add the rest of the fields from the
2389 component list and return the gnu type node. The function
2390 components_to_record will call itself recursively as it traverses
2394 if (Has_Complex_Representation (gnat_entity
))
2397 = build_complex_type
2399 (Etype (Defining_Entity
2400 (First (Component_Items
2403 (Declaration_Node (gnat_entity
)))))))));
2409 Node_Id full_definition
= Declaration_Node (gnat_entity
);
2410 Node_Id record_definition
= Type_Definition (full_definition
);
2411 Entity_Id gnat_field
;
2413 tree gnu_field_list
= NULL_TREE
;
2414 tree gnu_get_parent
;
2415 /* Set PACKED in keeping with gnat_to_gnu_field. */
2417 = Is_Packed (gnat_entity
)
2419 : Component_Alignment (gnat_entity
) == Calign_Storage_Unit
2421 : (Known_Alignment (gnat_entity
)
2422 || (Strict_Alignment (gnat_entity
)
2423 && Known_Static_Esize (gnat_entity
)))
2426 bool has_rep
= Has_Specified_Layout (gnat_entity
);
2427 bool all_rep
= has_rep
;
2429 = (Is_Tagged_Type (gnat_entity
)
2430 && Nkind (record_definition
) == N_Derived_Type_Definition
);
2432 /* See if all fields have a rep clause. Stop when we find one
2434 for (gnat_field
= First_Entity (gnat_entity
);
2435 Present (gnat_field
) && all_rep
;
2436 gnat_field
= Next_Entity (gnat_field
))
2437 if ((Ekind (gnat_field
) == E_Component
2438 || Ekind (gnat_field
) == E_Discriminant
)
2439 && No (Component_Clause (gnat_field
)))
2442 /* If this is a record extension, go a level further to find the
2443 record definition. Also, verify we have a Parent_Subtype. */
2446 if (!type_annotate_only
2447 || Present (Record_Extension_Part (record_definition
)))
2448 record_definition
= Record_Extension_Part (record_definition
);
2450 gcc_assert (type_annotate_only
2451 || Present (Parent_Subtype (gnat_entity
)));
2454 /* Make a node for the record. If we are not defining the record,
2455 suppress expanding incomplete types. */
2456 gnu_type
= make_node (tree_code_for_record_type (gnat_entity
));
2457 TYPE_NAME (gnu_type
) = gnu_entity_id
;
2458 TYPE_PACKED (gnu_type
) = (packed
!= 0) || has_rep
;
2461 defer_incomplete_level
++, this_deferred
= true;
2463 /* If both a size and rep clause was specified, put the size in
2464 the record type now so that it can get the proper mode. */
2465 if (has_rep
&& Known_Esize (gnat_entity
))
2466 TYPE_SIZE (gnu_type
) = UI_To_gnu (Esize (gnat_entity
), sizetype
);
2468 /* Always set the alignment here so that it can be used to
2469 set the mode, if it is making the alignment stricter. If
2470 it is invalid, it will be checked again below. If this is to
2471 be Atomic, choose a default alignment of a word unless we know
2472 the size and it's smaller. */
2473 if (Known_Alignment (gnat_entity
))
2474 TYPE_ALIGN (gnu_type
)
2475 = validate_alignment (Alignment (gnat_entity
), gnat_entity
, 0);
2476 else if (Is_Atomic (gnat_entity
))
2477 TYPE_ALIGN (gnu_type
)
2478 = esize
>= BITS_PER_WORD
? BITS_PER_WORD
: ceil_alignment (esize
);
2479 /* If a type needs strict alignment, the minimum size will be the
2480 type size instead of the RM size (see validate_size). Cap the
2481 alignment, lest it causes this type size to become too large. */
2482 else if (Strict_Alignment (gnat_entity
)
2483 && Known_Static_Esize (gnat_entity
))
2485 unsigned int raw_size
= UI_To_Int (Esize (gnat_entity
));
2486 TYPE_ALIGN (gnu_type
)
2487 = MIN (BIGGEST_ALIGNMENT
, raw_size
& -raw_size
);
2490 TYPE_ALIGN (gnu_type
) = 0;
2492 /* If we have a Parent_Subtype, make a field for the parent. If
2493 this record has rep clauses, force the position to zero. */
2494 if (Present (Parent_Subtype (gnat_entity
)))
2496 Entity_Id gnat_parent
= Parent_Subtype (gnat_entity
);
2499 /* A major complexity here is that the parent subtype will
2500 reference our discriminants in its Discriminant_Constraint
2501 list. But those must reference the parent component of this
2502 record which is of the parent subtype we have not built yet!
2503 To break the circle we first build a dummy COMPONENT_REF which
2504 represents the "get to the parent" operation and initialize
2505 each of those discriminants to a COMPONENT_REF of the above
2506 dummy parent referencing the corresponding discriminant of the
2507 base type of the parent subtype. */
2508 gnu_get_parent
= build3 (COMPONENT_REF
, void_type_node
,
2509 build0 (PLACEHOLDER_EXPR
, gnu_type
),
2510 build_decl (FIELD_DECL
, NULL_TREE
,
2514 if (Has_Discriminants (gnat_entity
))
2515 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2516 Present (gnat_field
);
2517 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2518 if (Present (Corresponding_Discriminant (gnat_field
)))
2521 build3 (COMPONENT_REF
,
2522 get_unpadded_type (Etype (gnat_field
)),
2524 gnat_to_gnu_field_decl (Corresponding_Discriminant
2529 /* Then we build the parent subtype. */
2530 gnu_parent
= gnat_to_gnu_type (gnat_parent
);
2532 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2533 initially built. The discriminants must reference the fields
2534 of the parent subtype and not those of its base type for the
2535 placeholder machinery to properly work. */
2536 if (Has_Discriminants (gnat_entity
))
2537 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2538 Present (gnat_field
);
2539 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2540 if (Present (Corresponding_Discriminant (gnat_field
)))
2542 Entity_Id field
= Empty
;
2543 for (field
= First_Stored_Discriminant (gnat_parent
);
2545 field
= Next_Stored_Discriminant (field
))
2546 if (same_discriminant_p (gnat_field
, field
))
2548 gcc_assert (Present (field
));
2549 TREE_OPERAND (get_gnu_tree (gnat_field
), 1)
2550 = gnat_to_gnu_field_decl (field
);
2553 /* The "get to the parent" COMPONENT_REF must be given its
2555 TREE_TYPE (gnu_get_parent
) = gnu_parent
;
2557 /* ...and reference the _parent field of this record. */
2559 = create_field_decl (get_identifier
2560 (Get_Name_String (Name_uParent
)),
2561 gnu_parent
, gnu_type
, 0,
2562 has_rep
? TYPE_SIZE (gnu_parent
) : 0,
2563 has_rep
? bitsize_zero_node
: 0, 1);
2564 DECL_INTERNAL_P (gnu_field_list
) = 1;
2565 TREE_OPERAND (gnu_get_parent
, 1) = gnu_field_list
;
2568 /* Make the fields for the discriminants and put them into the record
2569 unless it's an Unchecked_Union. */
2570 if (Has_Discriminants (gnat_entity
))
2571 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2572 Present (gnat_field
);
2573 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2575 /* If this is a record extension and this discriminant
2576 is the renaming of another discriminant, we've already
2577 handled the discriminant above. */
2578 if (Present (Parent_Subtype (gnat_entity
))
2579 && Present (Corresponding_Discriminant (gnat_field
)))
2583 = gnat_to_gnu_field (gnat_field
, gnu_type
, packed
, definition
);
2585 /* Make an expression using a PLACEHOLDER_EXPR from the
2586 FIELD_DECL node just created and link that with the
2587 corresponding GNAT defining identifier. Then add to the
2589 save_gnu_tree (gnat_field
,
2590 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
2591 build0 (PLACEHOLDER_EXPR
,
2592 DECL_CONTEXT (gnu_field
)),
2593 gnu_field
, NULL_TREE
),
2596 if (!Is_Unchecked_Union (gnat_entity
))
2598 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2599 gnu_field_list
= gnu_field
;
2603 /* Put the discriminants into the record (backwards), so we can
2604 know the appropriate discriminant to use for the names of the
2606 TYPE_FIELDS (gnu_type
) = gnu_field_list
;
2608 /* Add the listed fields into the record and finish it up. */
2609 components_to_record (gnu_type
, Component_List (record_definition
),
2610 gnu_field_list
, packed
, definition
, NULL
,
2611 false, all_rep
, false,
2612 Is_Unchecked_Union (gnat_entity
));
2614 /* We used to remove the associations of the discriminants and
2615 _Parent for validity checking, but we may need them if there's
2616 Freeze_Node for a subtype used in this record. */
2617 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
2618 TYPE_BY_REFERENCE_P (gnu_type
) = Is_By_Reference_Type (gnat_entity
);
2620 /* If it is a tagged record force the type to BLKmode to insure
2621 that these objects will always be placed in memory. Do the
2622 same thing for limited record types. */
2623 if (Is_Tagged_Type (gnat_entity
) || Is_Limited_Record (gnat_entity
))
2624 TYPE_MODE (gnu_type
) = BLKmode
;
2626 /* If this is a derived type, we must make the alias set of this type
2627 the same as that of the type we are derived from. We assume here
2628 that the other type is already frozen. */
2629 if (Etype (gnat_entity
) != gnat_entity
2630 && !(Is_Private_Type (Etype (gnat_entity
))
2631 && Full_View (Etype (gnat_entity
)) == gnat_entity
))
2632 copy_alias_set (gnu_type
, gnat_to_gnu_type (Etype (gnat_entity
)));
2634 /* Fill in locations of fields. */
2635 annotate_rep (gnat_entity
, gnu_type
);
2637 /* If there are any entities in the chain corresponding to
2638 components that we did not elaborate, ensure we elaborate their
2639 types if they are Itypes. */
2640 for (gnat_temp
= First_Entity (gnat_entity
);
2641 Present (gnat_temp
); gnat_temp
= Next_Entity (gnat_temp
))
2642 if ((Ekind (gnat_temp
) == E_Component
2643 || Ekind (gnat_temp
) == E_Discriminant
)
2644 && Is_Itype (Etype (gnat_temp
))
2645 && !present_gnu_tree (gnat_temp
))
2646 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2650 case E_Class_Wide_Subtype
:
2651 /* If an equivalent type is present, that is what we should use.
2652 Otherwise, fall through to handle this like a record subtype
2653 since it may have constraints. */
2654 if (gnat_equiv_type
!= gnat_entity
)
2656 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
2657 maybe_present
= true;
2661 /* ... fall through ... */
2663 case E_Record_Subtype
:
2665 /* If Cloned_Subtype is Present it means this record subtype has
2666 identical layout to that type or subtype and we should use
2667 that GCC type for this one. The front end guarantees that
2668 the component list is shared. */
2669 if (Present (Cloned_Subtype (gnat_entity
)))
2671 gnu_decl
= gnat_to_gnu_entity (Cloned_Subtype (gnat_entity
),
2673 maybe_present
= true;
2676 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2677 changing the type, make a new type with each field having the
2678 type of the field in the new subtype but having the position
2679 computed by transforming every discriminant reference according
2680 to the constraints. We don't see any difference between
2681 private and nonprivate type here since derivations from types should
2682 have been deferred until the completion of the private type. */
2685 Entity_Id gnat_base_type
= Implementation_Base_Type (gnat_entity
);
2690 defer_incomplete_level
++, this_deferred
= true;
2692 /* Get the base type initially for its alignment and sizes. But
2693 if it is a padded type, we do all the other work with the
2695 gnu_base_type
= gnat_to_gnu_type (gnat_base_type
);
2697 if (TREE_CODE (gnu_base_type
) == RECORD_TYPE
2698 && TYPE_IS_PADDING_P (gnu_base_type
))
2699 gnu_type
= gnu_orig_type
= TREE_TYPE (TYPE_FIELDS (gnu_base_type
));
2701 gnu_type
= gnu_orig_type
= gnu_base_type
;
2703 if (present_gnu_tree (gnat_entity
))
2705 maybe_present
= true;
2709 /* When the type has discriminants, and these discriminants
2710 affect the shape of what it built, factor them in.
2712 If we are making a subtype of an Unchecked_Union (must be an
2713 Itype), just return the type.
2715 We can't just use Is_Constrained because private subtypes without
2716 discriminants of full types with discriminants with default
2717 expressions are Is_Constrained but aren't constrained! */
2719 if (IN (Ekind (gnat_base_type
), Record_Kind
)
2720 && !Is_For_Access_Subtype (gnat_entity
)
2721 && !Is_Unchecked_Union (gnat_base_type
)
2722 && Is_Constrained (gnat_entity
)
2723 && Stored_Constraint (gnat_entity
) != No_Elist
2724 && Present (Discriminant_Constraint (gnat_entity
)))
2726 Entity_Id gnat_field
;
2727 tree gnu_field_list
= 0;
2729 = compute_field_positions (gnu_orig_type
, NULL_TREE
,
2730 size_zero_node
, bitsize_zero_node
,
2733 = substitution_list (gnat_entity
, gnat_base_type
, NULL_TREE
,
2737 gnu_type
= make_node (RECORD_TYPE
);
2738 TYPE_NAME (gnu_type
) = gnu_entity_id
;
2739 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_base_type
);
2740 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
2742 for (gnat_field
= First_Entity (gnat_entity
);
2743 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
2744 if ((Ekind (gnat_field
) == E_Component
2745 || Ekind (gnat_field
) == E_Discriminant
)
2746 && (Underlying_Type (Scope (Original_Record_Component
2749 && (No (Corresponding_Discriminant (gnat_field
))
2750 || !Is_Tagged_Type (gnat_base_type
)))
2753 = gnat_to_gnu_field_decl (Original_Record_Component
2756 = TREE_VALUE (purpose_member (gnu_old_field
,
2758 tree gnu_pos
= TREE_PURPOSE (gnu_offset
);
2759 tree gnu_bitpos
= TREE_VALUE (TREE_VALUE (gnu_offset
));
2761 = gnat_to_gnu_type (Etype (gnat_field
));
2762 tree gnu_size
= TYPE_SIZE (gnu_field_type
);
2763 tree gnu_new_pos
= 0;
2764 unsigned int offset_align
2765 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset
)),
2769 /* If there was a component clause, the field types must be
2770 the same for the type and subtype, so copy the data from
2771 the old field to avoid recomputation here. Also if the
2772 field is justified modular and the optimization in
2773 gnat_to_gnu_field was applied. */
2774 if (Present (Component_Clause
2775 (Original_Record_Component (gnat_field
)))
2776 || (TREE_CODE (gnu_field_type
) == RECORD_TYPE
2777 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
2778 && TREE_TYPE (TYPE_FIELDS (gnu_field_type
))
2779 == TREE_TYPE (gnu_old_field
)))
2781 gnu_size
= DECL_SIZE (gnu_old_field
);
2782 gnu_field_type
= TREE_TYPE (gnu_old_field
);
2785 /* If the old field was packed and of constant size, we
2786 have to get the old size here, as it might differ from
2787 what the Etype conveys and the latter might overlap
2788 onto the following field. Try to arrange the type for
2789 possible better packing along the way. */
2790 else if (DECL_PACKED (gnu_old_field
)
2791 && TREE_CODE (DECL_SIZE (gnu_old_field
))
2794 gnu_size
= DECL_SIZE (gnu_old_field
);
2795 if (TYPE_MODE (gnu_field_type
) == BLKmode
2796 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
2797 && host_integerp (TYPE_SIZE (gnu_field_type
), 1))
2798 gnu_field_type
= make_packable_type (gnu_field_type
);
2801 if (CONTAINS_PLACEHOLDER_P (gnu_pos
))
2802 for (gnu_temp
= gnu_subst_list
;
2803 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2804 gnu_pos
= substitute_in_expr (gnu_pos
,
2805 TREE_PURPOSE (gnu_temp
),
2806 TREE_VALUE (gnu_temp
));
2808 /* If the size is now a constant, we can set it as the
2809 size of the field when we make it. Otherwise, we need
2810 to deal with it specially. */
2811 if (TREE_CONSTANT (gnu_pos
))
2812 gnu_new_pos
= bit_from_pos (gnu_pos
, gnu_bitpos
);
2816 (DECL_NAME (gnu_old_field
), gnu_field_type
, gnu_type
,
2817 DECL_PACKED (gnu_old_field
), gnu_size
, gnu_new_pos
,
2818 !DECL_NONADDRESSABLE_P (gnu_old_field
));
2820 if (!TREE_CONSTANT (gnu_pos
))
2822 normalize_offset (&gnu_pos
, &gnu_bitpos
, offset_align
);
2823 DECL_FIELD_OFFSET (gnu_field
) = gnu_pos
;
2824 DECL_FIELD_BIT_OFFSET (gnu_field
) = gnu_bitpos
;
2825 SET_DECL_OFFSET_ALIGN (gnu_field
, offset_align
);
2826 DECL_SIZE (gnu_field
) = gnu_size
;
2827 DECL_SIZE_UNIT (gnu_field
)
2828 = convert (sizetype
,
2829 size_binop (CEIL_DIV_EXPR
, gnu_size
,
2830 bitsize_unit_node
));
2831 layout_decl (gnu_field
, DECL_OFFSET_ALIGN (gnu_field
));
2834 DECL_INTERNAL_P (gnu_field
)
2835 = DECL_INTERNAL_P (gnu_old_field
);
2836 SET_DECL_ORIGINAL_FIELD
2837 (gnu_field
, (DECL_ORIGINAL_FIELD (gnu_old_field
)
2838 ? DECL_ORIGINAL_FIELD (gnu_old_field
)
2840 DECL_DISCRIMINANT_NUMBER (gnu_field
)
2841 = DECL_DISCRIMINANT_NUMBER (gnu_old_field
);
2842 TREE_THIS_VOLATILE (gnu_field
)
2843 = TREE_THIS_VOLATILE (gnu_old_field
);
2844 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2845 gnu_field_list
= gnu_field
;
2846 save_gnu_tree (gnat_field
, gnu_field
, false);
2849 /* Now go through the entities again looking for Itypes that
2850 we have not elaborated but should (e.g., Etypes of fields
2851 that have Original_Components). */
2852 for (gnat_field
= First_Entity (gnat_entity
);
2853 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
2854 if ((Ekind (gnat_field
) == E_Discriminant
2855 || Ekind (gnat_field
) == E_Component
)
2856 && !present_gnu_tree (Etype (gnat_field
)))
2857 gnat_to_gnu_entity (Etype (gnat_field
), NULL_TREE
, 0);
2859 /* Do not finalize it since we're going to modify it below. */
2860 finish_record_type (gnu_type
, nreverse (gnu_field_list
),
2863 /* Now set the size, alignment and alias set of the new type to
2864 match that of the old one, doing any substitutions, as
2866 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_base_type
);
2867 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_base_type
);
2868 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_base_type
);
2869 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_ADA_SIZE (gnu_base_type
));
2870 copy_alias_set (gnu_type
, gnu_base_type
);
2872 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
2873 for (gnu_temp
= gnu_subst_list
;
2874 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2875 TYPE_SIZE (gnu_type
)
2876 = substitute_in_expr (TYPE_SIZE (gnu_type
),
2877 TREE_PURPOSE (gnu_temp
),
2878 TREE_VALUE (gnu_temp
));
2880 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type
)))
2881 for (gnu_temp
= gnu_subst_list
;
2882 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2883 TYPE_SIZE_UNIT (gnu_type
)
2884 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type
),
2885 TREE_PURPOSE (gnu_temp
),
2886 TREE_VALUE (gnu_temp
));
2888 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type
)))
2889 for (gnu_temp
= gnu_subst_list
;
2890 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2892 (gnu_type
, substitute_in_expr (TYPE_ADA_SIZE (gnu_type
),
2893 TREE_PURPOSE (gnu_temp
),
2894 TREE_VALUE (gnu_temp
)));
2896 /* Reapply variable_size since we have changed the sizes. */
2897 TYPE_SIZE (gnu_type
) = variable_size (TYPE_SIZE (gnu_type
));
2898 TYPE_SIZE_UNIT (gnu_type
)
2899 = variable_size (TYPE_SIZE_UNIT (gnu_type
));
2901 /* Recompute the mode of this record type now that we know its
2903 compute_record_mode (gnu_type
);
2905 /* Fill in locations of fields. */
2906 annotate_rep (gnat_entity
, gnu_type
);
2908 /* We've built a new type, make an XVS type to show what this
2909 is a subtype of. Some debuggers require the XVS type to be
2910 output first, so do it in that order. */
2913 tree gnu_subtype_marker
= make_node (RECORD_TYPE
);
2914 tree gnu_orig_name
= TYPE_NAME (gnu_orig_type
);
2916 if (TREE_CODE (gnu_orig_name
) == TYPE_DECL
)
2917 gnu_orig_name
= DECL_NAME (gnu_orig_name
);
2919 TYPE_NAME (gnu_subtype_marker
)
2920 = create_concat_name (gnat_entity
, "XVS");
2921 finish_record_type (gnu_subtype_marker
,
2922 create_field_decl (gnu_orig_name
,
2930 /* Now we can finalize it. */
2931 rest_of_record_type_compilation (gnu_type
);
2934 /* Otherwise, go down all the components in the new type and
2935 make them equivalent to those in the base type. */
2937 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
2938 gnat_temp
= Next_Entity (gnat_temp
))
2939 if ((Ekind (gnat_temp
) == E_Discriminant
2940 && !Is_Unchecked_Union (gnat_base_type
))
2941 || Ekind (gnat_temp
) == E_Component
)
2942 save_gnu_tree (gnat_temp
,
2943 gnat_to_gnu_field_decl
2944 (Original_Record_Component (gnat_temp
)), false);
2948 case E_Access_Subprogram_Type
:
2949 case E_Anonymous_Access_Subprogram_Type
:
2950 /* If we are not defining this entity, and we have incomplete
2951 entities being processed above us, make a dummy type and
2952 fill it in later. */
2953 if (!definition
&& defer_incomplete_level
!= 0)
2955 struct incomplete
*p
2956 = (struct incomplete
*) xmalloc (sizeof (struct incomplete
));
2959 = build_pointer_type
2960 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
2961 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
2962 !Comes_From_Source (gnat_entity
),
2963 debug_info_p
, gnat_entity
);
2964 this_made_decl
= true;
2965 gnu_type
= TREE_TYPE (gnu_decl
);
2966 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2969 p
->old_type
= TREE_TYPE (gnu_type
);
2970 p
->full_type
= Directly_Designated_Type (gnat_entity
);
2971 p
->next
= defer_incomplete_list
;
2972 defer_incomplete_list
= p
;
2976 /* ... fall through ... */
2978 case E_Allocator_Type
:
2980 case E_Access_Attribute_Type
:
2981 case E_Anonymous_Access_Type
:
2982 case E_General_Access_Type
:
2984 Entity_Id gnat_desig_type
= Directly_Designated_Type (gnat_entity
);
2985 Entity_Id gnat_desig_equiv
= Gigi_Equivalent_Type (gnat_desig_type
);
2986 bool is_from_limited_with
2987 = (IN (Ekind (gnat_desig_equiv
), Incomplete_Kind
)
2988 && From_With_Type (gnat_desig_equiv
));
2990 /* Get the "full view" of this entity. If this is an incomplete
2991 entity from a limited with, treat its non-limited view as the full
2992 view. Otherwise, if this is an incomplete or private type, use the
2993 full view. In the former case, we might point to a private type,
2994 in which case, we need its full view. Also, we want to look at the
2995 actual type used for the representation, so this takes a total of
2997 Entity_Id gnat_desig_full_direct_first
2998 = (is_from_limited_with
? Non_Limited_View (gnat_desig_equiv
)
2999 : (IN (Ekind (gnat_desig_equiv
), Incomplete_Or_Private_Kind
)
3000 ? Full_View (gnat_desig_equiv
) : Empty
));
3001 Entity_Id gnat_desig_full_direct
3002 = ((is_from_limited_with
3003 && Present (gnat_desig_full_direct_first
)
3004 && IN (Ekind (gnat_desig_full_direct_first
), Private_Kind
))
3005 ? Full_View (gnat_desig_full_direct_first
)
3006 : gnat_desig_full_direct_first
);
3007 Entity_Id gnat_desig_full
3008 = Gigi_Equivalent_Type (gnat_desig_full_direct
);
3010 /* This the type actually used to represent the designated type,
3011 either gnat_desig_full or gnat_desig_equiv. */
3012 Entity_Id gnat_desig_rep
;
3014 /* Nonzero if this is a pointer to an unconstrained array. */
3015 bool is_unconstrained_array
;
3017 /* We want to know if we'll be seeing the freeze node for any
3018 incomplete type we may be pointing to. */
3020 = (Present (gnat_desig_full
)
3021 ? In_Extended_Main_Code_Unit (gnat_desig_full
)
3022 : In_Extended_Main_Code_Unit (gnat_desig_type
));
3024 /* Nonzero if we make a dummy type here. */
3025 bool got_fat_p
= false;
3026 /* Nonzero if the dummy is a fat pointer. */
3027 bool made_dummy
= false;
3028 tree gnu_desig_type
= NULL_TREE
;
3029 enum machine_mode p_mode
= mode_for_size (esize
, MODE_INT
, 0);
3031 if (!targetm
.valid_pointer_mode (p_mode
))
3034 /* If either the designated type or its full view is an unconstrained
3035 array subtype, replace it with the type it's a subtype of. This
3036 avoids problems with multiple copies of unconstrained array types.
3037 Likewise, if the designated type is a subtype of an incomplete
3038 record type, use the parent type to avoid order of elaboration
3039 issues. This can lose some code efficiency, but there is no
3041 if (Ekind (gnat_desig_equiv
) == E_Array_Subtype
3042 && ! Is_Constrained (gnat_desig_equiv
))
3043 gnat_desig_equiv
= Etype (gnat_desig_equiv
);
3044 if (Present (gnat_desig_full
)
3045 && ((Ekind (gnat_desig_full
) == E_Array_Subtype
3046 && ! Is_Constrained (gnat_desig_full
))
3047 || (Ekind (gnat_desig_full
) == E_Record_Subtype
3048 && Ekind (Etype (gnat_desig_full
)) == E_Record_Type
)))
3049 gnat_desig_full
= Etype (gnat_desig_full
);
3051 /* Now set the type that actually marks the representation of
3052 the designated type and also flag whether we have a unconstrained
3054 gnat_desig_rep
= gnat_desig_full
? gnat_desig_full
: gnat_desig_equiv
;
3055 is_unconstrained_array
3056 = (Is_Array_Type (gnat_desig_rep
)
3057 && ! Is_Constrained (gnat_desig_rep
));
3059 /* If we are pointing to an incomplete type whose completion is an
3060 unconstrained array, make a fat pointer type. The two types in our
3061 fields will be pointers to dummy nodes and will be replaced in
3062 update_pointer_to. Similarly, if the type itself is a dummy type or
3063 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3064 in case we have any thin pointers to it. */
3065 if (is_unconstrained_array
3066 && (Present (gnat_desig_full
)
3067 || (present_gnu_tree (gnat_desig_equiv
)
3068 && TYPE_IS_DUMMY_P (TREE_TYPE
3069 (get_gnu_tree (gnat_desig_equiv
))))
3070 || (No (gnat_desig_full
) && ! in_main_unit
3071 && defer_incomplete_level
!= 0
3072 && ! present_gnu_tree (gnat_desig_equiv
))
3073 || (in_main_unit
&& is_from_limited_with
3074 && Present (Freeze_Node (gnat_desig_rep
)))))
3077 = (present_gnu_tree (gnat_desig_rep
)
3078 ? TREE_TYPE (get_gnu_tree (gnat_desig_rep
))
3079 : make_dummy_type (gnat_desig_rep
));
3082 /* Show the dummy we get will be a fat pointer. */
3083 got_fat_p
= made_dummy
= true;
3085 /* If the call above got something that has a pointer, that
3086 pointer is our type. This could have happened either
3087 because the type was elaborated or because somebody
3088 else executed the code below. */
3089 gnu_type
= TYPE_POINTER_TO (gnu_old
);
3092 tree gnu_template_type
= make_node (ENUMERAL_TYPE
);
3093 tree gnu_ptr_template
= build_pointer_type (gnu_template_type
);
3094 tree gnu_array_type
= make_node (ENUMERAL_TYPE
);
3095 tree gnu_ptr_array
= build_pointer_type (gnu_array_type
);
3097 TYPE_NAME (gnu_template_type
)
3098 = concat_id_with_name (get_entity_name (gnat_desig_equiv
),
3100 TYPE_DUMMY_P (gnu_template_type
) = 1;
3102 TYPE_NAME (gnu_array_type
)
3103 = concat_id_with_name (get_entity_name (gnat_desig_equiv
),
3105 TYPE_DUMMY_P (gnu_array_type
) = 1;
3107 gnu_type
= make_node (RECORD_TYPE
);
3108 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type
, gnu_old
);
3109 TYPE_POINTER_TO (gnu_old
) = gnu_type
;
3111 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
3113 = chainon (chainon (NULL_TREE
,
3115 (get_identifier ("P_ARRAY"),
3117 gnu_type
, 0, 0, 0, 0)),
3118 create_field_decl (get_identifier ("P_BOUNDS"),
3120 gnu_type
, 0, 0, 0, 0));
3122 /* Make sure we can place this into a register. */
3123 TYPE_ALIGN (gnu_type
)
3124 = MIN (BIGGEST_ALIGNMENT
, 2 * POINTER_SIZE
);
3125 TYPE_IS_FAT_POINTER_P (gnu_type
) = 1;
3127 /* Do not finalize this record type since the types of
3128 its fields are incomplete. */
3129 finish_record_type (gnu_type
, fields
, 0, true);
3131 TYPE_OBJECT_RECORD_TYPE (gnu_old
) = make_node (RECORD_TYPE
);
3132 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old
))
3133 = concat_id_with_name (get_entity_name (gnat_desig_equiv
),
3135 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old
)) = 1;
3139 /* If we already know what the full type is, use it. */
3140 else if (Present (gnat_desig_full
)
3141 && present_gnu_tree (gnat_desig_full
))
3142 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_full
));
3144 /* Get the type of the thing we are to point to and build a pointer
3145 to it. If it is a reference to an incomplete or private type with a
3146 full view that is a record, make a dummy type node and get the
3147 actual type later when we have verified it is safe. */
3148 else if ((! in_main_unit
3149 && ! present_gnu_tree (gnat_desig_equiv
)
3150 && Present (gnat_desig_full
)
3151 && ! present_gnu_tree (gnat_desig_full
)
3152 && Is_Record_Type (gnat_desig_full
))
3153 /* Likewise if we are pointing to a record or array and we
3154 are to defer elaborating incomplete types. We do this
3155 since this access type may be the full view of some
3156 private type. Note that the unconstrained array case is
3158 || ((! in_main_unit
|| imported_p
)
3159 && defer_incomplete_level
!= 0
3160 && ! present_gnu_tree (gnat_desig_equiv
)
3161 && ((Is_Record_Type (gnat_desig_rep
)
3162 || Is_Array_Type (gnat_desig_rep
))))
3163 /* If this is a reference from a limited_with type back to our
3164 main unit and there's a Freeze_Node for it, either we have
3165 already processed the declaration and made the dummy type,
3166 in which case we just reuse the latter, or we have not yet,
3167 in which case we make the dummy type and it will be reused
3168 when the declaration is processed. In both cases, the
3169 pointer eventually created below will be automatically
3170 adjusted when the Freeze_Node is processed. Note that the
3171 unconstrained array case is handled above. */
3172 || (in_main_unit
&& is_from_limited_with
3173 && Present (Freeze_Node (gnat_desig_rep
))))
3175 gnu_desig_type
= make_dummy_type (gnat_desig_equiv
);
3179 /* Otherwise handle the case of a pointer to itself. */
3180 else if (gnat_desig_equiv
== gnat_entity
)
3183 = build_pointer_type_for_mode (void_type_node
, p_mode
,
3184 No_Strict_Aliasing (gnat_entity
));
3185 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
) = gnu_type
;
3188 /* If expansion is disabled, the equivalent type of a concurrent
3189 type is absent, so build a dummy pointer type. */
3190 else if (type_annotate_only
&& No (gnat_desig_equiv
))
3191 gnu_type
= ptr_void_type_node
;
3193 /* Finally, handle the straightforward case where we can just
3194 elaborate our designated type and point to it. */
3196 gnu_desig_type
= gnat_to_gnu_type (gnat_desig_equiv
);
3198 /* It is possible that a call to gnat_to_gnu_type above resolved our
3199 type. If so, just return it. */
3200 if (present_gnu_tree (gnat_entity
))
3202 maybe_present
= true;
3206 /* If we have a GCC type for the designated type, possibly modify it
3207 if we are pointing only to constant objects and then make a pointer
3208 to it. Don't do this for unconstrained arrays. */
3209 if (!gnu_type
&& gnu_desig_type
)
3211 if (Is_Access_Constant (gnat_entity
)
3212 && TREE_CODE (gnu_desig_type
) != UNCONSTRAINED_ARRAY_TYPE
)
3215 = build_qualified_type
3217 TYPE_QUALS (gnu_desig_type
) | TYPE_QUAL_CONST
);
3219 /* Some extra processing is required if we are building a
3220 pointer to an incomplete type (in the GCC sense). We might
3221 have such a type if we just made a dummy, or directly out
3222 of the call to gnat_to_gnu_type above if we are processing
3223 an access type for a record component designating the
3224 record type itself. */
3225 if (TYPE_MODE (gnu_desig_type
) == VOIDmode
)
3227 /* We must ensure that the pointer to variant we make will
3228 be processed by update_pointer_to when the initial type
3229 is completed. Pretend we made a dummy and let further
3230 processing act as usual. */
3233 /* We must ensure that update_pointer_to will not retrieve
3234 the dummy variant when building a properly qualified
3235 version of the complete type. We take advantage of the
3236 fact that get_qualified_type is requiring TYPE_NAMEs to
3237 match to influence build_qualified_type and then also
3238 update_pointer_to here. */
3239 TYPE_NAME (gnu_desig_type
)
3240 = create_concat_name (gnat_desig_type
, "INCOMPLETE_CST");
3245 = build_pointer_type_for_mode (gnu_desig_type
, p_mode
,
3246 No_Strict_Aliasing (gnat_entity
));
3249 /* If we are not defining this object and we made a dummy pointer,
3250 save our current definition, evaluate the actual type, and replace
3251 the tentative type we made with the actual one. If we are to defer
3252 actually looking up the actual type, make an entry in the
3253 deferred list. If this is from a limited with, we have to defer
3254 to the end of the current spec in two cases: first if the
3255 designated type is in the current unit and second if the access
3257 if ((! in_main_unit
|| is_from_limited_with
) && made_dummy
)
3260 = TYPE_FAT_POINTER_P (gnu_type
)
3261 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type
) : TREE_TYPE (gnu_type
);
3263 if (esize
== POINTER_SIZE
3264 && (got_fat_p
|| TYPE_FAT_POINTER_P (gnu_type
)))
3266 = build_pointer_type
3267 (TYPE_OBJECT_RECORD_TYPE
3268 (TYPE_UNCONSTRAINED_ARRAY (gnu_type
)));
3270 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3271 !Comes_From_Source (gnat_entity
),
3272 debug_info_p
, gnat_entity
);
3273 this_made_decl
= true;
3274 gnu_type
= TREE_TYPE (gnu_decl
);
3275 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3278 if (defer_incomplete_level
== 0
3279 && ! (is_from_limited_with
3281 || In_Extended_Main_Code_Unit (gnat_entity
))))
3282 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type
),
3283 gnat_to_gnu_type (gnat_desig_equiv
));
3285 /* Note that the call to gnat_to_gnu_type here might have
3286 updated gnu_old_type directly, in which case it is not a
3287 dummy type any more when we get into update_pointer_to.
3289 This may happen for instance when the designated type is a
3290 record type, because their elaboration starts with an
3291 initial node from make_dummy_type, which may yield the same
3292 node as the one we got.
3294 Besides, variants of this non-dummy type might have been
3295 created along the way. update_pointer_to is expected to
3296 properly take care of those situations. */
3299 struct incomplete
*p
3300 = (struct incomplete
*) xmalloc (sizeof
3301 (struct incomplete
));
3302 struct incomplete
**head
3303 = (is_from_limited_with
3305 || In_Extended_Main_Code_Unit (gnat_entity
))
3306 ? &defer_limited_with
: &defer_incomplete_list
);
3308 p
->old_type
= gnu_old_type
;
3309 p
->full_type
= gnat_desig_equiv
;
3317 case E_Access_Protected_Subprogram_Type
:
3318 case E_Anonymous_Access_Protected_Subprogram_Type
:
3319 if (type_annotate_only
&& No (gnat_equiv_type
))
3320 gnu_type
= ptr_void_type_node
;
3323 /* The runtime representation is the equivalent type. */
3324 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
3328 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3329 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3330 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
)))
3331 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity
))))
3332 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3337 case E_Access_Subtype
:
3339 /* We treat this as identical to its base type; any constraint is
3340 meaningful only to the front end.
3342 The designated type must be elaborated as well, if it does
3343 not have its own freeze node. Designated (sub)types created
3344 for constrained components of records with discriminants are
3345 not frozen by the front end and thus not elaborated by gigi,
3346 because their use may appear before the base type is frozen,
3347 and because it is not clear that they are needed anywhere in
3348 Gigi. With the current model, there is no correct place where
3349 they could be elaborated. */
3351 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3352 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3353 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3354 && Is_Frozen (Directly_Designated_Type (gnat_entity
))
3355 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
))))
3357 /* If we are not defining this entity, and we have incomplete
3358 entities being processed above us, make a dummy type and
3359 elaborate it later. */
3360 if (!definition
&& defer_incomplete_level
!= 0)
3362 struct incomplete
*p
3363 = (struct incomplete
*) xmalloc (sizeof (struct incomplete
));
3365 = build_pointer_type
3366 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
3368 p
->old_type
= TREE_TYPE (gnu_ptr_type
);
3369 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3370 p
->next
= defer_incomplete_list
;
3371 defer_incomplete_list
= p
;
3373 else if (!IN (Ekind (Base_Type
3374 (Directly_Designated_Type (gnat_entity
))),
3375 Incomplete_Or_Private_Kind
))
3376 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3380 maybe_present
= true;
3383 /* Subprogram Entities
3385 The following access functions are defined for subprograms (functions
3388 First_Formal The first formal parameter.
3389 Is_Imported Indicates that the subprogram has appeared in
3390 an INTERFACE or IMPORT pragma. For now we
3391 assume that the external language is C.
3392 Is_Exported Likewise but for an EXPORT pragma.
3393 Is_Inlined True if the subprogram is to be inlined.
3395 In addition for function subprograms we have:
3397 Etype Return type of the function.
3399 Each parameter is first checked by calling must_pass_by_ref on its
3400 type to determine if it is passed by reference. For parameters which
3401 are copied in, if they are Ada In Out or Out parameters, their return
3402 value becomes part of a record which becomes the return type of the
3403 function (C function - note that this applies only to Ada procedures
3404 so there is no Ada return type). Additional code to store back the
3405 parameters will be generated on the caller side. This transformation
3406 is done here, not in the front-end.
3408 The intended result of the transformation can be seen from the
3409 equivalent source rewritings that follow:
3411 struct temp {int a,b};
3412 procedure P (A,B: In Out ...) is temp P (int A,B)
3415 end P; return {A,B};
3422 For subprogram types we need to perform mainly the same conversions to
3423 GCC form that are needed for procedures and function declarations. The
3424 only difference is that at the end, we make a type declaration instead
3425 of a function declaration. */
3427 case E_Subprogram_Type
:
3431 /* The first GCC parameter declaration (a PARM_DECL node). The
3432 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3433 actually is the head of this parameter list. */
3434 tree gnu_param_list
= NULL_TREE
;
3435 /* Likewise for the stub associated with an exported procedure. */
3436 tree gnu_stub_param_list
= NULL_TREE
;
3437 /* The type returned by a function. If the subprogram is a procedure
3438 this type should be void_type_node. */
3439 tree gnu_return_type
= void_type_node
;
3440 /* List of fields in return type of procedure with copy-in copy-out
3442 tree gnu_field_list
= NULL_TREE
;
3443 /* Non-null for subprograms containing parameters passed by copy-in
3444 copy-out (Ada In Out or Out parameters not passed by reference),
3445 in which case it is the list of nodes used to specify the values of
3446 the in out/out parameters that are returned as a record upon
3447 procedure return. The TREE_PURPOSE of an element of this list is
3448 a field of the record and the TREE_VALUE is the PARM_DECL
3449 corresponding to that field. This list will be saved in the
3450 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3451 tree gnu_return_list
= NULL_TREE
;
3452 /* If an import pragma asks to map this subprogram to a GCC builtin,
3453 this is the builtin DECL node. */
3454 tree gnu_builtin_decl
= NULL_TREE
;
3455 /* For the stub associated with an exported procedure. */
3456 tree gnu_stub_type
= NULL_TREE
, gnu_stub_name
= NULL_TREE
;
3457 tree gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
3458 Entity_Id gnat_param
;
3459 bool inline_flag
= Is_Inlined (gnat_entity
);
3460 bool public_flag
= Is_Public (gnat_entity
);
3462 = (Is_Public (gnat_entity
) && !definition
) || imported_p
;
3463 bool pure_flag
= Is_Pure (gnat_entity
);
3464 bool volatile_flag
= No_Return (gnat_entity
);
3465 bool returns_by_ref
= false;
3466 bool returns_unconstrained
= false;
3467 bool returns_by_target_ptr
= false;
3468 bool has_copy_in_out
= false;
3469 bool has_stub
= false;
3472 if (kind
== E_Subprogram_Type
&& !definition
)
3473 /* A parameter may refer to this type, so defer completion
3474 of any incomplete types. */
3475 defer_incomplete_level
++, this_deferred
= true;
3477 /* If the subprogram has an alias, it is probably inherited, so
3478 we can use the original one. If the original "subprogram"
3479 is actually an enumeration literal, it may be the first use
3480 of its type, so we must elaborate that type now. */
3481 if (Present (Alias (gnat_entity
)))
3483 if (Ekind (Alias (gnat_entity
)) == E_Enumeration_Literal
)
3484 gnat_to_gnu_entity (Etype (Alias (gnat_entity
)), NULL_TREE
, 0);
3486 gnu_decl
= gnat_to_gnu_entity (Alias (gnat_entity
),
3489 /* Elaborate any Itypes in the parameters of this entity. */
3490 for (gnat_temp
= First_Formal_With_Extras (gnat_entity
);
3491 Present (gnat_temp
);
3492 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
3493 if (Is_Itype (Etype (gnat_temp
)))
3494 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
3499 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3500 corresponding DECL node.
3502 We still want the parameter associations to take place because the
3503 proper generation of calls depends on it (a GNAT parameter without
3504 a corresponding GCC tree has a very specific meaning), so we don't
3506 if (Convention (gnat_entity
) == Convention_Intrinsic
)
3507 gnu_builtin_decl
= builtin_decl_for (gnu_ext_name
);
3509 /* ??? What if we don't find the builtin node above ? warn ? err ?
3510 In the current state we neither warn nor err, and calls will just
3511 be handled as for regular subprograms. */
3513 if (kind
== E_Function
|| kind
== E_Subprogram_Type
)
3514 gnu_return_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3516 /* If this function returns by reference, make the actual
3517 return type of this function the pointer and mark the decl. */
3518 if (Returns_By_Ref (gnat_entity
))
3520 returns_by_ref
= true;
3521 gnu_return_type
= build_pointer_type (gnu_return_type
);
3524 /* If the Mechanism is By_Reference, ensure the return type uses
3525 the machine's by-reference mechanism, which may not the same
3526 as above (e.g., it might be by passing a fake parameter). */
3527 else if (kind
== E_Function
3528 && Mechanism (gnat_entity
) == By_Reference
)
3530 TREE_ADDRESSABLE (gnu_return_type
) = 1;
3532 /* We expect this bit to be reset by gigi shortly, so can avoid a
3533 type node copy here. This actually also prevents troubles with
3534 the generation of debug information for the function, because
3535 we might have issued such info for this type already, and would
3536 be attaching a distinct type node to the function if we made a
3540 /* If we are supposed to return an unconstrained array,
3541 actually return a fat pointer and make a note of that. Return
3542 a pointer to an unconstrained record of variable size. */
3543 else if (TREE_CODE (gnu_return_type
) == UNCONSTRAINED_ARRAY_TYPE
)
3545 gnu_return_type
= TREE_TYPE (gnu_return_type
);
3546 returns_unconstrained
= true;
3549 /* If the type requires a transient scope, the result is allocated
3550 on the secondary stack, so the result type of the function is
3552 else if (Requires_Transient_Scope (Etype (gnat_entity
)))
3554 gnu_return_type
= build_pointer_type (gnu_return_type
);
3555 returns_unconstrained
= true;
3558 /* If the type is a padded type and the underlying type would not
3559 be passed by reference or this function has a foreign convention,
3560 return the underlying type. */
3561 else if (TREE_CODE (gnu_return_type
) == RECORD_TYPE
3562 && TYPE_IS_PADDING_P (gnu_return_type
)
3563 && (!default_pass_by_ref (TREE_TYPE
3564 (TYPE_FIELDS (gnu_return_type
)))
3565 || Has_Foreign_Convention (gnat_entity
)))
3566 gnu_return_type
= TREE_TYPE (TYPE_FIELDS (gnu_return_type
));
3568 /* If the return type is unconstrained, that means it must have a
3569 maximum size. We convert the function into a procedure and its
3570 caller will pass a pointer to an object of that maximum size as the
3571 first parameter when we call the function. */
3572 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type
)))
3574 returns_by_target_ptr
= true;
3576 = create_param_decl (get_identifier ("TARGET"),
3577 build_reference_type (gnu_return_type
),
3579 gnu_return_type
= void_type_node
;
3582 /* If the return type has a size that overflows, we cannot have
3583 a function that returns that type. This usage doesn't make
3584 sense anyway, so give an error here. */
3585 if (TYPE_SIZE_UNIT (gnu_return_type
)
3586 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type
))
3587 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type
)))
3589 post_error ("cannot return type whose size overflows",
3591 gnu_return_type
= copy_node (gnu_return_type
);
3592 TYPE_SIZE (gnu_return_type
) = bitsize_zero_node
;
3593 TYPE_SIZE_UNIT (gnu_return_type
) = size_zero_node
;
3594 TYPE_MAIN_VARIANT (gnu_return_type
) = gnu_return_type
;
3595 TYPE_NEXT_VARIANT (gnu_return_type
) = NULL_TREE
;
3598 /* Look at all our parameters and get the type of
3599 each. While doing this, build a copy-out structure if
3602 /* Loop over the parameters and get their associated GCC tree.
3603 While doing this, build a copy-out structure if we need one. */
3604 for (gnat_param
= First_Formal_With_Extras (gnat_entity
), parmnum
= 0;
3605 Present (gnat_param
);
3606 gnat_param
= Next_Formal_With_Extras (gnat_param
), parmnum
++)
3608 tree gnu_param_name
= get_entity_name (gnat_param
);
3609 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
3610 tree gnu_param
, gnu_field
;
3611 bool copy_in_copy_out
= false;
3612 Mechanism_Type mech
= Mechanism (gnat_param
);
3614 /* Builtins are expanded inline and there is no real call sequence
3615 involved. So the type expected by the underlying expander is
3616 always the type of each argument "as is". */
3617 if (gnu_builtin_decl
)
3619 /* Handle the first parameter of a valued procedure specially. */
3620 else if (Is_Valued_Procedure (gnat_entity
) && parmnum
== 0)
3621 mech
= By_Copy_Return
;
3622 /* Otherwise, see if a Mechanism was supplied that forced this
3623 parameter to be passed one way or another. */
3624 else if (mech
== Default
3625 || mech
== By_Copy
|| mech
== By_Reference
)
3627 else if (By_Descriptor_Last
<= mech
&& mech
<= By_Descriptor
)
3628 mech
= By_Descriptor
;
3631 if (TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
3632 || TREE_CODE (TYPE_SIZE (gnu_param_type
)) != INTEGER_CST
3633 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type
),
3635 mech
= By_Reference
;
3641 post_error ("unsupported mechanism for&", gnat_param
);
3646 = gnat_to_gnu_param (gnat_param
, mech
, gnat_entity
,
3647 Has_Foreign_Convention (gnat_entity
),
3650 /* We are returned either a PARM_DECL or a type if no parameter
3651 needs to be passed; in either case, adjust the type. */
3652 if (DECL_P (gnu_param
))
3653 gnu_param_type
= TREE_TYPE (gnu_param
);
3656 gnu_param_type
= gnu_param
;
3657 gnu_param
= NULL_TREE
;
3662 /* If it's an exported subprogram, we build a parameter list
3663 in parallel, in case we need to emit a stub for it. */
3664 if (Is_Exported (gnat_entity
))
3667 = chainon (gnu_param
, gnu_stub_param_list
);
3668 /* Change By_Descriptor parameter to By_Reference for
3669 the internal version of an exported subprogram. */
3670 if (mech
== By_Descriptor
)
3673 = gnat_to_gnu_param (gnat_param
, By_Reference
,
3679 gnu_param
= copy_node (gnu_param
);
3682 gnu_param_list
= chainon (gnu_param
, gnu_param_list
);
3683 Sloc_to_locus (Sloc (gnat_param
),
3684 &DECL_SOURCE_LOCATION (gnu_param
));
3685 save_gnu_tree (gnat_param
, gnu_param
, false);
3687 /* If a parameter is a pointer, this function may modify
3688 memory through it and thus shouldn't be considered
3689 a pure function. Also, the memory may be modified
3690 between two calls, so they can't be CSE'ed. The latter
3691 case also handles by-ref parameters. */
3692 if (POINTER_TYPE_P (gnu_param_type
)
3693 || TYPE_FAT_POINTER_P (gnu_param_type
))
3697 if (copy_in_copy_out
)
3699 if (!has_copy_in_out
)
3701 gcc_assert (TREE_CODE (gnu_return_type
) == VOID_TYPE
);
3702 gnu_return_type
= make_node (RECORD_TYPE
);
3703 TYPE_NAME (gnu_return_type
) = get_identifier ("RETURN");
3704 has_copy_in_out
= true;
3707 gnu_field
= create_field_decl (gnu_param_name
, gnu_param_type
,
3708 gnu_return_type
, 0, 0, 0, 0);
3709 Sloc_to_locus (Sloc (gnat_param
),
3710 &DECL_SOURCE_LOCATION (gnu_field
));
3711 TREE_CHAIN (gnu_field
) = gnu_field_list
;
3712 gnu_field_list
= gnu_field
;
3713 gnu_return_list
= tree_cons (gnu_field
, gnu_param
,
3718 /* Do not compute record for out parameters if subprogram is
3719 stubbed since structures are incomplete for the back-end. */
3720 if (gnu_field_list
&& Convention (gnat_entity
) != Convention_Stubbed
)
3721 finish_record_type (gnu_return_type
, nreverse (gnu_field_list
),
3724 /* If we have a CICO list but it has only one entry, we convert
3725 this function into a function that simply returns that one
3727 if (list_length (gnu_return_list
) == 1)
3728 gnu_return_type
= TREE_TYPE (TREE_PURPOSE (gnu_return_list
));
3730 if (Has_Stdcall_Convention (gnat_entity
))
3731 prepend_one_attribute_to
3732 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
3733 get_identifier ("stdcall"), NULL_TREE
,
3736 /* The lists have been built in reverse. */
3737 gnu_param_list
= nreverse (gnu_param_list
);
3739 gnu_stub_param_list
= nreverse (gnu_stub_param_list
);
3740 gnu_return_list
= nreverse (gnu_return_list
);
3742 if (Ekind (gnat_entity
) == E_Function
)
3743 Set_Mechanism (gnat_entity
,
3744 (returns_by_ref
|| returns_unconstrained
3745 ? By_Reference
: By_Copy
));
3747 = create_subprog_type (gnu_return_type
, gnu_param_list
,
3748 gnu_return_list
, returns_unconstrained
,
3750 Function_Returns_With_DSP (gnat_entity
),
3751 returns_by_target_ptr
);
3755 = create_subprog_type (gnu_return_type
, gnu_stub_param_list
,
3756 gnu_return_list
, returns_unconstrained
,
3758 Function_Returns_With_DSP (gnat_entity
),
3759 returns_by_target_ptr
);
3761 /* A subprogram (something that doesn't return anything) shouldn't
3762 be considered Pure since there would be no reason for such a
3763 subprogram. Note that procedures with Out (or In Out) parameters
3764 have already been converted into a function with a return type. */
3765 if (TREE_CODE (gnu_return_type
) == VOID_TYPE
)
3768 /* The semantics of "pure" in Ada essentially matches that of "const"
3769 in the back-end. In particular, both properties are orthogonal to
3770 the "nothrow" property. But this is true only if the EH circuitry
3771 is explicit in the internal representation of the back-end. If we
3772 are to completely hide the EH circuitry from it, we need to declare
3773 that calls to pure Ada subprograms that can throw have side effects
3774 since they can trigger an "abnormal" transfer of control flow; thus
3775 they can be neither "const" nor "pure" in the back-end sense. */
3777 = build_qualified_type (gnu_type
,
3778 TYPE_QUALS (gnu_type
)
3779 | (Exception_Mechanism
== Back_End_Exceptions
3780 ? TYPE_QUAL_CONST
* pure_flag
: 0)
3781 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
3783 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
3787 = build_qualified_type (gnu_stub_type
,
3788 TYPE_QUALS (gnu_stub_type
)
3789 | (Exception_Mechanism
== Back_End_Exceptions
3790 ? TYPE_QUAL_CONST
* pure_flag
: 0)
3791 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
3793 /* If we have a builtin decl for that function, check the signatures
3794 compatibilities. If the signatures are compatible, use the builtin
3795 decl. If they are not, we expect the checker predicate to have
3796 posted the appropriate errors, and just continue with what we have
3798 if (gnu_builtin_decl
)
3800 tree gnu_builtin_type
= TREE_TYPE (gnu_builtin_decl
);
3802 if (compatible_signatures_p (gnu_type
, gnu_builtin_type
))
3804 gnu_decl
= gnu_builtin_decl
;
3805 gnu_type
= gnu_builtin_type
;
3810 /* If there was no specified Interface_Name and the external and
3811 internal names of the subprogram are the same, only use the
3812 internal name to allow disambiguation of nested subprograms. */
3813 if (No (Interface_Name (gnat_entity
)) && gnu_ext_name
== gnu_entity_id
)
3814 gnu_ext_name
= NULL_TREE
;
3816 /* If we are defining the subprogram and it has an Address clause
3817 we must get the address expression from the saved GCC tree for the
3818 subprogram if it has a Freeze_Node. Otherwise, we elaborate
3819 the address expression here since the front-end has guaranteed
3820 in that case that the elaboration has no effects. If there is
3821 an Address clause and we are not defining the object, just
3822 make it a constant. */
3823 if (Present (Address_Clause (gnat_entity
)))
3825 tree gnu_address
= NULL_TREE
;
3829 = (present_gnu_tree (gnat_entity
)
3830 ? get_gnu_tree (gnat_entity
)
3831 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
3833 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
3835 /* Convert the type of the object to a reference type that can
3836 alias everything as per 13.3(19). */
3838 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
3840 gnu_address
= convert (gnu_type
, gnu_address
);
3843 = create_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
3844 gnu_address
, false, Is_Public (gnat_entity
),
3845 extern_flag
, false, NULL
, gnat_entity
);
3846 DECL_BY_REF_P (gnu_decl
) = 1;
3849 else if (kind
== E_Subprogram_Type
)
3850 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3851 !Comes_From_Source (gnat_entity
),
3852 debug_info_p
, gnat_entity
);
3857 gnu_stub_name
= gnu_ext_name
;
3858 gnu_ext_name
= create_concat_name (gnat_entity
, "internal");
3859 public_flag
= false;
3862 gnu_decl
= create_subprog_decl (gnu_entity_id
, gnu_ext_name
,
3863 gnu_type
, gnu_param_list
,
3864 inline_flag
, public_flag
,
3865 extern_flag
, attr_list
,
3870 = create_subprog_decl (gnu_entity_id
, gnu_stub_name
,
3871 gnu_stub_type
, gnu_stub_param_list
,
3873 extern_flag
, attr_list
,
3875 SET_DECL_FUNCTION_STUB (gnu_decl
, gnu_stub_decl
);
3878 /* This is unrelated to the stub built right above. */
3879 DECL_STUBBED_P (gnu_decl
)
3880 = Convention (gnat_entity
) == Convention_Stubbed
;
3885 case E_Incomplete_Type
:
3886 case E_Incomplete_Subtype
:
3887 case E_Private_Type
:
3888 case E_Private_Subtype
:
3889 case E_Limited_Private_Type
:
3890 case E_Limited_Private_Subtype
:
3891 case E_Record_Type_With_Private
:
3892 case E_Record_Subtype_With_Private
:
3894 /* Get the "full view" of this entity. If this is an incomplete
3895 entity from a limited with, treat its non-limited view as the
3896 full view. Otherwise, use either the full view or the underlying
3897 full view, whichever is present. This is used in all the tests
3900 = (IN (Ekind (gnat_entity
), Incomplete_Kind
)
3901 && From_With_Type (gnat_entity
))
3902 ? Non_Limited_View (gnat_entity
)
3903 : Present (Full_View (gnat_entity
))
3904 ? Full_View (gnat_entity
)
3905 : Underlying_Full_View (gnat_entity
);
3907 /* If this is an incomplete type with no full view, it must be a Taft
3908 Amendment type, in which case we return a dummy type. Otherwise,
3909 just get the type from its Etype. */
3912 if (kind
== E_Incomplete_Type
)
3913 gnu_type
= make_dummy_type (gnat_entity
);
3916 gnu_decl
= gnat_to_gnu_entity (Etype (gnat_entity
),
3918 maybe_present
= true;
3923 /* If we already made a type for the full view, reuse it. */
3924 else if (present_gnu_tree (full_view
))
3926 gnu_decl
= get_gnu_tree (full_view
);
3930 /* Otherwise, if we are not defining the type now, get the type
3931 from the full view. But always get the type from the full view
3932 for define on use types, since otherwise we won't see them! */
3933 else if (!definition
3934 || (Is_Itype (full_view
)
3935 && No (Freeze_Node (gnat_entity
)))
3936 || (Is_Itype (gnat_entity
)
3937 && No (Freeze_Node (full_view
))))
3939 gnu_decl
= gnat_to_gnu_entity (full_view
, NULL_TREE
, 0);
3940 maybe_present
= true;
3944 /* For incomplete types, make a dummy type entry which will be
3946 gnu_type
= make_dummy_type (gnat_entity
);
3948 /* Save this type as the full declaration's type so we can do any
3949 needed updates when we see it. */
3950 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3951 !Comes_From_Source (gnat_entity
),
3952 debug_info_p
, gnat_entity
);
3953 save_gnu_tree (full_view
, gnu_decl
, 0);
3957 /* Simple class_wide types are always viewed as their root_type
3958 by Gigi unless an Equivalent_Type is specified. */
3959 case E_Class_Wide_Type
:
3960 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
3961 maybe_present
= true;
3965 case E_Task_Subtype
:
3966 case E_Protected_Type
:
3967 case E_Protected_Subtype
:
3968 if (type_annotate_only
&& No (gnat_equiv_type
))
3969 gnu_type
= void_type_node
;
3971 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
3973 maybe_present
= true;
3977 gnu_decl
= create_label_decl (gnu_entity_id
);
3982 /* Nothing at all to do here, so just return an ERROR_MARK and claim
3983 we've already saved it, so we don't try to. */
3984 gnu_decl
= error_mark_node
;
3992 /* If we had a case where we evaluated another type and it might have
3993 defined this one, handle it here. */
3994 if (maybe_present
&& present_gnu_tree (gnat_entity
))
3996 gnu_decl
= get_gnu_tree (gnat_entity
);
4000 /* If we are processing a type and there is either no decl for it or
4001 we just made one, do some common processing for the type, such as
4002 handling alignment and possible padding. */
4004 if ((!gnu_decl
|| this_made_decl
) && IN (kind
, Type_Kind
))
4006 if (Is_Tagged_Type (gnat_entity
)
4007 || Is_Class_Wide_Equivalent_Type (gnat_entity
))
4008 TYPE_ALIGN_OK (gnu_type
) = 1;
4010 if (AGGREGATE_TYPE_P (gnu_type
) && Is_By_Reference_Type (gnat_entity
))
4011 TYPE_BY_REFERENCE_P (gnu_type
) = 1;
4013 /* ??? Don't set the size for a String_Literal since it is either
4014 confirming or we don't handle it properly (if the low bound is
4016 if (!gnu_size
&& kind
!= E_String_Literal_Subtype
)
4017 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
, gnat_entity
,
4019 Has_Size_Clause (gnat_entity
));
4021 /* If a size was specified, see if we can make a new type of that size
4022 by rearranging the type, for example from a fat to a thin pointer. */
4026 = make_type_from_size (gnu_type
, gnu_size
,
4027 Has_Biased_Representation (gnat_entity
));
4029 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0)
4030 && operand_equal_p (rm_size (gnu_type
), gnu_size
, 0))
4034 /* If the alignment hasn't already been processed and this is
4035 not an unconstrained array, see if an alignment is specified.
4036 If not, we pick a default alignment for atomic objects. */
4037 if (align
!= 0 || TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4039 else if (Known_Alignment (gnat_entity
))
4040 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
4041 TYPE_ALIGN (gnu_type
));
4042 else if (Is_Atomic (gnat_entity
) && !gnu_size
4043 && host_integerp (TYPE_SIZE (gnu_type
), 1)
4044 && integer_pow2p (TYPE_SIZE (gnu_type
)))
4045 align
= MIN (BIGGEST_ALIGNMENT
,
4046 tree_low_cst (TYPE_SIZE (gnu_type
), 1));
4047 else if (Is_Atomic (gnat_entity
) && gnu_size
4048 && host_integerp (gnu_size
, 1)
4049 && integer_pow2p (gnu_size
))
4050 align
= MIN (BIGGEST_ALIGNMENT
, tree_low_cst (gnu_size
, 1));
4052 /* See if we need to pad the type. If we did, and made a record,
4053 the name of the new type may be changed. So get it back for
4054 us when we make the new TYPE_DECL below. */
4055 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
, "PAD",
4056 true, definition
, false);
4057 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4058 && TYPE_IS_PADDING_P (gnu_type
))
4060 gnu_entity_id
= TYPE_NAME (gnu_type
);
4061 if (TREE_CODE (gnu_entity_id
) == TYPE_DECL
)
4062 gnu_entity_id
= DECL_NAME (gnu_entity_id
);
4065 set_rm_size (RM_Size (gnat_entity
), gnu_type
, gnat_entity
);
4067 /* If we are at global level, GCC will have applied variable_size to
4068 the type, but that won't have done anything. So, if it's not
4069 a constant or self-referential, call elaborate_expression_1 to
4070 make a variable for the size rather than calculating it each time.
4071 Handle both the RM size and the actual size. */
4072 if (global_bindings_p ()
4073 && TYPE_SIZE (gnu_type
)
4074 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
))
4075 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
4077 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4078 && operand_equal_p (TYPE_ADA_SIZE (gnu_type
),
4079 TYPE_SIZE (gnu_type
), 0))
4081 TYPE_SIZE (gnu_type
)
4082 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
4083 TYPE_SIZE (gnu_type
),
4084 get_identifier ("SIZE"),
4086 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_SIZE (gnu_type
));
4090 TYPE_SIZE (gnu_type
)
4091 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
4092 TYPE_SIZE (gnu_type
),
4093 get_identifier ("SIZE"),
4096 /* ??? For now, store the size as a multiple of the alignment
4097 in bytes so that we can see the alignment from the tree. */
4098 TYPE_SIZE_UNIT (gnu_type
)
4100 (MULT_EXPR
, sizetype
,
4101 elaborate_expression_1
4102 (gnat_entity
, gnat_entity
,
4103 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
4104 TYPE_SIZE_UNIT (gnu_type
),
4105 size_int (TYPE_ALIGN (gnu_type
)
4107 get_identifier ("SIZE_A_UNIT"),
4109 size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
4111 if (TREE_CODE (gnu_type
) == RECORD_TYPE
)
4114 elaborate_expression_1 (gnat_entity
,
4116 TYPE_ADA_SIZE (gnu_type
),
4117 get_identifier ("RM_SIZE"),
4122 /* If this is a record type or subtype, call elaborate_expression_1 on
4123 any field position. Do this for both global and local types.
4124 Skip any fields that we haven't made trees for to avoid problems with
4125 class wide types. */
4126 if (IN (kind
, Record_Kind
))
4127 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
4128 gnat_temp
= Next_Entity (gnat_temp
))
4129 if (Ekind (gnat_temp
) == E_Component
&& present_gnu_tree (gnat_temp
))
4131 tree gnu_field
= get_gnu_tree (gnat_temp
);
4133 /* ??? Unfortunately, GCC needs to be able to prove the
4134 alignment of this offset and if it's a variable, it can't.
4135 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4136 right now, we have to put in an explicit multiply and
4137 divide by that value. */
4138 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field
)))
4140 DECL_FIELD_OFFSET (gnu_field
)
4142 (MULT_EXPR
, sizetype
,
4143 elaborate_expression_1
4144 (gnat_temp
, gnat_temp
,
4145 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
4146 DECL_FIELD_OFFSET (gnu_field
),
4147 size_int (DECL_OFFSET_ALIGN (gnu_field
)
4149 get_identifier ("OFFSET"),
4151 size_int (DECL_OFFSET_ALIGN (gnu_field
) / BITS_PER_UNIT
));
4153 /* ??? The context of gnu_field is not necessarily gnu_type so
4154 the MULT_EXPR node built above may not be marked by the call
4155 to create_type_decl below. Mark it manually for now. */
4156 if (global_bindings_p ())
4157 TREE_VISITED (DECL_FIELD_OFFSET (gnu_field
)) = 1;
4161 gnu_type
= build_qualified_type (gnu_type
,
4162 (TYPE_QUALS (gnu_type
)
4163 | (TYPE_QUAL_VOLATILE
4164 * Treat_As_Volatile (gnat_entity
))));
4166 if (Is_Atomic (gnat_entity
))
4167 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
4169 if (Present (Alignment_Clause (gnat_entity
)))
4170 TYPE_USER_ALIGN (gnu_type
) = 1;
4172 if (Universal_Aliasing (gnat_entity
))
4173 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type
)) = 1;
4176 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
4177 !Comes_From_Source (gnat_entity
),
4178 debug_info_p
, gnat_entity
);
4180 TREE_TYPE (gnu_decl
) = gnu_type
;
4183 if (IN (kind
, Type_Kind
) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
)))
4185 gnu_type
= TREE_TYPE (gnu_decl
);
4187 /* Back-annotate the Alignment of the type if not already in the
4188 tree. Likewise for sizes. */
4189 if (Unknown_Alignment (gnat_entity
))
4190 Set_Alignment (gnat_entity
,
4191 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
4193 if (Unknown_Esize (gnat_entity
) && TYPE_SIZE (gnu_type
))
4195 /* If the size is self-referential, we annotate the maximum
4196 value of that size. */
4197 tree gnu_size
= TYPE_SIZE (gnu_type
);
4199 if (CONTAINS_PLACEHOLDER_P (gnu_size
))
4200 gnu_size
= max_size (gnu_size
, true);
4202 Set_Esize (gnat_entity
, annotate_value (gnu_size
));
4204 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
4206 /* In this mode the tag and the parent components are not
4207 generated by the front-end, so the sizes must be adjusted
4209 int size_offset
, new_size
;
4211 if (Is_Derived_Type (gnat_entity
))
4214 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity
))));
4215 Set_Alignment (gnat_entity
,
4216 Alignment (Etype (Base_Type (gnat_entity
))));
4219 size_offset
= POINTER_SIZE
;
4221 new_size
= UI_To_Int (Esize (gnat_entity
)) + size_offset
;
4222 Set_Esize (gnat_entity
,
4223 UI_From_Int (((new_size
+ (POINTER_SIZE
- 1))
4224 / POINTER_SIZE
) * POINTER_SIZE
));
4225 Set_RM_Size (gnat_entity
, Esize (gnat_entity
));
4229 if (Unknown_RM_Size (gnat_entity
) && rm_size (gnu_type
))
4230 Set_RM_Size (gnat_entity
, annotate_value (rm_size (gnu_type
)));
4233 if (!Comes_From_Source (gnat_entity
) && DECL_P (gnu_decl
))
4234 DECL_ARTIFICIAL (gnu_decl
) = 1;
4236 if (!debug_info_p
&& DECL_P (gnu_decl
)
4237 && TREE_CODE (gnu_decl
) != FUNCTION_DECL
4238 && No (Renamed_Object (gnat_entity
)))
4239 DECL_IGNORED_P (gnu_decl
) = 1;
4241 /* If we haven't already, associate the ..._DECL node that we just made with
4242 the input GNAT entity node. */
4244 save_gnu_tree (gnat_entity
, gnu_decl
, false);
4246 /* If this is an enumeral or floating-point type, we were not able to set
4247 the bounds since they refer to the type. These bounds are always static.
4249 For enumeration types, also write debugging information and declare the
4250 enumeration literal table, if needed. */
4252 if ((kind
== E_Enumeration_Type
&& Present (First_Literal (gnat_entity
)))
4253 || (kind
== E_Floating_Point_Type
&& !Vax_Float (gnat_entity
)))
4255 tree gnu_scalar_type
= gnu_type
;
4257 /* If this is a padded type, we need to use the underlying type. */
4258 if (TREE_CODE (gnu_scalar_type
) == RECORD_TYPE
4259 && TYPE_IS_PADDING_P (gnu_scalar_type
))
4260 gnu_scalar_type
= TREE_TYPE (TYPE_FIELDS (gnu_scalar_type
));
4262 /* If this is a floating point type and we haven't set a floating
4263 point type yet, use this in the evaluation of the bounds. */
4264 if (!longest_float_type_node
&& kind
== E_Floating_Point_Type
)
4265 longest_float_type_node
= gnu_type
;
4267 TYPE_MIN_VALUE (gnu_scalar_type
)
4268 = gnat_to_gnu (Type_Low_Bound (gnat_entity
));
4269 TYPE_MAX_VALUE (gnu_scalar_type
)
4270 = gnat_to_gnu (Type_High_Bound (gnat_entity
));
4272 if (TREE_CODE (gnu_scalar_type
) == ENUMERAL_TYPE
)
4274 TYPE_STUB_DECL (gnu_scalar_type
) = gnu_decl
;
4276 /* Since this has both a typedef and a tag, avoid outputting
4278 DECL_ARTIFICIAL (gnu_decl
) = 1;
4279 rest_of_type_compilation (gnu_scalar_type
, global_bindings_p ());
4283 /* If we deferred processing of incomplete types, re-enable it. If there
4284 were no other disables and we have some to process, do so. */
4285 if (this_deferred
&& --defer_incomplete_level
== 0)
4287 if (defer_incomplete_list
)
4289 struct incomplete
*incp
, *next
;
4291 /* We are back to level 0 for the deferring of incomplete types.
4292 But processing these incomplete types below may itself require
4293 deferring, so preserve what we have and restart from scratch. */
4294 incp
= defer_incomplete_list
;
4295 defer_incomplete_list
= NULL
;
4297 /* For finalization, however, all types must be complete so we
4298 cannot do the same because deferred incomplete types may end up
4299 referencing each other. Process them all recursively first. */
4300 defer_finalize_level
++;
4302 for (; incp
; incp
= next
)
4307 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4308 gnat_to_gnu_type (incp
->full_type
));
4312 defer_finalize_level
--;
4315 /* All the deferred incomplete types have been processed so we can
4316 now proceed with the finalization of the deferred types. */
4317 if (defer_finalize_level
== 0 && defer_finalize_list
)
4319 int toplev
= global_bindings_p ();
4323 for (i
= 0; VEC_iterate (tree
, defer_finalize_list
, i
, t
); i
++)
4324 rest_of_decl_compilation (t
, toplev
, 0);
4326 VEC_free (tree
, heap
, defer_finalize_list
);
4330 /* If we are not defining this type, see if it's in the incomplete list.
4331 If so, handle that list entry now. */
4332 else if (!definition
)
4334 struct incomplete
*incp
;
4336 for (incp
= defer_incomplete_list
; incp
; incp
= incp
->next
)
4337 if (incp
->old_type
&& incp
->full_type
== gnat_entity
)
4339 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4340 TREE_TYPE (gnu_decl
));
4341 incp
->old_type
= NULL_TREE
;
4348 if (Is_Packed_Array_Type (gnat_entity
)
4349 && Is_Itype (Associated_Node_For_Itype (gnat_entity
))
4350 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity
)))
4351 && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity
)))
4352 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity
), NULL_TREE
, 0);
4357 /* Similar, but if the returned value is a COMPONENT_REF, return the
4361 gnat_to_gnu_field_decl (Entity_Id gnat_entity
)
4363 tree gnu_field
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4365 if (TREE_CODE (gnu_field
) == COMPONENT_REF
)
4366 gnu_field
= TREE_OPERAND (gnu_field
, 1);
4371 /* Wrap up compilation of T, a TYPE_DECL, possibly deferring it. */
4374 rest_of_type_decl_compilation (tree t
)
4376 /* We need to defer finalizing the type if incomplete types
4377 are being deferred or if they are being processed. */
4378 if (defer_incomplete_level
|| defer_finalize_level
)
4379 VEC_safe_push (tree
, heap
, defer_finalize_list
, t
);
4381 rest_of_decl_compilation (t
, global_bindings_p (), 0);
4384 /* Finalize any From_With_Type incomplete types. We do this after processing
4385 our compilation unit and after processing its spec, if this is a body. */
4388 finalize_from_with_types (void)
4390 struct incomplete
*incp
= defer_limited_with
;
4391 struct incomplete
*next
;
4393 defer_limited_with
= 0;
4394 for (; incp
; incp
= next
)
4398 if (incp
->old_type
!= 0)
4399 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4400 gnat_to_gnu_type (incp
->full_type
));
4405 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4406 kind of type (such E_Task_Type) that has a different type which Gigi
4407 uses for its representation. If the type does not have a special type
4408 for its representation, return GNAT_ENTITY. If a type is supposed to
4409 exist, but does not, abort unless annotating types, in which case
4410 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4413 Gigi_Equivalent_Type (Entity_Id gnat_entity
)
4415 Entity_Id gnat_equiv
= gnat_entity
;
4417 if (No (gnat_entity
))
4420 switch (Ekind (gnat_entity
))
4422 case E_Class_Wide_Subtype
:
4423 if (Present (Equivalent_Type (gnat_entity
)))
4424 gnat_equiv
= Equivalent_Type (gnat_entity
);
4427 case E_Access_Protected_Subprogram_Type
:
4428 case E_Anonymous_Access_Protected_Subprogram_Type
:
4429 gnat_equiv
= Equivalent_Type (gnat_entity
);
4432 case E_Class_Wide_Type
:
4433 gnat_equiv
= ((Present (Equivalent_Type (gnat_entity
)))
4434 ? Equivalent_Type (gnat_entity
)
4435 : Root_Type (gnat_entity
));
4439 case E_Task_Subtype
:
4440 case E_Protected_Type
:
4441 case E_Protected_Subtype
:
4442 gnat_equiv
= Corresponding_Record_Type (gnat_entity
);
4449 gcc_assert (Present (gnat_equiv
) || type_annotate_only
);
4453 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
4454 using MECH as its passing mechanism, to be placed in the parameter
4455 list built for GNAT_SUBPROG. Assume a foreign convention for the
4456 latter if FOREIGN is true. Also set CICO to true if the parameter
4457 must use the copy-in copy-out implementation mechanism.
4459 The returned tree is a PARM_DECL, except for those cases where no
4460 parameter needs to be actually passed to the subprogram; the type
4461 of this "shadow" parameter is then returned instead. */
4464 gnat_to_gnu_param (Entity_Id gnat_param
, Mechanism_Type mech
,
4465 Entity_Id gnat_subprog
, bool foreign
, bool *cico
)
4467 tree gnu_param_name
= get_entity_name (gnat_param
);
4468 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
4469 bool in_param
= (Ekind (gnat_param
) == E_In_Parameter
);
4470 /* The parameter can be indirectly modified if its address is taken. */
4471 bool ro_param
= in_param
&& !Address_Taken (gnat_param
);
4472 bool by_return
= false, by_component_ptr
= false, by_ref
= false;
4475 /* Copy-return is used only for the first parameter of a valued procedure.
4476 It's a copy mechanism for which a parameter is never allocated. */
4477 if (mech
== By_Copy_Return
)
4479 gcc_assert (Ekind (gnat_param
) == E_Out_Parameter
);
4484 /* If this is either a foreign function or if the underlying type won't
4485 be passed by reference, strip off possible padding type. */
4486 if (TREE_CODE (gnu_param_type
) == RECORD_TYPE
4487 && TYPE_IS_PADDING_P (gnu_param_type
))
4489 tree unpadded_type
= TREE_TYPE (TYPE_FIELDS (gnu_param_type
));
4491 if (mech
== By_Reference
4493 || (!must_pass_by_ref (unpadded_type
)
4494 && (mech
== By_Copy
|| !default_pass_by_ref (unpadded_type
))))
4495 gnu_param_type
= unpadded_type
;
4498 /* If this is a read-only parameter, make a variant of the type that is
4499 read-only. ??? However, if this is an unconstrained array, that type
4500 can be very complex, so skip it for now. Likewise for any other
4501 self-referential type. */
4503 && TREE_CODE (gnu_param_type
) != UNCONSTRAINED_ARRAY_TYPE
4504 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type
)))
4505 gnu_param_type
= build_qualified_type (gnu_param_type
,
4506 (TYPE_QUALS (gnu_param_type
)
4507 | TYPE_QUAL_CONST
));
4509 /* For foreign conventions, pass arrays as pointers to the element type.
4510 First check for unconstrained array and get the underlying array. */
4511 if (foreign
&& TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4513 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type
))));
4515 /* VMS descriptors are themselves passed by reference. */
4516 if (mech
== By_Descriptor
)
4518 = build_pointer_type (build_vms_descriptor (gnu_param_type
,
4519 Mechanism (gnat_param
),
4522 /* Arrays are passed as pointers to element type for foreign conventions. */
4525 && TREE_CODE (gnu_param_type
) == ARRAY_TYPE
)
4527 /* Strip off any multi-dimensional entries, then strip
4528 off the last array to get the component type. */
4529 while (TREE_CODE (TREE_TYPE (gnu_param_type
)) == ARRAY_TYPE
4530 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type
)))
4531 gnu_param_type
= TREE_TYPE (gnu_param_type
);
4533 by_component_ptr
= true;
4534 gnu_param_type
= TREE_TYPE (gnu_param_type
);
4537 gnu_param_type
= build_qualified_type (gnu_param_type
,
4538 (TYPE_QUALS (gnu_param_type
)
4539 | TYPE_QUAL_CONST
));
4541 gnu_param_type
= build_pointer_type (gnu_param_type
);
4544 /* Fat pointers are passed as thin pointers for foreign conventions. */
4545 else if (foreign
&& TYPE_FAT_POINTER_P (gnu_param_type
))
4547 = make_type_from_size (gnu_param_type
, size_int (POINTER_SIZE
), 0);
4549 /* If we must pass or were requested to pass by reference, do so.
4550 If we were requested to pass by copy, do so.
4551 Otherwise, for foreign conventions, pass In Out or Out parameters
4552 or aggregates by reference. For COBOL and Fortran, pass all
4553 integer and FP types that way too. For Convention Ada, use
4554 the standard Ada default. */
4555 else if (must_pass_by_ref (gnu_param_type
)
4556 || mech
== By_Reference
4559 && (!in_param
|| AGGREGATE_TYPE_P (gnu_param_type
)))
4561 && (Convention (gnat_subprog
) == Convention_Fortran
4562 || Convention (gnat_subprog
) == Convention_COBOL
)
4563 && (INTEGRAL_TYPE_P (gnu_param_type
)
4564 || FLOAT_TYPE_P (gnu_param_type
)))
4566 && default_pass_by_ref (gnu_param_type
)))))
4568 gnu_param_type
= build_reference_type (gnu_param_type
);
4572 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
4576 if (mech
== By_Copy
&& (by_ref
|| by_component_ptr
))
4577 post_error ("?cannot pass & by copy", gnat_param
);
4579 /* If this is an Out parameter that isn't passed by reference and isn't
4580 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
4581 it will be a VAR_DECL created when we process the procedure, so just
4582 return its type. For the special parameter of a valued procedure,
4585 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
4586 Out parameters with discriminants or implicit initial values to be
4587 handled like In Out parameters. These type are normally built as
4588 aggregates, hence passed by reference, except for some packed arrays
4589 which end up encoded in special integer types.
4591 The exception we need to make is then for packed arrays of records
4592 with discriminants or implicit initial values. We have no light/easy
4593 way to check for the latter case, so we merely check for packed arrays
4594 of records. This may lead to useless copy-in operations, but in very
4595 rare cases only, as these would be exceptions in a set of already
4596 exceptional situations. */
4597 if (Ekind (gnat_param
) == E_Out_Parameter
4600 || (mech
!= By_Descriptor
4601 && !POINTER_TYPE_P (gnu_param_type
)
4602 && !AGGREGATE_TYPE_P (gnu_param_type
)))
4603 && !(Is_Array_Type (Etype (gnat_param
))
4604 && Is_Packed (Etype (gnat_param
))
4605 && Is_Composite_Type (Component_Type (Etype (gnat_param
)))))
4606 return gnu_param_type
;
4608 gnu_param
= create_param_decl (gnu_param_name
, gnu_param_type
,
4609 ro_param
|| by_ref
|| by_component_ptr
);
4610 DECL_BY_REF_P (gnu_param
) = by_ref
;
4611 DECL_BY_COMPONENT_PTR_P (gnu_param
) = by_component_ptr
;
4612 DECL_BY_DESCRIPTOR_P (gnu_param
) = (mech
== By_Descriptor
);
4613 DECL_POINTS_TO_READONLY_P (gnu_param
)
4614 = (ro_param
&& (by_ref
|| by_component_ptr
));
4616 /* If no Mechanism was specified, indicate what we're using, then
4617 back-annotate it. */
4618 if (mech
== Default
)
4619 mech
= (by_ref
|| by_component_ptr
) ? By_Reference
: By_Copy
;
4621 Set_Mechanism (gnat_param
, mech
);
4625 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
4628 same_discriminant_p (Entity_Id discr1
, Entity_Id discr2
)
4630 while (Present (Corresponding_Discriminant (discr1
)))
4631 discr1
= Corresponding_Discriminant (discr1
);
4633 while (Present (Corresponding_Discriminant (discr2
)))
4634 discr2
= Corresponding_Discriminant (discr2
);
4637 Original_Record_Component (discr1
) == Original_Record_Component (discr2
);
4640 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
4641 a non-aliased component in the back-end sense. */
4644 array_type_has_nonaliased_component (Entity_Id gnat_type
, tree gnu_type
)
4646 /* If the type below this is a multi-array type, then
4647 this does not have aliased components. */
4648 if (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
4649 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
4652 if (Has_Aliased_Components (gnat_type
))
4655 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type
));
4658 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4659 be elaborated at the point of its definition, but do nothing else. */
4662 elaborate_entity (Entity_Id gnat_entity
)
4664 switch (Ekind (gnat_entity
))
4666 case E_Signed_Integer_Subtype
:
4667 case E_Modular_Integer_Subtype
:
4668 case E_Enumeration_Subtype
:
4669 case E_Ordinary_Fixed_Point_Subtype
:
4670 case E_Decimal_Fixed_Point_Subtype
:
4671 case E_Floating_Point_Subtype
:
4673 Node_Id gnat_lb
= Type_Low_Bound (gnat_entity
);
4674 Node_Id gnat_hb
= Type_High_Bound (gnat_entity
);
4676 /* ??? Tests for avoiding static constraint error expression
4677 is needed until the front stops generating bogus conversions
4678 on bounds of real types. */
4680 if (!Raises_Constraint_Error (gnat_lb
))
4681 elaborate_expression (gnat_lb
, gnat_entity
, get_identifier ("L"),
4682 1, 0, Needs_Debug_Info (gnat_entity
));
4683 if (!Raises_Constraint_Error (gnat_hb
))
4684 elaborate_expression (gnat_hb
, gnat_entity
, get_identifier ("U"),
4685 1, 0, Needs_Debug_Info (gnat_entity
));
4691 Node_Id full_definition
= Declaration_Node (gnat_entity
);
4692 Node_Id record_definition
= Type_Definition (full_definition
);
4694 /* If this is a record extension, go a level further to find the
4695 record definition. */
4696 if (Nkind (record_definition
) == N_Derived_Type_Definition
)
4697 record_definition
= Record_Extension_Part (record_definition
);
4701 case E_Record_Subtype
:
4702 case E_Private_Subtype
:
4703 case E_Limited_Private_Subtype
:
4704 case E_Record_Subtype_With_Private
:
4705 if (Is_Constrained (gnat_entity
)
4706 && Has_Discriminants (Base_Type (gnat_entity
))
4707 && Present (Discriminant_Constraint (gnat_entity
)))
4709 Node_Id gnat_discriminant_expr
;
4710 Entity_Id gnat_field
;
4712 for (gnat_field
= First_Discriminant (Base_Type (gnat_entity
)),
4713 gnat_discriminant_expr
4714 = First_Elmt (Discriminant_Constraint (gnat_entity
));
4715 Present (gnat_field
);
4716 gnat_field
= Next_Discriminant (gnat_field
),
4717 gnat_discriminant_expr
= Next_Elmt (gnat_discriminant_expr
))
4718 /* ??? For now, ignore access discriminants. */
4719 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr
))))
4720 elaborate_expression (Node (gnat_discriminant_expr
),
4722 get_entity_name (gnat_field
), 1, 0, 0);
4729 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
4730 any entities on its entity chain similarly. */
4733 mark_out_of_scope (Entity_Id gnat_entity
)
4735 Entity_Id gnat_sub_entity
;
4736 unsigned int kind
= Ekind (gnat_entity
);
4738 /* If this has an entity list, process all in the list. */
4739 if (IN (kind
, Class_Wide_Kind
) || IN (kind
, Concurrent_Kind
)
4740 || IN (kind
, Private_Kind
)
4741 || kind
== E_Block
|| kind
== E_Entry
|| kind
== E_Entry_Family
4742 || kind
== E_Function
|| kind
== E_Generic_Function
4743 || kind
== E_Generic_Package
|| kind
== E_Generic_Procedure
4744 || kind
== E_Loop
|| kind
== E_Operator
|| kind
== E_Package
4745 || kind
== E_Package_Body
|| kind
== E_Procedure
4746 || kind
== E_Record_Type
|| kind
== E_Record_Subtype
4747 || kind
== E_Subprogram_Body
|| kind
== E_Subprogram_Type
)
4748 for (gnat_sub_entity
= First_Entity (gnat_entity
);
4749 Present (gnat_sub_entity
);
4750 gnat_sub_entity
= Next_Entity (gnat_sub_entity
))
4751 if (Scope (gnat_sub_entity
) == gnat_entity
4752 && gnat_sub_entity
!= gnat_entity
)
4753 mark_out_of_scope (gnat_sub_entity
);
4755 /* Now clear this if it has been defined, but only do so if it isn't
4756 a subprogram or parameter. We could refine this, but it isn't
4757 worth it. If this is statically allocated, it is supposed to
4758 hang around out of cope. */
4759 if (present_gnu_tree (gnat_entity
) && !Is_Statically_Allocated (gnat_entity
)
4760 && kind
!= E_Procedure
&& kind
!= E_Function
&& !IN (kind
, Formal_Kind
))
4762 save_gnu_tree (gnat_entity
, NULL_TREE
, true);
4763 save_gnu_tree (gnat_entity
, error_mark_node
, true);
4767 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
4768 is a multi-dimensional array type, do this recursively. */
4771 copy_alias_set (tree gnu_new_type
, tree gnu_old_type
)
4773 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
4774 of a one-dimensional array, since the padding has the same alias set
4775 as the field type, but if it's a multi-dimensional array, we need to
4776 see the inner types. */
4777 while (TREE_CODE (gnu_old_type
) == RECORD_TYPE
4778 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type
)
4779 || TYPE_IS_PADDING_P (gnu_old_type
)))
4780 gnu_old_type
= TREE_TYPE (TYPE_FIELDS (gnu_old_type
));
4782 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
4783 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
4784 so we need to go down to what does. */
4785 if (TREE_CODE (gnu_old_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4787 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type
))));
4789 if (TREE_CODE (gnu_new_type
) == ARRAY_TYPE
4790 && TREE_CODE (TREE_TYPE (gnu_new_type
)) == ARRAY_TYPE
4791 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type
)))
4792 copy_alias_set (TREE_TYPE (gnu_new_type
), TREE_TYPE (gnu_old_type
));
4794 TYPE_ALIAS_SET (gnu_new_type
) = get_alias_set (gnu_old_type
);
4795 record_component_aliases (gnu_new_type
);
4798 /* Return a TREE_LIST describing the substitutions needed to reflect
4799 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
4800 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
4801 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
4802 gives the tree for the discriminant and TREE_VALUES is the replacement
4803 value. They are in the form of operands to substitute_in_expr.
4804 DEFINITION is as in gnat_to_gnu_entity. */
4807 substitution_list (Entity_Id gnat_subtype
, Entity_Id gnat_type
,
4808 tree gnu_list
, bool definition
)
4810 Entity_Id gnat_discrim
;
4814 gnat_type
= Implementation_Base_Type (gnat_subtype
);
4816 if (Has_Discriminants (gnat_type
))
4817 for (gnat_discrim
= First_Stored_Discriminant (gnat_type
),
4818 gnat_value
= First_Elmt (Stored_Constraint (gnat_subtype
));
4819 Present (gnat_discrim
);
4820 gnat_discrim
= Next_Stored_Discriminant (gnat_discrim
),
4821 gnat_value
= Next_Elmt (gnat_value
))
4822 /* Ignore access discriminants. */
4823 if (!Is_Access_Type (Etype (Node (gnat_value
))))
4824 gnu_list
= tree_cons (gnat_to_gnu_field_decl (gnat_discrim
),
4825 elaborate_expression
4826 (Node (gnat_value
), gnat_subtype
,
4827 get_entity_name (gnat_discrim
), definition
,
4834 /* Return true if the size represented by GNU_SIZE can be handled by an
4835 allocation. If STATIC_P is true, consider only what can be done with a
4836 static allocation. */
4839 allocatable_size_p (tree gnu_size
, bool static_p
)
4841 HOST_WIDE_INT our_size
;
4843 /* If this is not a static allocation, the only case we want to forbid
4844 is an overflowing size. That will be converted into a raise a
4847 return !(TREE_CODE (gnu_size
) == INTEGER_CST
4848 && TREE_OVERFLOW (gnu_size
));
4850 /* Otherwise, we need to deal with both variable sizes and constant
4851 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
4852 since assemblers may not like very large sizes. */
4853 if (!host_integerp (gnu_size
, 1))
4856 our_size
= tree_low_cst (gnu_size
, 1);
4857 return (int) our_size
== our_size
;
4860 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
4861 NAME, ARGS and ERROR_POINT. */
4864 prepend_one_attribute_to (struct attrib
** attr_list
,
4865 enum attr_type attr_type
,
4868 Node_Id attr_error_point
)
4870 struct attrib
* attr
= (struct attrib
*) xmalloc (sizeof (struct attrib
));
4872 attr
->type
= attr_type
;
4873 attr
->name
= attr_name
;
4874 attr
->args
= attr_args
;
4875 attr
->error_point
= attr_error_point
;
4877 attr
->next
= *attr_list
;
4881 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
4884 prepend_attributes (Entity_Id gnat_entity
, struct attrib
** attr_list
)
4888 for (gnat_temp
= First_Rep_Item (gnat_entity
); Present (gnat_temp
);
4889 gnat_temp
= Next_Rep_Item (gnat_temp
))
4890 if (Nkind (gnat_temp
) == N_Pragma
)
4892 tree gnu_arg0
= NULL_TREE
, gnu_arg1
= NULL_TREE
;
4893 Node_Id gnat_assoc
= Pragma_Argument_Associations (gnat_temp
);
4894 enum attr_type etype
;
4896 if (Present (gnat_assoc
) && Present (First (gnat_assoc
))
4897 && Present (Next (First (gnat_assoc
)))
4898 && (Nkind (Expression (Next (First (gnat_assoc
))))
4899 == N_String_Literal
))
4901 gnu_arg0
= get_identifier (TREE_STRING_POINTER
4904 (First (gnat_assoc
))))));
4905 if (Present (Next (Next (First (gnat_assoc
))))
4906 && (Nkind (Expression (Next (Next (First (gnat_assoc
)))))
4907 == N_String_Literal
))
4908 gnu_arg1
= get_identifier (TREE_STRING_POINTER
4912 (First (gnat_assoc
)))))));
4915 switch (Get_Pragma_Id (Chars (gnat_temp
)))
4917 case Pragma_Machine_Attribute
:
4918 etype
= ATTR_MACHINE_ATTRIBUTE
;
4921 case Pragma_Linker_Alias
:
4922 etype
= ATTR_LINK_ALIAS
;
4925 case Pragma_Linker_Section
:
4926 etype
= ATTR_LINK_SECTION
;
4929 case Pragma_Linker_Constructor
:
4930 etype
= ATTR_LINK_CONSTRUCTOR
;
4933 case Pragma_Linker_Destructor
:
4934 etype
= ATTR_LINK_DESTRUCTOR
;
4937 case Pragma_Weak_External
:
4938 etype
= ATTR_WEAK_EXTERNAL
;
4946 /* Prepend to the list now. Make a list of the argument we might
4947 have, as GCC expects it. */
4948 prepend_one_attribute_to
4951 (gnu_arg1
!= NULL_TREE
)
4952 ? build_tree_list (NULL_TREE
, gnu_arg1
) : NULL_TREE
,
4953 Present (Next (First (gnat_assoc
)))
4954 ? Expression (Next (First (gnat_assoc
))) : gnat_temp
);
4958 /* Get the unpadded version of a GNAT type. */
4961 get_unpadded_type (Entity_Id gnat_entity
)
4963 tree type
= gnat_to_gnu_type (gnat_entity
);
4965 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
4966 type
= TREE_TYPE (TYPE_FIELDS (type
));
4971 /* Called when we need to protect a variable object using a save_expr. */
4974 maybe_variable (tree gnu_operand
)
4976 if (TREE_CONSTANT (gnu_operand
) || TREE_READONLY (gnu_operand
)
4977 || TREE_CODE (gnu_operand
) == SAVE_EXPR
4978 || TREE_CODE (gnu_operand
) == NULL_EXPR
)
4981 if (TREE_CODE (gnu_operand
) == UNCONSTRAINED_ARRAY_REF
)
4983 tree gnu_result
= build1 (UNCONSTRAINED_ARRAY_REF
,
4984 TREE_TYPE (gnu_operand
),
4985 variable_size (TREE_OPERAND (gnu_operand
, 0)));
4987 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
)
4988 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand
)));
4992 return variable_size (gnu_operand
);
4995 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
4996 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
4997 return the GCC tree to use for that expression. GNU_NAME is the
4998 qualification to use if an external name is appropriate and DEFINITION is
4999 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
5000 we need a result. Otherwise, we are just elaborating this for
5001 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
5002 purposes even if it isn't needed for code generation. */
5005 elaborate_expression (Node_Id gnat_expr
, Entity_Id gnat_entity
,
5006 tree gnu_name
, bool definition
, bool need_value
,
5011 /* If we already elaborated this expression (e.g., it was involved
5012 in the definition of a private type), use the old value. */
5013 if (present_gnu_tree (gnat_expr
))
5014 return get_gnu_tree (gnat_expr
);
5016 /* If we don't need a value and this is static or a discriminant, we
5017 don't need to do anything. */
5018 else if (!need_value
5019 && (Is_OK_Static_Expression (gnat_expr
)
5020 || (Nkind (gnat_expr
) == N_Identifier
5021 && Ekind (Entity (gnat_expr
)) == E_Discriminant
)))
5024 /* Otherwise, convert this tree to its GCC equivalent. */
5026 = elaborate_expression_1 (gnat_expr
, gnat_entity
, gnat_to_gnu (gnat_expr
),
5027 gnu_name
, definition
, need_debug
);
5029 /* Save the expression in case we try to elaborate this entity again. Since
5030 this is not a DECL, don't check it. Don't save if it's a discriminant. */
5031 if (!CONTAINS_PLACEHOLDER_P (gnu_expr
))
5032 save_gnu_tree (gnat_expr
, gnu_expr
, true);
5034 return need_value
? gnu_expr
: error_mark_node
;
5037 /* Similar, but take a GNU expression. */
5040 elaborate_expression_1 (Node_Id gnat_expr
, Entity_Id gnat_entity
,
5041 tree gnu_expr
, tree gnu_name
, bool definition
,
5044 tree gnu_decl
= NULL_TREE
;
5045 /* Strip any conversions to see if the expression is a readonly variable.
5046 ??? This really should remain readonly, but we have to think about
5047 the typing of the tree here. */
5048 tree gnu_inner_expr
= remove_conversions (gnu_expr
, true);
5049 bool expr_global
= Is_Public (gnat_entity
) || global_bindings_p ();
5052 /* In most cases, we won't see a naked FIELD_DECL here because a
5053 discriminant reference will have been replaced with a COMPONENT_REF
5054 when the type is being elaborated. However, there are some cases
5055 involving child types where we will. So convert it to a COMPONENT_REF
5056 here. We have to hope it will be at the highest level of the
5057 expression in these cases. */
5058 if (TREE_CODE (gnu_expr
) == FIELD_DECL
)
5059 gnu_expr
= build3 (COMPONENT_REF
, TREE_TYPE (gnu_expr
),
5060 build0 (PLACEHOLDER_EXPR
, DECL_CONTEXT (gnu_expr
)),
5061 gnu_expr
, NULL_TREE
);
5063 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5064 that is a constant, make a variable that is initialized to contain the
5065 bound when the package containing the definition is elaborated. If
5066 this entity is defined at top level and a bound or discriminant value
5067 isn't a constant or a reference to a discriminant, replace the bound
5068 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5069 rely here on the fact that an expression cannot contain both the
5070 discriminant and some other variable. */
5072 expr_variable
= (!CONSTANT_CLASS_P (gnu_expr
)
5073 && !(TREE_CODE (gnu_inner_expr
) == VAR_DECL
5074 && (TREE_READONLY (gnu_inner_expr
)
5075 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr
)))
5076 && !CONTAINS_PLACEHOLDER_P (gnu_expr
));
5078 /* If this is a static expression or contains a discriminant, we don't
5079 need the variable for debugging (and can't elaborate anyway if a
5082 && (Is_OK_Static_Expression (gnat_expr
)
5083 || CONTAINS_PLACEHOLDER_P (gnu_expr
)))
5086 /* Now create the variable if we need it. */
5087 if (need_debug
|| (expr_variable
&& expr_global
))
5089 = create_var_decl (create_concat_name (gnat_entity
,
5090 IDENTIFIER_POINTER (gnu_name
)),
5091 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
5092 !need_debug
, Is_Public (gnat_entity
),
5093 !definition
, false, NULL
, gnat_entity
);
5095 /* We only need to use this variable if we are in global context since GCC
5096 can do the right thing in the local case. */
5097 if (expr_global
&& expr_variable
)
5099 else if (!expr_variable
)
5102 return maybe_variable (gnu_expr
);
5105 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5106 starting bit position so that it is aligned to ALIGN bits, and leaving at
5107 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5108 record is guaranteed to get. */
5111 make_aligning_type (tree type
, unsigned int align
, tree size
,
5112 unsigned int base_align
, int room
)
5114 /* We will be crafting a record type with one field at a position set to be
5115 the next multiple of ALIGN past record'address + room bytes. We use a
5116 record placeholder to express record'address. */
5118 tree record_type
= make_node (RECORD_TYPE
);
5119 tree record
= build0 (PLACEHOLDER_EXPR
, record_type
);
5122 = convert (sizetype
, build_unary_op (ADDR_EXPR
, NULL_TREE
, record
));
5124 /* The diagram below summarizes the shape of what we manipulate:
5126 <--------- pos ---------->
5127 { +------------+-------------+-----------------+
5128 record =>{ |############| ... | field (type) |
5129 { +------------+-------------+-----------------+
5130 |<-- room -->|<- voffset ->|<---- size ----->|
5133 record_addr vblock_addr
5135 Every length is in sizetype bytes there, except "pos" which has to be
5136 set as a bit position in the GCC tree for the record. */
5138 tree room_st
= size_int (room
);
5139 tree vblock_addr_st
= size_binop (PLUS_EXPR
, record_addr_st
, room_st
);
5140 tree voffset_st
, pos
, field
;
5142 tree name
= TYPE_NAME (type
);
5144 if (TREE_CODE (name
) == TYPE_DECL
)
5145 name
= DECL_NAME (name
);
5147 TYPE_NAME (record_type
) = concat_id_with_name (name
, "_ALIGN");
5149 /* Compute VOFFSET and then POS. The next byte position multiple of some
5150 alignment after some address is obtained by "and"ing the alignment minus
5151 1 with the two's complement of the address. */
5153 voffset_st
= size_binop (BIT_AND_EXPR
,
5154 size_diffop (size_zero_node
, vblock_addr_st
),
5155 ssize_int ((align
/ BITS_PER_UNIT
) - 1));
5157 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5159 pos
= size_binop (MULT_EXPR
,
5160 convert (bitsizetype
,
5161 size_binop (PLUS_EXPR
, room_st
, voffset_st
)),
5164 /* Craft the GCC record representation. We exceptionally do everything
5165 manually here because 1) our generic circuitry is not quite ready to
5166 handle the complex position/size expressions we are setting up, 2) we
5167 have a strong simplifying factor at hand: we know the maximum possible
5168 value of voffset, and 3) we have to set/reset at least the sizes in
5169 accordance with this maximum value anyway, as we need them to convey
5170 what should be "alloc"ated for this type.
5172 Use -1 as the 'addressable' indication for the field to prevent the
5173 creation of a bitfield. We don't need one, it would have damaging
5174 consequences on the alignment computation, and create_field_decl would
5175 make one without this special argument, for instance because of the
5176 complex position expression. */
5178 field
= create_field_decl (get_identifier ("F"), type
, record_type
,
5180 TYPE_FIELDS (record_type
) = field
;
5182 TYPE_ALIGN (record_type
) = base_align
;
5183 TYPE_USER_ALIGN (record_type
) = 1;
5185 TYPE_SIZE (record_type
)
5186 = size_binop (PLUS_EXPR
,
5187 size_binop (MULT_EXPR
, convert (bitsizetype
, size
),
5189 bitsize_int (align
+ room
* BITS_PER_UNIT
));
5190 TYPE_SIZE_UNIT (record_type
)
5191 = size_binop (PLUS_EXPR
, size
,
5192 size_int (room
+ align
/ BITS_PER_UNIT
));
5194 TYPE_MODE (record_type
) = BLKmode
;
5196 copy_alias_set (record_type
, type
);
5200 /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's
5201 being used as the field type of a packed record. See if we can rewrite it
5202 as a record that has a non-BLKmode type, which we can pack tighter. If so,
5203 return the new type. If not, return the original type. */
5206 make_packable_type (tree type
)
5208 tree new_type
= make_node (TREE_CODE (type
));
5209 tree field_list
= NULL_TREE
;
5212 /* Copy the name and flags from the old type to that of the new. Note
5213 that we rely on the pointer equality created here for TYPE_NAME at
5214 the end of gnat_to_gnu. For QUAL_UNION_TYPE, also copy the size. */
5215 TYPE_NAME (new_type
) = TYPE_NAME (type
);
5216 TYPE_JUSTIFIED_MODULAR_P (new_type
) = TYPE_JUSTIFIED_MODULAR_P (type
);
5217 TYPE_CONTAINS_TEMPLATE_P (new_type
) = TYPE_CONTAINS_TEMPLATE_P (type
);
5219 if (TREE_CODE (type
) == RECORD_TYPE
)
5220 TYPE_IS_PADDING_P (new_type
) = TYPE_IS_PADDING_P (type
);
5221 else if (TREE_CODE (type
) == QUAL_UNION_TYPE
)
5223 TYPE_SIZE (new_type
) = TYPE_SIZE (type
);
5224 TYPE_SIZE_UNIT (new_type
) = TYPE_SIZE_UNIT (type
);
5227 /* Set the alignment to try for an integral type. */
5228 TYPE_ALIGN (new_type
) = ceil_alignment (tree_low_cst (TYPE_SIZE (type
), 1));
5229 TYPE_USER_ALIGN (new_type
) = 1;
5231 /* Now copy the fields, keeping the position and size. */
5232 for (old_field
= TYPE_FIELDS (type
); old_field
;
5233 old_field
= TREE_CHAIN (old_field
))
5235 tree new_field_type
= TREE_TYPE (old_field
);
5238 if (TYPE_MODE (new_field_type
) == BLKmode
5239 && (TREE_CODE (new_field_type
) == RECORD_TYPE
5240 || TREE_CODE (new_field_type
) == UNION_TYPE
5241 || TREE_CODE (new_field_type
) == QUAL_UNION_TYPE
)
5242 && host_integerp (TYPE_SIZE (new_field_type
), 1))
5243 new_field_type
= make_packable_type (new_field_type
);
5245 new_field
= create_field_decl (DECL_NAME (old_field
), new_field_type
,
5246 new_type
, TYPE_PACKED (type
),
5247 DECL_SIZE (old_field
),
5248 bit_position (old_field
),
5249 !DECL_NONADDRESSABLE_P (old_field
));
5251 DECL_INTERNAL_P (new_field
) = DECL_INTERNAL_P (old_field
);
5252 SET_DECL_ORIGINAL_FIELD
5253 (new_field
, (DECL_ORIGINAL_FIELD (old_field
)
5254 ? DECL_ORIGINAL_FIELD (old_field
) : old_field
));
5256 if (TREE_CODE (new_type
) == QUAL_UNION_TYPE
)
5257 DECL_QUALIFIER (new_field
) = DECL_QUALIFIER (old_field
);
5259 TREE_CHAIN (new_field
) = field_list
;
5260 field_list
= new_field
;
5263 finish_record_type (new_type
, nreverse (field_list
), 1, true);
5264 copy_alias_set (new_type
, type
);
5266 /* Try harder to get a packable type if necessary, for example
5267 in case the record itself contains a BLKmode field. */
5268 if (TYPE_MODE (new_type
) == BLKmode
)
5269 TYPE_MODE (new_type
)
5270 = mode_for_size_tree (TYPE_SIZE (new_type
), MODE_INT
, 1);
5272 return TYPE_MODE (new_type
) == BLKmode
? type
: new_type
;
5275 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
5276 if needed. We have already verified that SIZE and TYPE are large enough.
5278 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
5281 IS_USER_TYPE is true if we must be sure we complete the original type.
5283 DEFINITION is true if this type is being defined.
5285 SAME_RM_SIZE is true if the RM_Size of the resulting type is to be
5286 set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
5290 maybe_pad_type (tree type
, tree size
, unsigned int align
,
5291 Entity_Id gnat_entity
, const char *name_trailer
,
5292 bool is_user_type
, bool definition
, bool same_rm_size
)
5294 tree orig_size
= TYPE_SIZE (type
);
5295 unsigned int orig_align
= align
;
5299 /* If TYPE is a padded type, see if it agrees with any size and alignment
5300 we were given. If so, return the original type. Otherwise, strip
5301 off the padding, since we will either be returning the inner type
5302 or repadding it. If no size or alignment is specified, use that of
5303 the original padded type. */
5305 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
5308 || operand_equal_p (round_up (size
,
5309 MAX (align
, TYPE_ALIGN (type
))),
5310 round_up (TYPE_SIZE (type
),
5311 MAX (align
, TYPE_ALIGN (type
))),
5313 && (align
== 0 || align
== TYPE_ALIGN (type
)))
5317 size
= TYPE_SIZE (type
);
5319 align
= TYPE_ALIGN (type
);
5321 type
= TREE_TYPE (TYPE_FIELDS (type
));
5322 orig_size
= TYPE_SIZE (type
);
5325 /* If the size is either not being changed or is being made smaller (which
5326 is not done here (and is only valid for bitfields anyway), show the size
5327 isn't changing. Likewise, clear the alignment if it isn't being
5328 changed. Then return if we aren't doing anything. */
5331 && (operand_equal_p (size
, orig_size
, 0)
5332 || (TREE_CODE (orig_size
) == INTEGER_CST
5333 && tree_int_cst_lt (size
, orig_size
))))
5336 if (align
== TYPE_ALIGN (type
))
5339 if (align
== 0 && !size
)
5342 /* We used to modify the record in place in some cases, but that could
5343 generate incorrect debugging information. So make a new record
5345 record
= make_node (RECORD_TYPE
);
5347 if (Present (gnat_entity
))
5348 TYPE_NAME (record
) = create_concat_name (gnat_entity
, name_trailer
);
5350 /* If we were making a type, complete the original type and give it a
5353 create_type_decl (get_entity_name (gnat_entity
), type
,
5354 NULL
, !Comes_From_Source (gnat_entity
),
5356 && TREE_CODE (TYPE_NAME (type
)) == TYPE_DECL
5357 && DECL_IGNORED_P (TYPE_NAME (type
))),
5360 /* If we are changing the alignment and the input type is a record with
5361 BLKmode and a small constant size, try to make a form that has an
5362 integral mode. That might allow this record to have an integral mode,
5363 which will be much more efficient. There is no point in doing this if a
5364 size is specified unless it is also smaller than the biggest alignment
5365 and it is incorrect to do this if the size of the original type is not a
5366 multiple of the alignment. */
5368 && TREE_CODE (type
) == RECORD_TYPE
5369 && TYPE_MODE (type
) == BLKmode
5370 && host_integerp (orig_size
, 1)
5371 && compare_tree_int (orig_size
, BIGGEST_ALIGNMENT
) <= 0
5373 || (TREE_CODE (size
) == INTEGER_CST
5374 && compare_tree_int (size
, BIGGEST_ALIGNMENT
) <= 0))
5375 && tree_low_cst (orig_size
, 1) % align
== 0)
5376 type
= make_packable_type (type
);
5378 field
= create_field_decl (get_identifier ("F"), type
, record
, 0,
5379 NULL_TREE
, bitsize_zero_node
, 1);
5381 DECL_INTERNAL_P (field
) = 1;
5382 TYPE_SIZE (record
) = size
? size
: orig_size
;
5383 TYPE_SIZE_UNIT (record
)
5384 = (size
? convert (sizetype
,
5385 size_binop (CEIL_DIV_EXPR
, size
, bitsize_unit_node
))
5386 : TYPE_SIZE_UNIT (type
));
5388 TYPE_ALIGN (record
) = align
;
5390 TYPE_USER_ALIGN (record
) = align
;
5392 TYPE_IS_PADDING_P (record
) = 1;
5393 TYPE_VOLATILE (record
)
5394 = Present (gnat_entity
) && Treat_As_Volatile (gnat_entity
);
5395 /* Do not finalize it until after the auxiliary record is built. */
5396 finish_record_type (record
, field
, 1, true);
5398 /* Keep the RM_Size of the padded record as that of the old record
5400 SET_TYPE_ADA_SIZE (record
, same_rm_size
? size
: rm_size (type
));
5402 /* Unless debugging information isn't being written for the input type,
5403 write a record that shows what we are a subtype of and also make a
5404 variable that indicates our size, if variable. */
5405 if (TYPE_NAME (record
)
5406 && AGGREGATE_TYPE_P (type
)
5407 && (TREE_CODE (TYPE_NAME (type
)) != TYPE_DECL
5408 || !DECL_IGNORED_P (TYPE_NAME (type
))))
5410 tree marker
= make_node (RECORD_TYPE
);
5411 tree name
= TYPE_NAME (record
);
5412 tree orig_name
= TYPE_NAME (type
);
5414 if (TREE_CODE (name
) == TYPE_DECL
)
5415 name
= DECL_NAME (name
);
5417 if (TREE_CODE (orig_name
) == TYPE_DECL
)
5418 orig_name
= DECL_NAME (orig_name
);
5420 TYPE_NAME (marker
) = concat_id_with_name (name
, "XVS");
5421 finish_record_type (marker
,
5422 create_field_decl (orig_name
, integer_type_node
,
5423 marker
, 0, NULL_TREE
, NULL_TREE
,
5427 if (size
&& TREE_CODE (size
) != INTEGER_CST
&& definition
)
5428 create_var_decl (concat_id_with_name (name
, "XVZ"), NULL_TREE
,
5429 bitsizetype
, TYPE_SIZE (record
), false, false, false,
5430 false, NULL
, gnat_entity
);
5433 rest_of_record_type_compilation (record
);
5435 /* If the size was widened explicitly, maybe give a warning. Take the
5436 original size as the maximum size of the input if there was an
5437 unconstrained record involved and round it up to the specified alignment,
5438 if one was specified. */
5439 if (CONTAINS_PLACEHOLDER_P (orig_size
))
5440 orig_size
= max_size (orig_size
, true);
5443 orig_size
= round_up (orig_size
, align
);
5445 if (size
&& Present (gnat_entity
)
5446 && !operand_equal_p (size
, orig_size
, 0)
5447 && !(TREE_CODE (size
) == INTEGER_CST
5448 && TREE_CODE (orig_size
) == INTEGER_CST
5449 && tree_int_cst_lt (size
, orig_size
)))
5451 Node_Id gnat_error_node
= Empty
;
5453 if (Is_Packed_Array_Type (gnat_entity
))
5454 gnat_entity
= Associated_Node_For_Itype (gnat_entity
);
5456 if ((Ekind (gnat_entity
) == E_Component
5457 || Ekind (gnat_entity
) == E_Discriminant
)
5458 && Present (Component_Clause (gnat_entity
)))
5459 gnat_error_node
= Last_Bit (Component_Clause (gnat_entity
));
5460 else if (Present (Size_Clause (gnat_entity
)))
5461 gnat_error_node
= Expression (Size_Clause (gnat_entity
));
5463 /* Generate message only for entities that come from source, since
5464 if we have an entity created by expansion, the message will be
5465 generated for some other corresponding source entity. */
5466 if (Comes_From_Source (gnat_entity
) && Present (gnat_error_node
))
5467 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node
,
5469 size_diffop (size
, orig_size
));
5471 else if (*name_trailer
== 'C' && !Is_Internal (gnat_entity
))
5472 post_error_ne_tree ("component of& padded{ by ^ bits}?",
5473 gnat_entity
, gnat_entity
,
5474 size_diffop (size
, orig_size
));
5480 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
5481 the value passed against the list of choices. */
5484 choices_to_gnu (tree operand
, Node_Id choices
)
5488 tree result
= integer_zero_node
;
5489 tree this_test
, low
= 0, high
= 0, single
= 0;
5491 for (choice
= First (choices
); Present (choice
); choice
= Next (choice
))
5493 switch (Nkind (choice
))
5496 low
= gnat_to_gnu (Low_Bound (choice
));
5497 high
= gnat_to_gnu (High_Bound (choice
));
5499 /* There's no good type to use here, so we might as well use
5500 integer_type_node. */
5502 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
5503 build_binary_op (GE_EXPR
, integer_type_node
,
5505 build_binary_op (LE_EXPR
, integer_type_node
,
5510 case N_Subtype_Indication
:
5511 gnat_temp
= Range_Expression (Constraint (choice
));
5512 low
= gnat_to_gnu (Low_Bound (gnat_temp
));
5513 high
= gnat_to_gnu (High_Bound (gnat_temp
));
5516 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
5517 build_binary_op (GE_EXPR
, integer_type_node
,
5519 build_binary_op (LE_EXPR
, integer_type_node
,
5524 case N_Expanded_Name
:
5525 /* This represents either a subtype range, an enumeration
5526 literal, or a constant Ekind says which. If an enumeration
5527 literal or constant, fall through to the next case. */
5528 if (Ekind (Entity (choice
)) != E_Enumeration_Literal
5529 && Ekind (Entity (choice
)) != E_Constant
)
5531 tree type
= gnat_to_gnu_type (Entity (choice
));
5533 low
= TYPE_MIN_VALUE (type
);
5534 high
= TYPE_MAX_VALUE (type
);
5537 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
5538 build_binary_op (GE_EXPR
, integer_type_node
,
5540 build_binary_op (LE_EXPR
, integer_type_node
,
5544 /* ... fall through ... */
5545 case N_Character_Literal
:
5546 case N_Integer_Literal
:
5547 single
= gnat_to_gnu (choice
);
5548 this_test
= build_binary_op (EQ_EXPR
, integer_type_node
, operand
,
5552 case N_Others_Choice
:
5553 this_test
= integer_one_node
;
5560 result
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
5567 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
5568 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
5571 adjust_packed (tree field_type
, tree record_type
, int packed
)
5573 /* If the field contains an item of variable size, we cannot pack it
5574 because we cannot create temporaries of non-fixed size. */
5575 if (is_variable_size (field_type
))
5578 /* If the alignment of the record is specified and the field type
5579 is over-aligned, request Storage_Unit alignment for the field. */
5582 if (TYPE_ALIGN (field_type
) > TYPE_ALIGN (record_type
))
5591 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
5592 placed in GNU_RECORD_TYPE.
5594 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
5595 record has Component_Alignment of Storage_Unit, -2 if the enclosing
5596 record has a specified alignment.
5598 DEFINITION is true if this field is for a record being defined. */
5601 gnat_to_gnu_field (Entity_Id gnat_field
, tree gnu_record_type
, int packed
,
5604 tree gnu_field_id
= get_entity_name (gnat_field
);
5605 tree gnu_field_type
= gnat_to_gnu_type (Etype (gnat_field
));
5606 tree gnu_field
, gnu_size
, gnu_pos
;
5607 bool needs_strict_alignment
5608 = (Is_Aliased (gnat_field
) || Strict_Alignment (Etype (gnat_field
))
5609 || Treat_As_Volatile (gnat_field
));
5611 /* If this field requires strict alignment, we cannot pack it because
5612 it would very likely be under-aligned in the record. */
5613 if (needs_strict_alignment
)
5616 packed
= adjust_packed (gnu_field_type
, gnu_record_type
, packed
);
5618 /* If a size is specified, use it. Otherwise, if the record type is packed,
5619 use the official RM size. See "Handling of Type'Size Values" in Einfo
5620 for further details. */
5621 if (Known_Static_Esize (gnat_field
))
5622 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
5623 gnat_field
, FIELD_DECL
, false, true);
5624 else if (packed
== 1)
5625 gnu_size
= validate_size (RM_Size (Etype (gnat_field
)), gnu_field_type
,
5626 gnat_field
, FIELD_DECL
, false, true);
5628 gnu_size
= NULL_TREE
;
5630 /* If we have a specified size that's smaller than that of the field type,
5631 or a position is specified, and the field type is also a record that's
5632 BLKmode and with a small constant size, see if we can get an integral
5633 mode form of the type when appropriate. If we can, show a size was
5634 specified for the field if there wasn't one already, so we know to make
5635 this a bitfield and avoid making things wider.
5637 Doing this is first useful if the record is packed because we can then
5638 place the field at a non-byte-aligned position and so achieve tighter
5641 This is in addition *required* if the field shares a byte with another
5642 field and the front-end lets the back-end handle the references, because
5643 GCC does not handle BLKmode bitfields properly.
5645 We avoid the transformation if it is not required or potentially useful,
5646 as it might entail an increase of the field's alignment and have ripple
5647 effects on the outer record type. A typical case is a field known to be
5648 byte aligned and not to share a byte with another field.
5650 Besides, we don't even look the possibility of a transformation in cases
5651 known to be in error already, for instance when an invalid size results
5652 from a component clause. */
5654 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
5655 && TYPE_MODE (gnu_field_type
) == BLKmode
5656 && host_integerp (TYPE_SIZE (gnu_field_type
), 1)
5657 && compare_tree_int (TYPE_SIZE (gnu_field_type
), BIGGEST_ALIGNMENT
) <= 0
5660 && (tree_int_cst_lt (gnu_size
, TYPE_SIZE (gnu_field_type
))
5661 || Present (Component_Clause (gnat_field
))))))
5663 /* See what the alternate type and size would be. */
5664 tree gnu_packable_type
= make_packable_type (gnu_field_type
);
5666 bool has_byte_aligned_clause
5667 = Present (Component_Clause (gnat_field
))
5668 && (UI_To_Int (Component_Bit_Offset (gnat_field
))
5669 % BITS_PER_UNIT
== 0);
5671 /* Compute whether we should avoid the substitution. */
5673 /* There is no point substituting if there is no change... */
5674 = (gnu_packable_type
== gnu_field_type
)
5675 /* ... nor when the field is known to be byte aligned and not to
5676 share a byte with another field. */
5677 || (has_byte_aligned_clause
5678 && value_factor_p (gnu_size
, BITS_PER_UNIT
))
5679 /* The size of an aliased field must be an exact multiple of the
5680 type's alignment, which the substitution might increase. Reject
5681 substitutions that would so invalidate a component clause when the
5682 specified position is byte aligned, as the change would have no
5683 real benefit from the packing standpoint anyway. */
5684 || (Is_Aliased (gnat_field
)
5685 && has_byte_aligned_clause
5686 && !value_factor_p (gnu_size
, TYPE_ALIGN (gnu_packable_type
)));
5688 /* Substitute unless told otherwise. */
5691 gnu_field_type
= gnu_packable_type
;
5694 gnu_size
= rm_size (gnu_field_type
);
5698 /* If we are packing the record and the field is BLKmode, round the
5699 size up to a byte boundary. */
5700 if (packed
&& TYPE_MODE (gnu_field_type
) == BLKmode
&& gnu_size
)
5701 gnu_size
= round_up (gnu_size
, BITS_PER_UNIT
);
5703 if (Present (Component_Clause (gnat_field
)))
5705 gnu_pos
= UI_To_gnu (Component_Bit_Offset (gnat_field
), bitsizetype
);
5706 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
5707 gnat_field
, FIELD_DECL
, false, true);
5709 /* Ensure the position does not overlap with the parent subtype,
5711 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field
)))))
5714 = gnat_to_gnu_type (Parent_Subtype
5715 (Underlying_Type (Scope (gnat_field
))));
5717 if (TREE_CODE (TYPE_SIZE (gnu_parent
)) == INTEGER_CST
5718 && tree_int_cst_lt (gnu_pos
, TYPE_SIZE (gnu_parent
)))
5721 ("offset of& must be beyond parent{, minimum allowed is ^}",
5722 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
5723 TYPE_SIZE_UNIT (gnu_parent
));
5727 /* If this field needs strict alignment, ensure the record is
5728 sufficiently aligned and that that position and size are
5729 consistent with the alignment. */
5730 if (needs_strict_alignment
)
5732 TYPE_ALIGN (gnu_record_type
)
5733 = MAX (TYPE_ALIGN (gnu_record_type
), TYPE_ALIGN (gnu_field_type
));
5736 && !operand_equal_p (gnu_size
, TYPE_SIZE (gnu_field_type
), 0))
5738 if (Is_Atomic (gnat_field
) || Is_Atomic (Etype (gnat_field
)))
5740 ("atomic field& must be natural size of type{ (^)}",
5741 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
5742 TYPE_SIZE (gnu_field_type
));
5744 else if (Is_Aliased (gnat_field
))
5746 ("size of aliased field& must be ^ bits",
5747 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
5748 TYPE_SIZE (gnu_field_type
));
5750 else if (Strict_Alignment (Etype (gnat_field
)))
5752 ("size of & with aliased or tagged components not ^ bits",
5753 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
5754 TYPE_SIZE (gnu_field_type
));
5756 gnu_size
= NULL_TREE
;
5759 if (!integer_zerop (size_binop
5760 (TRUNC_MOD_EXPR
, gnu_pos
,
5761 bitsize_int (TYPE_ALIGN (gnu_field_type
)))))
5763 if (Is_Aliased (gnat_field
))
5765 ("position of aliased field& must be multiple of ^ bits",
5766 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
5767 TYPE_ALIGN (gnu_field_type
));
5769 else if (Treat_As_Volatile (gnat_field
))
5771 ("position of volatile field& must be multiple of ^ bits",
5772 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
5773 TYPE_ALIGN (gnu_field_type
));
5775 else if (Strict_Alignment (Etype (gnat_field
)))
5777 ("position of & with aliased or tagged components not multiple of ^ bits",
5778 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
5779 TYPE_ALIGN (gnu_field_type
));
5784 gnu_pos
= NULL_TREE
;
5788 if (Is_Atomic (gnat_field
))
5789 check_ok_for_atomic (gnu_field_type
, gnat_field
, false);
5792 /* If the record has rep clauses and this is the tag field, make a rep
5793 clause for it as well. */
5794 else if (Has_Specified_Layout (Scope (gnat_field
))
5795 && Chars (gnat_field
) == Name_uTag
)
5797 gnu_pos
= bitsize_zero_node
;
5798 gnu_size
= TYPE_SIZE (gnu_field_type
);
5802 gnu_pos
= NULL_TREE
;
5804 /* We need to make the size the maximum for the type if it is
5805 self-referential and an unconstrained type. In that case, we can't
5806 pack the field since we can't make a copy to align it. */
5807 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
5809 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type
))
5810 && !Is_Constrained (Underlying_Type (Etype (gnat_field
))))
5812 gnu_size
= max_size (TYPE_SIZE (gnu_field_type
), true);
5816 /* If a size is specified, adjust the field's type to it. */
5819 /* If the field's type is justified modular, we would need to remove
5820 the wrapper to (better) meet the layout requirements. However we
5821 can do so only if the field is not aliased to preserve the unique
5822 layout and if the prescribed size is not greater than that of the
5823 packed array to preserve the justification. */
5824 if (!needs_strict_alignment
5825 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
5826 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
5827 && tree_int_cst_compare (gnu_size
, TYPE_ADA_SIZE (gnu_field_type
))
5829 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
5832 = make_type_from_size (gnu_field_type
, gnu_size
,
5833 Has_Biased_Representation (gnat_field
));
5834 gnu_field_type
= maybe_pad_type (gnu_field_type
, gnu_size
, 0, gnat_field
,
5835 "PAD", false, definition
, true);
5838 /* Otherwise (or if there was an error), don't specify a position. */
5840 gnu_pos
= NULL_TREE
;
5842 gcc_assert (TREE_CODE (gnu_field_type
) != RECORD_TYPE
5843 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type
));
5845 /* Now create the decl for the field. */
5846 gnu_field
= create_field_decl (gnu_field_id
, gnu_field_type
, gnu_record_type
,
5847 packed
, gnu_size
, gnu_pos
,
5848 Is_Aliased (gnat_field
));
5849 Sloc_to_locus (Sloc (gnat_field
), &DECL_SOURCE_LOCATION (gnu_field
));
5850 TREE_THIS_VOLATILE (gnu_field
) = Treat_As_Volatile (gnat_field
);
5852 if (Ekind (gnat_field
) == E_Discriminant
)
5853 DECL_DISCRIMINANT_NUMBER (gnu_field
)
5854 = UI_To_gnu (Discriminant_Number (gnat_field
), sizetype
);
5859 /* Return true if TYPE is a type with variable size, a padding type with a
5860 field of variable size or is a record that has a field such a field. */
5863 is_variable_size (tree type
)
5867 /* We need not be concerned about this at all if we don't have
5868 strict alignment. */
5869 if (!STRICT_ALIGNMENT
)
5871 else if (!TREE_CONSTANT (TYPE_SIZE (type
)))
5873 else if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
)
5874 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type
))))
5876 else if (TREE_CODE (type
) != RECORD_TYPE
5877 && TREE_CODE (type
) != UNION_TYPE
5878 && TREE_CODE (type
) != QUAL_UNION_TYPE
)
5881 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
5882 if (is_variable_size (TREE_TYPE (field
)))
5888 /* qsort comparer for the bit positions of two record components. */
5891 compare_field_bitpos (const PTR rt1
, const PTR rt2
)
5893 const_tree
const field1
= * (const_tree
const *) rt1
;
5894 const_tree
const field2
= * (const_tree
const *) rt2
;
5896 = tree_int_cst_compare (bit_position (field1
), bit_position (field2
));
5898 return ret
? ret
: (int) (DECL_UID (field1
) - DECL_UID (field2
));
5901 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
5902 of GCC trees for fields that are in the record and have already been
5903 processed. When called from gnat_to_gnu_entity during the processing of a
5904 record type definition, the GCC nodes for the discriminants will be on
5905 the chain. The other calls to this function are recursive calls from
5906 itself for the Component_List of a variant and the chain is empty.
5908 PACKED is 1 if this is for a packed record, -1 if this is for a record
5909 with Component_Alignment of Storage_Unit, -2 if this is for a record
5910 with a specified alignment.
5912 DEFINITION is true if we are defining this record.
5914 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
5915 with a rep clause is to be added. If it is nonzero, that is all that
5916 should be done with such fields.
5918 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
5919 laying out the record. This means the alignment only serves to force fields
5920 to be bitfields, but not require the record to be that aligned. This is
5923 ALL_REP, if true, means a rep clause was found for all the fields. This
5924 simplifies the logic since we know we're not in the mixed case.
5926 DO_NOT_FINALIZE, if true, means that the record type is expected to be
5927 modified afterwards so it will not be sent to the back-end for finalization.
5929 UNCHECKED_UNION, if true, means that we are building a type for a record
5930 with a Pragma Unchecked_Union.
5932 The processing of the component list fills in the chain with all of the
5933 fields of the record and then the record type is finished. */
5936 components_to_record (tree gnu_record_type
, Node_Id component_list
,
5937 tree gnu_field_list
, int packed
, bool definition
,
5938 tree
*p_gnu_rep_list
, bool cancel_alignment
,
5939 bool all_rep
, bool do_not_finalize
, bool unchecked_union
)
5941 Node_Id component_decl
;
5942 Entity_Id gnat_field
;
5943 Node_Id variant_part
;
5944 tree gnu_our_rep_list
= NULL_TREE
;
5945 tree gnu_field
, gnu_last
;
5946 bool layout_with_rep
= false;
5947 bool all_rep_and_size
= all_rep
&& TYPE_SIZE (gnu_record_type
);
5949 /* For each variable within each component declaration create a GCC field
5950 and add it to the list, skipping any pragmas in the list. */
5951 if (Present (Component_Items (component_list
)))
5952 for (component_decl
= First_Non_Pragma (Component_Items (component_list
));
5953 Present (component_decl
);
5954 component_decl
= Next_Non_Pragma (component_decl
))
5956 gnat_field
= Defining_Entity (component_decl
);
5958 if (Chars (gnat_field
) == Name_uParent
)
5959 gnu_field
= tree_last (TYPE_FIELDS (gnu_record_type
));
5962 gnu_field
= gnat_to_gnu_field (gnat_field
, gnu_record_type
,
5963 packed
, definition
);
5965 /* If this is the _Tag field, put it before any discriminants,
5966 instead of after them as is the case for all other fields.
5967 Ignore field of void type if only annotating. */
5968 if (Chars (gnat_field
) == Name_uTag
)
5969 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
5972 TREE_CHAIN (gnu_field
) = gnu_field_list
;
5973 gnu_field_list
= gnu_field
;
5977 save_gnu_tree (gnat_field
, gnu_field
, false);
5980 /* At the end of the component list there may be a variant part. */
5981 variant_part
= Variant_Part (component_list
);
5983 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
5984 mutually exclusive and should go in the same memory. To do this we need
5985 to treat each variant as a record whose elements are created from the
5986 component list for the variant. So here we create the records from the
5987 lists for the variants and put them all into the QUAL_UNION_TYPE.
5988 If this is an Unchecked_Union, we make a UNION_TYPE instead or
5989 use GNU_RECORD_TYPE if there are no fields so far. */
5990 if (Present (variant_part
))
5992 tree gnu_discriminant
= gnat_to_gnu (Name (variant_part
));
5994 tree gnu_name
= TYPE_NAME (gnu_record_type
);
5996 = concat_id_with_name (get_identifier (Get_Name_String
5997 (Chars (Name (variant_part
)))),
5999 tree gnu_union_type
;
6000 tree gnu_union_name
;
6001 tree gnu_union_field
;
6002 tree gnu_variant_list
= NULL_TREE
;
6004 if (TREE_CODE (gnu_name
) == TYPE_DECL
)
6005 gnu_name
= DECL_NAME (gnu_name
);
6007 gnu_union_name
= concat_id_with_name (gnu_name
,
6008 IDENTIFIER_POINTER (gnu_var_name
));
6010 /* Reuse an enclosing union if all fields are in the variant part
6011 and there is no representation clause on the record, to match
6012 the layout of C unions. There is an associated check below. */
6014 && TREE_CODE (gnu_record_type
) == UNION_TYPE
6015 && !TYPE_PACKED (gnu_record_type
))
6016 gnu_union_type
= gnu_record_type
;
6020 = make_node (unchecked_union
? UNION_TYPE
: QUAL_UNION_TYPE
);
6022 TYPE_NAME (gnu_union_type
) = gnu_union_name
;
6023 TYPE_PACKED (gnu_union_type
) = TYPE_PACKED (gnu_record_type
);
6026 for (variant
= First_Non_Pragma (Variants (variant_part
));
6028 variant
= Next_Non_Pragma (variant
))
6030 tree gnu_variant_type
= make_node (RECORD_TYPE
);
6031 tree gnu_inner_name
;
6034 Get_Variant_Encoding (variant
);
6035 gnu_inner_name
= get_identifier (Name_Buffer
);
6036 TYPE_NAME (gnu_variant_type
)
6037 = concat_id_with_name (gnu_union_name
,
6038 IDENTIFIER_POINTER (gnu_inner_name
));
6040 /* Set the alignment of the inner type in case we need to make
6041 inner objects into bitfields, but then clear it out
6042 so the record actually gets only the alignment required. */
6043 TYPE_ALIGN (gnu_variant_type
) = TYPE_ALIGN (gnu_record_type
);
6044 TYPE_PACKED (gnu_variant_type
) = TYPE_PACKED (gnu_record_type
);
6046 /* Similarly, if the outer record has a size specified and all fields
6047 have record rep clauses, we can propagate the size into the
6049 if (all_rep_and_size
)
6051 TYPE_SIZE (gnu_variant_type
) = TYPE_SIZE (gnu_record_type
);
6052 TYPE_SIZE_UNIT (gnu_variant_type
)
6053 = TYPE_SIZE_UNIT (gnu_record_type
);
6056 /* Create the record type for the variant. Note that we defer
6057 finalizing it until after we are sure to actually use it. */
6058 components_to_record (gnu_variant_type
, Component_List (variant
),
6059 NULL_TREE
, packed
, definition
,
6060 &gnu_our_rep_list
, !all_rep_and_size
, all_rep
,
6061 true, unchecked_union
);
6063 gnu_qual
= choices_to_gnu (gnu_discriminant
,
6064 Discrete_Choices (variant
));
6066 Set_Present_Expr (variant
, annotate_value (gnu_qual
));
6068 /* If this is an Unchecked_Union and we have exactly one field,
6069 use that field here. */
6070 if (unchecked_union
&& TYPE_FIELDS (gnu_variant_type
)
6071 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type
)))
6072 gnu_field
= TYPE_FIELDS (gnu_variant_type
);
6075 /* Deal with packedness like in gnat_to_gnu_field. */
6077 = adjust_packed (gnu_variant_type
, gnu_record_type
, packed
);
6079 /* Finalize the record type now. We used to throw away
6080 empty records but we no longer do that because we need
6081 them to generate complete debug info for the variant;
6082 otherwise, the union type definition will be lacking
6083 the fields associated with these empty variants. */
6084 rest_of_record_type_compilation (gnu_variant_type
);
6086 gnu_field
= create_field_decl (gnu_inner_name
, gnu_variant_type
,
6087 gnu_union_type
, field_packed
,
6089 ? TYPE_SIZE (gnu_variant_type
)
6092 ? bitsize_zero_node
: 0),
6095 DECL_INTERNAL_P (gnu_field
) = 1;
6097 if (!unchecked_union
)
6098 DECL_QUALIFIER (gnu_field
) = gnu_qual
;
6101 TREE_CHAIN (gnu_field
) = gnu_variant_list
;
6102 gnu_variant_list
= gnu_field
;
6105 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
6106 if (gnu_variant_list
)
6108 if (all_rep_and_size
)
6110 TYPE_SIZE (gnu_union_type
) = TYPE_SIZE (gnu_record_type
);
6111 TYPE_SIZE_UNIT (gnu_union_type
)
6112 = TYPE_SIZE_UNIT (gnu_record_type
);
6115 finish_record_type (gnu_union_type
, nreverse (gnu_variant_list
),
6116 all_rep_and_size
? 1 : 0, false);
6118 /* If GNU_UNION_TYPE is our record type, it means we must have an
6119 Unchecked_Union with no fields. Verify that and, if so, just
6121 if (gnu_union_type
== gnu_record_type
)
6123 gcc_assert (unchecked_union
6125 && !gnu_our_rep_list
);
6130 = create_field_decl (gnu_var_name
, gnu_union_type
, gnu_record_type
,
6132 all_rep
? TYPE_SIZE (gnu_union_type
) : 0,
6133 all_rep
? bitsize_zero_node
: 0, 0);
6135 DECL_INTERNAL_P (gnu_union_field
) = 1;
6136 TREE_CHAIN (gnu_union_field
) = gnu_field_list
;
6137 gnu_field_list
= gnu_union_field
;
6141 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6142 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
6143 in a separate pass since we want to handle the discriminants but can't
6144 play with them until we've used them in debugging data above.
6146 ??? Note: if we then reorder them, debugging information will be wrong,
6147 but there's nothing that can be done about this at the moment. */
6148 for (gnu_field
= gnu_field_list
, gnu_last
= NULL_TREE
; gnu_field
; )
6150 if (DECL_FIELD_OFFSET (gnu_field
))
6152 tree gnu_next
= TREE_CHAIN (gnu_field
);
6155 gnu_field_list
= gnu_next
;
6157 TREE_CHAIN (gnu_last
) = gnu_next
;
6159 TREE_CHAIN (gnu_field
) = gnu_our_rep_list
;
6160 gnu_our_rep_list
= gnu_field
;
6161 gnu_field
= gnu_next
;
6165 gnu_last
= gnu_field
;
6166 gnu_field
= TREE_CHAIN (gnu_field
);
6170 /* If we have any items in our rep'ed field list, it is not the case that all
6171 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
6172 set it and ignore the items. */
6173 if (gnu_our_rep_list
&& p_gnu_rep_list
&& !all_rep
)
6174 *p_gnu_rep_list
= chainon (*p_gnu_rep_list
, gnu_our_rep_list
);
6175 else if (gnu_our_rep_list
)
6177 /* Otherwise, sort the fields by bit position and put them into their
6178 own record if we have any fields without rep clauses. */
6180 = (gnu_field_list
? make_node (RECORD_TYPE
) : gnu_record_type
);
6181 int len
= list_length (gnu_our_rep_list
);
6182 tree
*gnu_arr
= (tree
*) alloca (sizeof (tree
) * len
);
6185 for (i
= 0, gnu_field
= gnu_our_rep_list
; gnu_field
;
6186 gnu_field
= TREE_CHAIN (gnu_field
), i
++)
6187 gnu_arr
[i
] = gnu_field
;
6189 qsort (gnu_arr
, len
, sizeof (tree
), compare_field_bitpos
);
6191 /* Put the fields in the list in order of increasing position, which
6192 means we start from the end. */
6193 gnu_our_rep_list
= NULL_TREE
;
6194 for (i
= len
- 1; i
>= 0; i
--)
6196 TREE_CHAIN (gnu_arr
[i
]) = gnu_our_rep_list
;
6197 gnu_our_rep_list
= gnu_arr
[i
];
6198 DECL_CONTEXT (gnu_arr
[i
]) = gnu_rep_type
;
6203 finish_record_type (gnu_rep_type
, gnu_our_rep_list
, 1, false);
6204 gnu_field
= create_field_decl (get_identifier ("REP"), gnu_rep_type
,
6205 gnu_record_type
, 0, 0, 0, 1);
6206 DECL_INTERNAL_P (gnu_field
) = 1;
6207 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
6211 layout_with_rep
= true;
6212 gnu_field_list
= nreverse (gnu_our_rep_list
);
6216 if (cancel_alignment
)
6217 TYPE_ALIGN (gnu_record_type
) = 0;
6219 finish_record_type (gnu_record_type
, nreverse (gnu_field_list
),
6220 layout_with_rep
? 1 : 0, do_not_finalize
);
6223 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
6224 placed into an Esize, Component_Bit_Offset, or Component_Size value
6225 in the GNAT tree. */
6228 annotate_value (tree gnu_size
)
6230 int len
= TREE_CODE_LENGTH (TREE_CODE (gnu_size
));
6232 Node_Ref_Or_Val ops
[3], ret
;
6235 struct tree_int_map
**h
= NULL
;
6237 /* See if we've already saved the value for this node. */
6238 if (EXPR_P (gnu_size
))
6240 struct tree_int_map in
;
6241 if (!annotate_value_cache
)
6242 annotate_value_cache
= htab_create_ggc (512, tree_int_map_hash
,
6243 tree_int_map_eq
, 0);
6244 in
.base
.from
= gnu_size
;
6245 h
= (struct tree_int_map
**)
6246 htab_find_slot (annotate_value_cache
, &in
, INSERT
);
6249 return (Node_Ref_Or_Val
) (*h
)->to
;
6252 /* If we do not return inside this switch, TCODE will be set to the
6253 code to use for a Create_Node operand and LEN (set above) will be
6254 the number of recursive calls for us to make. */
6256 switch (TREE_CODE (gnu_size
))
6259 if (TREE_OVERFLOW (gnu_size
))
6262 /* This may have come from a conversion from some smaller type,
6263 so ensure this is in bitsizetype. */
6264 gnu_size
= convert (bitsizetype
, gnu_size
);
6266 /* For negative values, use NEGATE_EXPR of the supplied value. */
6267 if (tree_int_cst_sgn (gnu_size
) < 0)
6269 /* The ridiculous code below is to handle the case of the largest
6270 negative integer. */
6271 tree negative_size
= size_diffop (bitsize_zero_node
, gnu_size
);
6272 bool adjust
= false;
6275 if (TREE_OVERFLOW (negative_size
))
6278 = size_binop (MINUS_EXPR
, bitsize_zero_node
,
6279 size_binop (PLUS_EXPR
, gnu_size
,
6284 temp
= build1 (NEGATE_EXPR
, bitsizetype
, negative_size
);
6286 temp
= build2 (MINUS_EXPR
, bitsizetype
, temp
, bitsize_one_node
);
6288 return annotate_value (temp
);
6291 if (!host_integerp (gnu_size
, 1))
6294 size
= tree_low_cst (gnu_size
, 1);
6296 /* This peculiar test is to make sure that the size fits in an int
6297 on machines where HOST_WIDE_INT is not "int". */
6298 if (tree_low_cst (gnu_size
, 1) == size
)
6299 return UI_From_Int (size
);
6304 /* The only case we handle here is a simple discriminant reference. */
6305 if (TREE_CODE (TREE_OPERAND (gnu_size
, 0)) == PLACEHOLDER_EXPR
6306 && TREE_CODE (TREE_OPERAND (gnu_size
, 1)) == FIELD_DECL
6307 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size
, 1)))
6308 return Create_Node (Discrim_Val
,
6309 annotate_value (DECL_DISCRIMINANT_NUMBER
6310 (TREE_OPERAND (gnu_size
, 1))),
6315 case NOP_EXPR
: case CONVERT_EXPR
: case NON_LVALUE_EXPR
:
6316 return annotate_value (TREE_OPERAND (gnu_size
, 0));
6318 /* Now just list the operations we handle. */
6319 case COND_EXPR
: tcode
= Cond_Expr
; break;
6320 case PLUS_EXPR
: tcode
= Plus_Expr
; break;
6321 case MINUS_EXPR
: tcode
= Minus_Expr
; break;
6322 case MULT_EXPR
: tcode
= Mult_Expr
; break;
6323 case TRUNC_DIV_EXPR
: tcode
= Trunc_Div_Expr
; break;
6324 case CEIL_DIV_EXPR
: tcode
= Ceil_Div_Expr
; break;
6325 case FLOOR_DIV_EXPR
: tcode
= Floor_Div_Expr
; break;
6326 case TRUNC_MOD_EXPR
: tcode
= Trunc_Mod_Expr
; break;
6327 case CEIL_MOD_EXPR
: tcode
= Ceil_Mod_Expr
; break;
6328 case FLOOR_MOD_EXPR
: tcode
= Floor_Mod_Expr
; break;
6329 case EXACT_DIV_EXPR
: tcode
= Exact_Div_Expr
; break;
6330 case NEGATE_EXPR
: tcode
= Negate_Expr
; break;
6331 case MIN_EXPR
: tcode
= Min_Expr
; break;
6332 case MAX_EXPR
: tcode
= Max_Expr
; break;
6333 case ABS_EXPR
: tcode
= Abs_Expr
; break;
6334 case TRUTH_ANDIF_EXPR
: tcode
= Truth_Andif_Expr
; break;
6335 case TRUTH_ORIF_EXPR
: tcode
= Truth_Orif_Expr
; break;
6336 case TRUTH_AND_EXPR
: tcode
= Truth_And_Expr
; break;
6337 case TRUTH_OR_EXPR
: tcode
= Truth_Or_Expr
; break;
6338 case TRUTH_XOR_EXPR
: tcode
= Truth_Xor_Expr
; break;
6339 case TRUTH_NOT_EXPR
: tcode
= Truth_Not_Expr
; break;
6340 case BIT_AND_EXPR
: tcode
= Bit_And_Expr
; break;
6341 case LT_EXPR
: tcode
= Lt_Expr
; break;
6342 case LE_EXPR
: tcode
= Le_Expr
; break;
6343 case GT_EXPR
: tcode
= Gt_Expr
; break;
6344 case GE_EXPR
: tcode
= Ge_Expr
; break;
6345 case EQ_EXPR
: tcode
= Eq_Expr
; break;
6346 case NE_EXPR
: tcode
= Ne_Expr
; break;
6352 /* Now get each of the operands that's relevant for this code. If any
6353 cannot be expressed as a repinfo node, say we can't. */
6354 for (i
= 0; i
< 3; i
++)
6357 for (i
= 0; i
< len
; i
++)
6359 ops
[i
] = annotate_value (TREE_OPERAND (gnu_size
, i
));
6360 if (ops
[i
] == No_Uint
)
6364 ret
= Create_Node (tcode
, ops
[0], ops
[1], ops
[2]);
6366 /* Save the result in the cache. */
6369 *h
= ggc_alloc (sizeof (struct tree_int_map
));
6370 (*h
)->base
.from
= gnu_size
;
6377 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6378 GCC type, set Component_Bit_Offset and Esize to the position and size
6382 annotate_rep (Entity_Id gnat_entity
, tree gnu_type
)
6386 Entity_Id gnat_field
;
6388 /* We operate by first making a list of all fields and their positions
6389 (we can get the sizes easily at any time) by a recursive call
6390 and then update all the sizes into the tree. */
6391 gnu_list
= compute_field_positions (gnu_type
, NULL_TREE
,
6392 size_zero_node
, bitsize_zero_node
,
6395 for (gnat_field
= First_Entity (gnat_entity
); Present (gnat_field
);
6396 gnat_field
= Next_Entity (gnat_field
))
6397 if ((Ekind (gnat_field
) == E_Component
6398 || (Ekind (gnat_field
) == E_Discriminant
6399 && !Is_Unchecked_Union (Scope (gnat_field
)))))
6401 tree parent_offset
= bitsize_zero_node
;
6403 gnu_entry
= purpose_member (gnat_to_gnu_field_decl (gnat_field
),
6408 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
6410 /* In this mode the tag and parent components have not been
6411 generated, so we add the appropriate offset to each
6412 component. For a component appearing in the current
6413 extension, the offset is the size of the parent. */
6414 if (Is_Derived_Type (gnat_entity
)
6415 && Original_Record_Component (gnat_field
) == gnat_field
)
6417 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity
))),
6420 parent_offset
= bitsize_int (POINTER_SIZE
);
6423 Set_Component_Bit_Offset
6426 (size_binop (PLUS_EXPR
,
6427 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry
)),
6428 TREE_VALUE (TREE_VALUE
6429 (TREE_VALUE (gnu_entry
)))),
6432 Set_Esize (gnat_field
,
6433 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry
))));
6435 else if (Is_Tagged_Type (gnat_entity
)
6436 && Is_Derived_Type (gnat_entity
))
6438 /* If there is no gnu_entry, this is an inherited component whose
6439 position is the same as in the parent type. */
6440 Set_Component_Bit_Offset
6442 Component_Bit_Offset (Original_Record_Component (gnat_field
)));
6443 Set_Esize (gnat_field
,
6444 Esize (Original_Record_Component (gnat_field
)));
6449 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
6450 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
6451 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
6452 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
6453 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
6454 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
6458 compute_field_positions (tree gnu_type
, tree gnu_list
, tree gnu_pos
,
6459 tree gnu_bitpos
, unsigned int offset_align
)
6462 tree gnu_result
= gnu_list
;
6464 for (gnu_field
= TYPE_FIELDS (gnu_type
); gnu_field
;
6465 gnu_field
= TREE_CHAIN (gnu_field
))
6467 tree gnu_our_bitpos
= size_binop (PLUS_EXPR
, gnu_bitpos
,
6468 DECL_FIELD_BIT_OFFSET (gnu_field
));
6469 tree gnu_our_offset
= size_binop (PLUS_EXPR
, gnu_pos
,
6470 DECL_FIELD_OFFSET (gnu_field
));
6471 unsigned int our_offset_align
6472 = MIN (offset_align
, DECL_OFFSET_ALIGN (gnu_field
));
6475 = tree_cons (gnu_field
,
6476 tree_cons (gnu_our_offset
,
6477 tree_cons (size_int (our_offset_align
),
6478 gnu_our_bitpos
, NULL_TREE
),
6482 if (DECL_INTERNAL_P (gnu_field
))
6484 = compute_field_positions (TREE_TYPE (gnu_field
), gnu_result
,
6485 gnu_our_offset
, gnu_our_bitpos
,
6492 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
6493 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
6494 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
6495 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
6496 for the size of a field. COMPONENT_P is true if we are being called
6497 to process the Component_Size of GNAT_OBJECT. This is used for error
6498 message handling and to indicate to use the object size of GNU_TYPE.
6499 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
6500 it means that a size of zero should be treated as an unspecified size. */
6503 validate_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_object
,
6504 enum tree_code kind
, bool component_p
, bool zero_ok
)
6506 Node_Id gnat_error_node
;
6507 tree type_size
, size
;
6509 if (kind
== VAR_DECL
6510 /* If a type needs strict alignment, a component of this type in
6511 a packed record cannot be packed and thus uses the type size. */
6512 || (kind
== TYPE_DECL
&& Strict_Alignment (gnat_object
)))
6513 type_size
= TYPE_SIZE (gnu_type
);
6515 type_size
= rm_size (gnu_type
);
6517 /* Find the node to use for errors. */
6518 if ((Ekind (gnat_object
) == E_Component
6519 || Ekind (gnat_object
) == E_Discriminant
)
6520 && Present (Component_Clause (gnat_object
)))
6521 gnat_error_node
= Last_Bit (Component_Clause (gnat_object
));
6522 else if (Present (Size_Clause (gnat_object
)))
6523 gnat_error_node
= Expression (Size_Clause (gnat_object
));
6525 gnat_error_node
= gnat_object
;
6527 /* Return 0 if no size was specified, either because Esize was not Present or
6528 the specified size was zero. */
6529 if (No (uint_size
) || uint_size
== No_Uint
)
6532 /* Get the size as a tree. Give an error if a size was specified, but cannot
6533 be represented as in sizetype. */
6534 size
= UI_To_gnu (uint_size
, bitsizetype
);
6535 if (TREE_OVERFLOW (size
))
6537 post_error_ne (component_p
? "component size of & is too large"
6538 : "size of & is too large",
6539 gnat_error_node
, gnat_object
);
6543 /* Ignore a negative size since that corresponds to our back-annotation.
6544 Also ignore a zero size unless a size clause exists. */
6545 else if (tree_int_cst_sgn (size
) < 0 || (integer_zerop (size
) && !zero_ok
))
6548 /* The size of objects is always a multiple of a byte. */
6549 if (kind
== VAR_DECL
6550 && !integer_zerop (size_binop (TRUNC_MOD_EXPR
, size
, bitsize_unit_node
)))
6553 post_error_ne ("component size for& is not a multiple of Storage_Unit",
6554 gnat_error_node
, gnat_object
);
6556 post_error_ne ("size for& is not a multiple of Storage_Unit",
6557 gnat_error_node
, gnat_object
);
6561 /* If this is an integral type or a packed array type, the front-end has
6562 verified the size, so we need not do it here (which would entail
6563 checking against the bounds). However, if this is an aliased object, it
6564 may not be smaller than the type of the object. */
6565 if ((INTEGRAL_TYPE_P (gnu_type
) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type
))
6566 && !(kind
== VAR_DECL
&& Is_Aliased (gnat_object
)))
6569 /* If the object is a record that contains a template, add the size of
6570 the template to the specified size. */
6571 if (TREE_CODE (gnu_type
) == RECORD_TYPE
6572 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
6573 size
= size_binop (PLUS_EXPR
, DECL_SIZE (TYPE_FIELDS (gnu_type
)), size
);
6575 /* Modify the size of the type to be that of the maximum size if it has a
6576 discriminant or the size of a thin pointer if this is a fat pointer. */
6577 if (type_size
&& CONTAINS_PLACEHOLDER_P (type_size
))
6578 type_size
= max_size (type_size
, true);
6579 else if (TYPE_FAT_POINTER_P (gnu_type
))
6580 type_size
= bitsize_int (POINTER_SIZE
);
6582 /* If this is an access type, the minimum size is that given by the smallest
6583 integral mode that's valid for pointers. */
6584 if (TREE_CODE (gnu_type
) == POINTER_TYPE
)
6586 enum machine_mode p_mode
;
6588 for (p_mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
6589 !targetm
.valid_pointer_mode (p_mode
);
6590 p_mode
= GET_MODE_WIDER_MODE (p_mode
))
6593 type_size
= bitsize_int (GET_MODE_BITSIZE (p_mode
));
6596 /* If the size of the object is a constant, the new size must not be
6598 if (TREE_CODE (type_size
) != INTEGER_CST
6599 || TREE_OVERFLOW (type_size
)
6600 || tree_int_cst_lt (size
, type_size
))
6604 ("component size for& too small{, minimum allowed is ^}",
6605 gnat_error_node
, gnat_object
, type_size
);
6607 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
6608 gnat_error_node
, gnat_object
, type_size
);
6610 if (kind
== VAR_DECL
&& !component_p
6611 && TREE_CODE (rm_size (gnu_type
)) == INTEGER_CST
6612 && !tree_int_cst_lt (size
, rm_size (gnu_type
)))
6613 post_error_ne_tree_2
6614 ("\\size of ^ is not a multiple of alignment (^ bits)",
6615 gnat_error_node
, gnat_object
, rm_size (gnu_type
),
6616 TYPE_ALIGN (gnu_type
));
6618 else if (INTEGRAL_TYPE_P (gnu_type
))
6619 post_error_ne ("\\size would be legal if & were not aliased!",
6620 gnat_error_node
, gnat_object
);
6628 /* Similarly, but both validate and process a value of RM_Size. This
6629 routine is only called for types. */
6632 set_rm_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_entity
)
6634 /* Only give an error if a Value_Size clause was explicitly given.
6635 Otherwise, we'd be duplicating an error on the Size clause. */
6636 Node_Id gnat_attr_node
6637 = Get_Attribute_Definition_Clause (gnat_entity
, Attr_Value_Size
);
6638 tree old_size
= rm_size (gnu_type
);
6641 /* Get the size as a tree. Do nothing if none was specified, either
6642 because RM_Size was not Present or if the specified size was zero.
6643 Give an error if a size was specified, but cannot be represented as
6645 if (No (uint_size
) || uint_size
== No_Uint
)
6648 size
= UI_To_gnu (uint_size
, bitsizetype
);
6649 if (TREE_OVERFLOW (size
))
6651 if (Present (gnat_attr_node
))
6652 post_error_ne ("Value_Size of & is too large", gnat_attr_node
,
6658 /* Ignore a negative size since that corresponds to our back-annotation.
6659 Also ignore a zero size unless a size clause exists, a Value_Size
6660 clause exists, or this is an integer type, in which case the
6661 front end will have always set it. */
6662 else if (tree_int_cst_sgn (size
) < 0
6663 || (integer_zerop (size
) && No (gnat_attr_node
)
6664 && !Has_Size_Clause (gnat_entity
)
6665 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity
)))
6668 /* If the old size is self-referential, get the maximum size. */
6669 if (CONTAINS_PLACEHOLDER_P (old_size
))
6670 old_size
= max_size (old_size
, true);
6672 /* If the size of the object is a constant, the new size must not be
6673 smaller (the front end checks this for scalar types). */
6674 if (TREE_CODE (old_size
) != INTEGER_CST
6675 || TREE_OVERFLOW (old_size
)
6676 || (AGGREGATE_TYPE_P (gnu_type
)
6677 && tree_int_cst_lt (size
, old_size
)))
6679 if (Present (gnat_attr_node
))
6681 ("Value_Size for& too small{, minimum allowed is ^}",
6682 gnat_attr_node
, gnat_entity
, old_size
);
6687 /* Otherwise, set the RM_Size. */
6688 if (TREE_CODE (gnu_type
) == INTEGER_TYPE
6689 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
6690 TYPE_RM_SIZE_NUM (gnu_type
) = size
;
6691 else if (TREE_CODE (gnu_type
) == ENUMERAL_TYPE
)
6692 TYPE_RM_SIZE_NUM (gnu_type
) = size
;
6693 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
6694 || TREE_CODE (gnu_type
) == UNION_TYPE
6695 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
6696 && !TYPE_IS_FAT_POINTER_P (gnu_type
))
6697 SET_TYPE_ADA_SIZE (gnu_type
, size
);
6700 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
6701 If TYPE is the best type, return it. Otherwise, make a new type. We
6702 only support new integral and pointer types. BIASED_P is nonzero if
6703 we are making a biased type. */
6706 make_type_from_size (tree type
, tree size_tree
, bool biased_p
)
6709 unsigned HOST_WIDE_INT size
;
6712 /* If size indicates an error, just return TYPE to avoid propagating the
6713 error. Likewise if it's too large to represent. */
6714 if (!size_tree
|| !host_integerp (size_tree
, 1))
6717 size
= tree_low_cst (size_tree
, 1);
6718 switch (TREE_CODE (type
))
6722 /* Only do something if the type is not already the proper size and is
6723 not a packed array type. */
6724 if (TYPE_PACKED_ARRAY_TYPE_P (type
)
6725 || (TYPE_PRECISION (type
) == size
6726 && biased_p
== (TREE_CODE (type
) == INTEGER_CST
6727 && TYPE_BIASED_REPRESENTATION_P (type
))))
6730 biased_p
|= (TREE_CODE (type
) == INTEGER_TYPE
6731 && TYPE_BIASED_REPRESENTATION_P (type
));
6732 unsigned_p
= TYPE_UNSIGNED (type
) || biased_p
;
6734 size
= MIN (size
, LONG_LONG_TYPE_SIZE
);
6736 = unsigned_p
? make_unsigned_type (size
) : make_signed_type (size
);
6737 TREE_TYPE (new_type
) = TREE_TYPE (type
) ? TREE_TYPE (type
) : type
;
6738 TYPE_MIN_VALUE (new_type
)
6739 = convert (TREE_TYPE (new_type
), TYPE_MIN_VALUE (type
));
6740 TYPE_MAX_VALUE (new_type
)
6741 = convert (TREE_TYPE (new_type
), TYPE_MAX_VALUE (type
));
6742 TYPE_BIASED_REPRESENTATION_P (new_type
) = biased_p
;
6743 TYPE_RM_SIZE_NUM (new_type
) = bitsize_int (size
);
6747 /* Do something if this is a fat pointer, in which case we
6748 may need to return the thin pointer. */
6749 if (TYPE_IS_FAT_POINTER_P (type
) && size
< POINTER_SIZE
* 2)
6752 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type
)));
6756 /* Only do something if this is a thin pointer, in which case we
6757 may need to return the fat pointer. */
6758 if (TYPE_THIN_POINTER_P (type
) && size
>= POINTER_SIZE
* 2)
6760 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)));
6771 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
6772 a type or object whose present alignment is ALIGN. If this alignment is
6773 valid, return it. Otherwise, give an error and return ALIGN. */
6776 validate_alignment (Uint alignment
, Entity_Id gnat_entity
, unsigned int align
)
6778 Node_Id gnat_error_node
= gnat_entity
;
6779 unsigned int new_align
;
6781 unsigned int max_allowed_alignment
= get_target_maximum_allowed_alignment ();
6783 if (Present (Alignment_Clause (gnat_entity
)))
6784 gnat_error_node
= Expression (Alignment_Clause (gnat_entity
));
6786 /* Don't worry about checking alignment if alignment was not specified
6787 by the source program and we already posted an error for this entity. */
6789 if (Error_Posted (gnat_entity
) && !Has_Alignment_Clause (gnat_entity
))
6792 /* Within GCC, an alignment is an integer, so we must make sure a value is
6793 specified that fits in that range. Also, there is an upper bound to
6794 alignments we can support/allow. */
6796 if (! UI_Is_In_Int_Range (alignment
)
6797 || ((new_align
= UI_To_Int (alignment
)) > max_allowed_alignment
))
6798 post_error_ne_num ("largest supported alignment for& is ^",
6799 gnat_error_node
, gnat_entity
, max_allowed_alignment
);
6800 else if (!(Present (Alignment_Clause (gnat_entity
))
6801 && From_At_Mod (Alignment_Clause (gnat_entity
)))
6802 && new_align
* BITS_PER_UNIT
< align
)
6803 post_error_ne_num ("alignment for& must be at least ^",
6804 gnat_error_node
, gnat_entity
,
6805 align
/ BITS_PER_UNIT
);
6807 align
= MAX (align
, new_align
== 0 ? 1 : new_align
* BITS_PER_UNIT
);
6812 /* Return the smallest alignment not less than SIZE. */
6815 ceil_alignment (unsigned HOST_WIDE_INT size
)
6817 return (unsigned int) 1 << (floor_log2 (size
- 1) + 1);
6820 /* Verify that OBJECT, a type or decl, is something we can implement
6821 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
6822 if we require atomic components. */
6825 check_ok_for_atomic (tree object
, Entity_Id gnat_entity
, bool comp_p
)
6827 Node_Id gnat_error_point
= gnat_entity
;
6829 enum machine_mode mode
;
6833 /* There are three case of what OBJECT can be. It can be a type, in which
6834 case we take the size, alignment and mode from the type. It can be a
6835 declaration that was indirect, in which case the relevant values are
6836 that of the type being pointed to, or it can be a normal declaration,
6837 in which case the values are of the decl. The code below assumes that
6838 OBJECT is either a type or a decl. */
6839 if (TYPE_P (object
))
6841 mode
= TYPE_MODE (object
);
6842 align
= TYPE_ALIGN (object
);
6843 size
= TYPE_SIZE (object
);
6845 else if (DECL_BY_REF_P (object
))
6847 mode
= TYPE_MODE (TREE_TYPE (TREE_TYPE (object
)));
6848 align
= TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object
)));
6849 size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (object
)));
6853 mode
= DECL_MODE (object
);
6854 align
= DECL_ALIGN (object
);
6855 size
= DECL_SIZE (object
);
6858 /* Consider all floating-point types atomic and any types that that are
6859 represented by integers no wider than a machine word. */
6860 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
6861 || ((GET_MODE_CLASS (mode
) == MODE_INT
6862 || GET_MODE_CLASS (mode
) == MODE_PARTIAL_INT
)
6863 && GET_MODE_BITSIZE (mode
) <= BITS_PER_WORD
))
6866 /* For the moment, also allow anything that has an alignment equal
6867 to its size and which is smaller than a word. */
6868 if (size
&& TREE_CODE (size
) == INTEGER_CST
6869 && compare_tree_int (size
, align
) == 0
6870 && align
<= BITS_PER_WORD
)
6873 for (gnat_node
= First_Rep_Item (gnat_entity
); Present (gnat_node
);
6874 gnat_node
= Next_Rep_Item (gnat_node
))
6876 if (!comp_p
&& Nkind (gnat_node
) == N_Pragma
6877 && Get_Pragma_Id (Chars (gnat_node
)) == Pragma_Atomic
)
6878 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
6879 else if (comp_p
&& Nkind (gnat_node
) == N_Pragma
6880 && (Get_Pragma_Id (Chars (gnat_node
))
6881 == Pragma_Atomic_Components
))
6882 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
6886 post_error_ne ("atomic access to component of & cannot be guaranteed",
6887 gnat_error_point
, gnat_entity
);
6889 post_error_ne ("atomic access to & cannot be guaranteed",
6890 gnat_error_point
, gnat_entity
);
6893 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
6894 have compatible signatures so that a call using one type may be safely
6895 issued if the actual target function type is the other. Return 1 if it is
6896 the case, 0 otherwise, and post errors on the incompatibilities.
6898 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
6899 that calls to the subprogram will have arguments suitable for the later
6900 underlying builtin expansion. */
6903 compatible_signatures_p (tree ftype1
, tree ftype2
)
6905 /* As of now, we only perform very trivial tests and consider it's the
6906 programmer's responsibility to ensure the type correctness in the Ada
6907 declaration, as in the regular Import cases.
6909 Mismatches typically result in either error messages from the builtin
6910 expander, internal compiler errors, or in a real call sequence. This
6911 should be refined to issue diagnostics helping error detection and
6914 /* Almost fake test, ensuring a use of each argument. */
6915 if (ftype1
== ftype2
)
6921 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
6922 type with all size expressions that contain F updated by replacing F
6923 with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
6924 nothing has changed. */
6927 substitute_in_type (tree t
, tree f
, tree r
)
6932 switch (TREE_CODE (t
))
6937 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t
))
6938 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t
)))
6940 tree low
= SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t
), f
, r
);
6941 tree high
= SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t
), f
, r
);
6943 if (low
== TYPE_MIN_VALUE (t
) && high
== TYPE_MAX_VALUE (t
))
6946 new = build_range_type (TREE_TYPE (t
), low
, high
);
6947 if (TYPE_INDEX_TYPE (t
))
6949 (new, substitute_in_type (TYPE_INDEX_TYPE (t
), f
, r
));
6956 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t
))
6957 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t
)))
6959 tree low
= NULL_TREE
, high
= NULL_TREE
;
6961 if (TYPE_MIN_VALUE (t
))
6962 low
= SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t
), f
, r
);
6963 if (TYPE_MAX_VALUE (t
))
6964 high
= SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t
), f
, r
);
6966 if (low
== TYPE_MIN_VALUE (t
) && high
== TYPE_MAX_VALUE (t
))
6970 TYPE_MIN_VALUE (t
) = low
;
6971 TYPE_MAX_VALUE (t
) = high
;
6976 tem
= substitute_in_type (TREE_TYPE (t
), f
, r
);
6977 if (tem
== TREE_TYPE (t
))
6980 return build_complex_type (tem
);
6986 /* Don't know how to do these yet. */
6991 tree component
= substitute_in_type (TREE_TYPE (t
), f
, r
);
6992 tree domain
= substitute_in_type (TYPE_DOMAIN (t
), f
, r
);
6994 if (component
== TREE_TYPE (t
) && domain
== TYPE_DOMAIN (t
))
6997 new = build_array_type (component
, domain
);
6998 TYPE_SIZE (new) = 0;
6999 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t
);
7000 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t
);
7002 TYPE_ALIGN (new) = TYPE_ALIGN (t
);
7003 TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t
);
7005 /* If we had bounded the sizes of T by a constant, bound the sizes of
7006 NEW by the same constant. */
7007 if (TREE_CODE (TYPE_SIZE (t
)) == MIN_EXPR
)
7009 = size_binop (MIN_EXPR
, TREE_OPERAND (TYPE_SIZE (t
), 1),
7011 if (TREE_CODE (TYPE_SIZE_UNIT (t
)) == MIN_EXPR
)
7012 TYPE_SIZE_UNIT (new)
7013 = size_binop (MIN_EXPR
, TREE_OPERAND (TYPE_SIZE_UNIT (t
), 1),
7014 TYPE_SIZE_UNIT (new));
7020 case QUAL_UNION_TYPE
:
7024 = (f
== NULL_TREE
&& !TREE_CONSTANT (TYPE_SIZE (t
)));
7025 bool field_has_rep
= false;
7026 tree last_field
= NULL_TREE
;
7028 tree
new = copy_type (t
);
7030 /* Start out with no fields, make new fields, and chain them
7031 in. If we haven't actually changed the type of any field,
7032 discard everything we've done and return the old type. */
7034 TYPE_FIELDS (new) = NULL_TREE
;
7035 TYPE_SIZE (new) = NULL_TREE
;
7037 for (field
= TYPE_FIELDS (t
); field
; field
= TREE_CHAIN (field
))
7039 tree new_field
= copy_node (field
);
7041 TREE_TYPE (new_field
)
7042 = substitute_in_type (TREE_TYPE (new_field
), f
, r
);
7044 if (DECL_HAS_REP_P (field
) && !DECL_INTERNAL_P (field
))
7045 field_has_rep
= true;
7046 else if (TREE_TYPE (new_field
) != TREE_TYPE (field
))
7047 changed_field
= true;
7049 /* If this is an internal field and the type of this field is
7050 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
7051 the type just has one element, treat that as the field.
7052 But don't do this if we are processing a QUAL_UNION_TYPE. */
7053 if (TREE_CODE (t
) != QUAL_UNION_TYPE
7054 && DECL_INTERNAL_P (new_field
)
7055 && (TREE_CODE (TREE_TYPE (new_field
)) == UNION_TYPE
7056 || TREE_CODE (TREE_TYPE (new_field
)) == RECORD_TYPE
))
7058 if (!TYPE_FIELDS (TREE_TYPE (new_field
)))
7061 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field
))))
7064 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field
)));
7066 /* Make sure omitting the union doesn't change
7068 DECL_ALIGN (next_new_field
) = DECL_ALIGN (new_field
);
7069 new_field
= next_new_field
;
7073 DECL_CONTEXT (new_field
) = new;
7074 SET_DECL_ORIGINAL_FIELD (new_field
,
7075 (DECL_ORIGINAL_FIELD (field
)
7076 ? DECL_ORIGINAL_FIELD (field
) : field
));
7078 /* If the size of the old field was set at a constant,
7079 propagate the size in case the type's size was variable.
7080 (This occurs in the case of a variant or discriminated
7081 record with a default size used as a field of another
7083 DECL_SIZE (new_field
)
7084 = TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
7085 ? DECL_SIZE (field
) : NULL_TREE
;
7086 DECL_SIZE_UNIT (new_field
)
7087 = TREE_CODE (DECL_SIZE_UNIT (field
)) == INTEGER_CST
7088 ? DECL_SIZE_UNIT (field
) : NULL_TREE
;
7090 if (TREE_CODE (t
) == QUAL_UNION_TYPE
)
7092 tree new_q
= SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field
), f
, r
);
7094 if (new_q
!= DECL_QUALIFIER (new_field
))
7095 changed_field
= true;
7097 /* Do the substitution inside the qualifier and if we find
7098 that this field will not be present, omit it. */
7099 DECL_QUALIFIER (new_field
) = new_q
;
7101 if (integer_zerop (DECL_QUALIFIER (new_field
)))
7106 TYPE_FIELDS (new) = new_field
;
7108 TREE_CHAIN (last_field
) = new_field
;
7110 last_field
= new_field
;
7112 /* If this is a qualified type and this field will always be
7113 present, we are done. */
7114 if (TREE_CODE (t
) == QUAL_UNION_TYPE
7115 && integer_onep (DECL_QUALIFIER (new_field
)))
7119 /* If this used to be a qualified union type, but we now know what
7120 field will be present, make this a normal union. */
7121 if (changed_field
&& TREE_CODE (new) == QUAL_UNION_TYPE
7122 && (!TYPE_FIELDS (new)
7123 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
7124 TREE_SET_CODE (new, UNION_TYPE
);
7125 else if (!changed_field
)
7128 gcc_assert (!field_has_rep
);
7131 /* If the size was originally a constant use it. */
7132 if (TYPE_SIZE (t
) && TREE_CODE (TYPE_SIZE (t
)) == INTEGER_CST
7133 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST
)
7135 TYPE_SIZE (new) = TYPE_SIZE (t
);
7136 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t
);
7137 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t
));
7148 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
7149 needed to represent the object. */
7152 rm_size (tree gnu_type
)
7154 /* For integer types, this is the precision. For record types, we store
7155 the size explicitly. For other types, this is just the size. */
7157 if (INTEGRAL_TYPE_P (gnu_type
) && TYPE_RM_SIZE (gnu_type
))
7158 return TYPE_RM_SIZE (gnu_type
);
7159 else if (TREE_CODE (gnu_type
) == RECORD_TYPE
7160 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7161 /* Return the rm_size of the actual data plus the size of the template. */
7163 size_binop (PLUS_EXPR
,
7164 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)))),
7165 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
7166 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
7167 || TREE_CODE (gnu_type
) == UNION_TYPE
7168 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
7169 && !TYPE_IS_FAT_POINTER_P (gnu_type
)
7170 && TYPE_ADA_SIZE (gnu_type
))
7171 return TYPE_ADA_SIZE (gnu_type
);
7173 return TYPE_SIZE (gnu_type
);
7176 /* Return an identifier representing the external name to be used for
7177 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
7178 and the specified suffix. */
7181 create_concat_name (Entity_Id gnat_entity
, const char *suffix
)
7183 Entity_Kind kind
= Ekind (gnat_entity
);
7185 const char *str
= (!suffix
? "" : suffix
);
7186 String_Template temp
= {1, strlen (str
)};
7187 Fat_Pointer fp
= {str
, &temp
};
7189 Get_External_Name_With_Suffix (gnat_entity
, fp
);
7191 /* A variable using the Stdcall convention (meaning we are running
7192 on a Windows box) live in a DLL. Here we adjust its name to use
7193 the jump-table, the _imp__NAME contains the address for the NAME
7195 if ((kind
== E_Variable
|| kind
== E_Constant
)
7196 && Has_Stdcall_Convention (gnat_entity
))
7198 const char *prefix
= "_imp__";
7199 int k
, plen
= strlen (prefix
);
7201 for (k
= 0; k
<= Name_Len
; k
++)
7202 Name_Buffer
[Name_Len
- k
+ plen
] = Name_Buffer
[Name_Len
- k
];
7203 strncpy (Name_Buffer
, prefix
, plen
);
7206 return get_identifier (Name_Buffer
);
7209 /* Return the name to be used for GNAT_ENTITY. If a type, create a
7210 fully-qualified name, possibly with type information encoding.
7211 Otherwise, return the name. */
7214 get_entity_name (Entity_Id gnat_entity
)
7216 Get_Encoded_Name (gnat_entity
);
7217 return get_identifier (Name_Buffer
);
7220 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
7221 string, return a new IDENTIFIER_NODE that is the concatenation of
7222 the name in GNU_ID and SUFFIX. */
7225 concat_id_with_name (tree gnu_id
, const char *suffix
)
7227 int len
= IDENTIFIER_LENGTH (gnu_id
);
7229 strncpy (Name_Buffer
, IDENTIFIER_POINTER (gnu_id
),
7230 IDENTIFIER_LENGTH (gnu_id
));
7231 strncpy (Name_Buffer
+ len
, "___", 3);
7233 strcpy (Name_Buffer
+ len
, suffix
);
7234 return get_identifier (Name_Buffer
);
7237 #include "gt-ada-decl.h"